/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
- Inc.
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software
+ Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
#include "config.h"
#include "system.h"
#include "flags.h"
-
-#include <string.h>
-
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
static gfc_expr *
range_check (gfc_expr * result, const char *name)
{
-
if (gfc_range_check (result) == ARITH_OK)
return result;
}
+/* 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;
+
+ 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);
+
+ /* We negate the number by hand, zeroing the high bits, that is
+ make it the corresponding positive number, and then have it
+ negated by GMP, giving the correct representation of the
+ negative number. */
+ 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;
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;
return range_check (result, "ACOS");
}
+gfc_expr *
+gfc_simplify_acosh (gfc_expr * x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) < 0)
+ {
+ gfc_error ("Argument of ACOSH at %L must not be less than 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ACOSH");
+}
gfc_expr *
gfc_simplify_adjustl (gfc_expr * e)
gfc_expr *
gfc_simplify_aimag (gfc_expr * e)
{
+
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
-
}
gfc_expr *
gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
{
- gfc_expr *rtrunc, *result;
- int kind, cmp;
- mpfr_t half;
+ gfc_expr *result;
+ int kind;
kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
if (kind == -1)
result = gfc_constant_result (e->ts.type, kind, &e->where);
- rtrunc = gfc_copy_expr (e);
+ mpfr_round (result->value.real, e->value.real);
- cmp = mpfr_cmp_ui (e->value.real, 0);
+ return range_check (result, "ANINT");
+}
- gfc_set_model_kind (kind);
- mpfr_init (half);
- mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
- if (cmp > 0)
+gfc_expr *
+gfc_simplify_and (gfc_expr * x, gfc_expr * y)
+{
+ gfc_expr *result;
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
{
- mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (result->value.real, rtrunc->value.real);
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_and (result->value.integer, x->value.integer, y->value.integer);
}
- else if (cmp < 0)
+ else /* BT_LOGICAL */
{
- mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (result->value.real, rtrunc->value.real);
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = x->value.logical && y->value.logical;
}
- else
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
- gfc_free_expr (rtrunc);
- mpfr_clear (half);
-
- return range_check (result, "ANINT");
+ return range_check (result, "AND");
}
gfc_expr *
gfc_simplify_dnint (gfc_expr * e)
{
- gfc_expr *rtrunc, *result;
- int cmp;
- mpfr_t half;
+ gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- result =
- gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
-
- rtrunc = gfc_copy_expr (e);
+ result = gfc_constant_result (BT_REAL, gfc_default_double_kind, &e->where);
- cmp = mpfr_cmp_ui (e->value.real, 0);
-
- gfc_set_model_kind (gfc_default_double_kind);
- mpfr_init (half);
- mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
-
- if (cmp > 0)
- {
- mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (result->value.real, rtrunc->value.real);
- }
- else if (cmp < 0)
- {
- mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (result->value.real, rtrunc->value.real);
- }
- else
- mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
-
- gfc_free_expr (rtrunc);
- mpfr_clear (half);
+ mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
}
gfc_expr *
-gfc_simplify_atan (gfc_expr * x)
+gfc_simplify_asinh (gfc_expr * x)
{
gfc_expr *result;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ mpfr_asinh(result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ASINH");
+}
+
+
+gfc_expr *
+gfc_simplify_atan (gfc_expr * x)
+{
+ gfc_expr *result;
+
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
mpfr_atan(result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN");
+}
+
+
+gfc_expr *
+gfc_simplify_atanh (gfc_expr * x)
+{
+ gfc_expr *result;
+ if (x->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ if (mpfr_cmp_si (x->value.real, 1) >= 0 ||
+ mpfr_cmp_si (x->value.real, -1) <= 0)
+ {
+ gfc_error ("Argument of ATANH at %L must be inside the range -1 to 1",
+ &x->where);
+ return &gfc_bad_expr;
+ }
+
+ result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+
+ mpfr_atanh(result->value.real, x->value.real, GFC_RND_MODE);
+
+ return range_check (result, "ATANH");
}
arctangent2 (y->value.real, x->value.real, result->value.real);
return range_check (result, "ATAN2");
-
}
gfc_expr *ceil, *result;
int kind;
- kind = get_kind (BT_REAL, k, "CEILING", gfc_default_real_kind);
+ kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (e, &c) != NULL || c < 0 || c > 255)
+ if (gfc_extract_int (e, &c) != NULL || c < 0 || c > UCHAR_MAX)
{
gfc_error ("Bad character in CHAR function at %L", &e->where);
return &gfc_bad_expr;
gfc_expr *
+gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
+{
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT
+ || (y != NULL && y->expr_type != EXPR_CONSTANT))
+ return NULL;
+
+ if (x->ts.type == BT_INTEGER)
+ {
+ if (y->ts.type == BT_INTEGER)
+ kind = gfc_default_real_kind;
+ else
+ kind = y->ts.kind;
+ }
+ else
+ {
+ if (y->ts.type == BT_REAL)
+ kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
+ else
+ kind = x->ts.kind;
+ }
+
+ return simplify_cmplx ("COMPLEX", x, y, kind);
+}
+
+
+gfc_expr *
gfc_simplify_conjg (gfc_expr * e)
{
gfc_expr *result;
gfc_simplify_dim (gfc_expr * x, gfc_expr * y)
{
gfc_expr *result;
+ int kind;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ result = gfc_constant_result (x->ts.type, kind, &x->where);
switch (x->ts.type)
{
gfc_expr *
gfc_simplify_exponent (gfc_expr * x)
{
- mpfr_t i2, absv, ln2, lnx, zero;
+ int i;
+ mpfr_t tmp;
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
&x->where);
gfc_set_model (x->value.real);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
mpz_set_ui (result->value.integer, 0);
- mpfr_clear (zero);
return result;
}
- mpfr_init (i2);
- mpfr_init (absv);
- mpfr_init (ln2);
- mpfr_init (lnx);
+ mpfr_init (tmp);
- mpfr_set_ui (i2, 2, GFC_RND_MODE);
+ mpfr_abs (tmp, x->value.real, GFC_RND_MODE);
+ mpfr_log2 (tmp, tmp, GFC_RND_MODE);
- mpfr_log (ln2, i2, GFC_RND_MODE);
- mpfr_abs (absv, x->value.real, GFC_RND_MODE);
- mpfr_log (lnx, absv, GFC_RND_MODE);
+ gfc_mpfr_to_mpz (result->value.integer, tmp);
- mpfr_div (lnx, lnx, ln2, GFC_RND_MODE);
- mpfr_trunc (lnx, lnx);
- mpfr_add_ui (lnx, lnx, 1, GFC_RND_MODE);
+ /* The model number for tiny(x) is b**(emin - 1) where b is the base and emin
+ is the smallest exponent value. So, we need to add 1 if x is tiny(x). */
+ i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
+ if (mpfr_cmp (x->value.real, gfc_real_kinds[i].tiny) == 0)
+ mpz_add_ui (result->value.integer,result->value.integer, 1);
- gfc_mpfr_to_mpz (result->value.integer, lnx);
-
- mpfr_clear (i2);
- mpfr_clear (ln2);
- mpfr_clear (lnx);
- mpfr_clear (absv);
- mpfr_clear (zero);
+ mpfr_clear (tmp);
return range_check (result, "EXPONENT");
}
mpfr_t floor;
int kind;
- kind = get_kind (BT_REAL, k, "FLOOR", gfc_default_real_kind);
+ kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
if (kind == -1)
gfc_internal_error ("gfc_simplify_floor(): Bad kind");
gfc_simplify_fraction (gfc_expr * x)
{
gfc_expr *result;
- mpfr_t i2, absv, ln2, lnx, pow2, zero;
- unsigned long exp2;
+ mpfr_t absv, exp, pow2;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
- mpfr_set (result->value.real, zero, GFC_RND_MODE);
- mpfr_clear (zero);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- mpfr_init (i2);
+ mpfr_init (exp);
mpfr_init (absv);
- mpfr_init (ln2);
- mpfr_init (lnx);
mpfr_init (pow2);
- mpfr_set_ui (i2, 2, GFC_RND_MODE);
-
- mpfr_log (ln2, i2, GFC_RND_MODE);
mpfr_abs (absv, x->value.real, GFC_RND_MODE);
- mpfr_log (lnx, absv, GFC_RND_MODE);
+ mpfr_log2 (exp, absv, GFC_RND_MODE);
- mpfr_div (lnx, lnx, ln2, GFC_RND_MODE);
- mpfr_trunc (lnx, lnx);
- mpfr_add_ui (lnx, lnx, 1, GFC_RND_MODE);
+ mpfr_trunc (exp, exp);
+ mpfr_add_ui (exp, exp, 1, GFC_RND_MODE);
- exp2 = (unsigned long) mpfr_get_d (lnx, GFC_RND_MODE);
- mpfr_pow_ui (pow2, i2, exp2, GFC_RND_MODE);
+ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
mpfr_div (result->value.real, absv, pow2, GFC_RND_MODE);
- mpfr_clear (i2);
- mpfr_clear (ln2);
+ mpfr_clear (exp);
mpfr_clear (absv);
- mpfr_clear (lnx);
mpfr_clear (pow2);
- mpfr_clear (zero);
return range_check (result, "FRACTION");
}
result = gfc_copy_expr (x);
mpz_setbit (result->value.integer, pos);
+
+ twos_complement (result->value.integer, gfc_integer_kinds[k].bit_size);
+
return range_check (result, "IBSET");
}
return &gfc_bad_expr;
}
- index = (int) e->value.character.string[0];
+ index = (unsigned char) e->value.character.string[0];
- if (index < CHAR_MIN || index > CHAR_MAX)
+ if (index < 0 || index > UCHAR_MAX)
{
gfc_error ("Argument of ICHAR at %L out of range of this processor",
&e->where);
gfc_expr *rpart, *rtrunc, *result;
int kind;
- kind = get_kind (BT_REAL, k, "INT", gfc_default_real_kind);
+ kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
if (kind == -1)
return &gfc_bad_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;
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)
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);
- return range_check (result, "ISHFT");
+ 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;
}
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++)
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);
}
{
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
{
{
if (bits[i] == 0)
mpz_clrbit (result->value.integer, i + delta);
- if (bits[i] == 1)
+ else
mpz_setbit (result->value.integer, i + delta);
}
{
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;
}
static gfc_expr *
-gfc_simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
+simplify_bound (gfc_expr * array, gfc_expr * dim, int upper)
{
gfc_ref *ref;
gfc_array_spec *as;
- int i;
+ gfc_expr *e;
+ int d;
if (array->expr_type != EXPR_VARIABLE)
- return NULL;
+ return NULL;
if (dim == NULL)
+ /* TODO: Simplify constant multi-dimensional bounds. */
return NULL;
if (dim->expr_type != EXPR_CONSTANT)
/* Follow any component references. */
as = array->symtree->n.sym->as;
- ref = array->ref;
- while (ref->next != NULL)
+ for (ref = array->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ /* We're done because 'as' has already been set in the
+ previous iteration. */
+ goto done;
+
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ return NULL;
+ }
+
+ gcc_unreachable ();
+
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+ }
+ }
+
+ gcc_unreachable ();
+
+ done:
+ if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+ return NULL;
+
+ d = mpz_get_si (dim->value.integer);
+
+ if (d < 1 || d > as->rank
+ || (d == as->rank && as->type == AS_ASSUMED_SIZE && upper))
{
- if (ref->type == REF_COMPONENT)
- as = ref->u.c.sym->as;
- ref = ref->next;
+ gfc_error ("DIM argument at %L is out of bounds", &dim->where);
+ return &gfc_bad_expr;
}
- if (ref->type != REF_ARRAY || ref->u.ar.type != AR_FULL)
+ e = upper ? as->upper[d-1] : as->lower[d-1];
+
+ if (e->expr_type != EXPR_CONSTANT)
return NULL;
-
- i = mpz_get_si (dim->value.integer);
- if (upper)
- return gfc_copy_expr (as->upper[i-1]);
- else
- return gfc_copy_expr (as->lower[i-1]);
+
+ return gfc_copy_expr (e);
}
gfc_expr *
gfc_simplify_lbound (gfc_expr * array, gfc_expr * dim)
{
- return gfc_simplify_bound (array, dim, 0);
+ return simplify_bound (array, dim, 0);
}
gfc_simplify_log (gfc_expr * x)
{
gfc_expr *result;
- mpfr_t xr, xi, zero;
+ mpfr_t xr, xi;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
switch (x->ts.type)
{
case BT_REAL:
- if (mpfr_cmp (x->value.real, zero) <= 0)
+ if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error
("Argument of LOG at %L cannot be less than or equal to zero",
&x->where);
gfc_free_expr (result);
- mpfr_clear (zero);
return &gfc_bad_expr;
}
mpfr_log(result->value.real, x->value.real, GFC_RND_MODE);
- mpfr_clear (zero);
break;
case BT_COMPLEX:
- if ((mpfr_cmp (x->value.complex.r, zero) == 0)
- && (mpfr_cmp (x->value.complex.i, zero) == 0))
+ if ((mpfr_sgn (x->value.complex.r) == 0)
+ && (mpfr_sgn (x->value.complex.i) == 0))
{
gfc_error ("Complex argument of LOG at %L cannot be zero",
&x->where);
gfc_free_expr (result);
- mpfr_clear (zero);
return &gfc_bad_expr;
}
mpfr_clear (xr);
mpfr_clear (xi);
- mpfr_clear (zero);
break;
gfc_simplify_log10 (gfc_expr * x)
{
gfc_expr *result;
- mpfr_t zero;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) <= 0)
+ if (mpfr_sgn (x->value.real) <= 0)
{
gfc_error
("Argument of LOG10 at %L cannot be less than or equal to zero",
&x->where);
- mpfr_clear (zero);
return &gfc_bad_expr;
}
result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
- mpfr_clear (zero);
return range_check (result, "LOG10");
}
gfc_expr *
gfc_simplify_min (gfc_expr * e)
{
-
return simplify_min_max (e, -1);
}
gfc_expr *
gfc_simplify_max (gfc_expr * e)
{
-
return simplify_min_max (e, 1);
}
{
gfc_expr *result;
mpfr_t quot, iquot, term;
+ int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+ result = gfc_constant_result (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
return &gfc_bad_expr;
}
- gfc_set_model_kind (a->ts.kind);
+ gfc_set_model_kind (kind);
mpfr_init (quot);
mpfr_init (iquot);
mpfr_init (term);
{
gfc_expr *result;
mpfr_t quot, iquot, term;
+ int kind;
if (a->expr_type != EXPR_CONSTANT || p->expr_type != EXPR_CONSTANT)
return NULL;
- result = gfc_constant_result (a->ts.type, a->ts.kind, &a->where);
+ kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
+ result = gfc_constant_result (a->ts.type, kind, &a->where);
switch (a->ts.type)
{
return &gfc_bad_expr;
}
- gfc_set_model_kind (a->ts.kind);
+ gfc_set_model_kind (kind);
mpfr_init (quot);
mpfr_init (iquot);
mpfr_init (term);
mpfr_div (quot, a->value.real, p->value.real, GFC_RND_MODE);
mpfr_floor (iquot, quot);
mpfr_mul (term, iquot, p->value.real, GFC_RND_MODE);
+ mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
mpfr_clear (quot);
mpfr_clear (iquot);
mpfr_clear (term);
-
- mpfr_sub (result->value.real, a->value.real, term, GFC_RND_MODE);
break;
default:
gfc_simplify_nearest (gfc_expr * x, gfc_expr * s)
{
gfc_expr *result;
- float rval;
- double val, eps;
- int p, i, k, match_float;
+ mpfr_t tmp;
+ int direction, sgn;
- /* FIXME: This implementation is dopey and probably not quite right,
- but it's a start. */
-
- if (x->expr_type != EXPR_CONSTANT)
+ if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
-
- result = gfc_constant_result (x->ts.type, x->ts.kind, &x->where);
+ gfc_set_model_kind (x->ts.kind);
+ result = gfc_copy_expr (x);
- val = mpfr_get_d (x->value.real, GFC_RND_MODE);
- p = gfc_real_kinds[k].digits;
+ direction = mpfr_sgn (s->value.real);
- eps = 1.;
- for (i = 1; i < p; ++i)
+ if (direction == 0)
{
- eps = eps / 2.;
+ gfc_error ("Second argument of NEAREST at %L may not be zero",
+ &s->where);
+ gfc_free (result);
+ return &gfc_bad_expr;
}
- /* TODO we should make sure that 'float' matches kind 4 */
- match_float = gfc_real_kinds[k].kind == 4;
- if (mpfr_cmp_ui (s->value.real, 0) > 0)
+ /* TODO: Use mpfr_nextabove and mpfr_nextbelow once we move to a
+ newer version of mpfr. */
+
+ sgn = mpfr_sgn (x->value.real);
+
+ if (sgn == 0)
{
- if (match_float)
- {
- rval = (float) val;
- rval = rval + eps;
- mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
- }
+ int k = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
+
+ if (direction > 0)
+ mpfr_add (result->value.real,
+ x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
else
- {
- val = val + eps;
- mpfr_set_d (result->value.real, val, GFC_RND_MODE);
- }
+ mpfr_sub (result->value.real,
+ x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
}
- else if (mpfr_cmp_ui (s->value.real, 0) < 0)
+ else
{
- if (match_float)
+ if (sgn < 0)
{
- rval = (float) val;
- rval = rval - eps;
- mpfr_set_d (result->value.real, rval, GFC_RND_MODE);
+ direction = -direction;
+ mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
}
+
+ if (direction > 0)
+ mpfr_add_one_ulp (result->value.real, GFC_RND_MODE);
else
{
- val = val - eps;
- mpfr_set_d (result->value.real, val, GFC_RND_MODE);
+ /* In this case the exponent can shrink, which makes us skip
+ over one number because we subtract one ulp with the
+ larger exponent. Thus we need to compensate for this. */
+ mpfr_init_set (tmp, result->value.real, GFC_RND_MODE);
+
+ mpfr_sub_one_ulp (result->value.real, GFC_RND_MODE);
+ mpfr_add_one_ulp (result->value.real, GFC_RND_MODE);
+
+ /* If we're back to where we started, the spacing is one
+ ulp, and we get the correct result by subtracting. */
+ if (mpfr_cmp (tmp, result->value.real) == 0)
+ mpfr_sub_one_ulp (result->value.real, GFC_RND_MODE);
+
+ mpfr_clear (tmp);
}
- }
- else
- {
- gfc_error ("Invalid second argument of NEAREST at %L", &s->where);
- gfc_free (result);
- return &gfc_bad_expr;
+
+ if (sgn < 0)
+ mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
}
return range_check (result, "NEAREST");
-
}
static gfc_expr *
simplify_nint (const char *name, gfc_expr * e, gfc_expr * k)
{
- gfc_expr *rtrunc, *itrunc, *result;
- int kind, cmp;
- mpfr_t half;
+ gfc_expr *itrunc, *result;
+ int kind;
kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
if (kind == -1)
result = gfc_constant_result (BT_INTEGER, kind, &e->where);
- rtrunc = gfc_copy_expr (e);
itrunc = gfc_copy_expr (e);
- cmp = mpfr_cmp_ui (e->value.real, 0);
-
- gfc_set_model (e->value.real);
- mpfr_init (half);
- mpfr_set_str (half, "0.5", 10, GFC_RND_MODE);
-
- if (cmp > 0)
- {
- mpfr_add (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (itrunc->value.real, rtrunc->value.real);
- }
- else if (cmp < 0)
- {
- mpfr_sub (rtrunc->value.real, e->value.real, half, GFC_RND_MODE);
- mpfr_trunc (itrunc->value.real, rtrunc->value.real);
- }
- else
- mpfr_set_ui (itrunc->value.real, 0, GFC_RND_MODE);
+ mpfr_round(itrunc->value.real, e->value.real);
gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real);
gfc_free_expr (itrunc);
- gfc_free_expr (rtrunc);
- mpfr_clear (half);
return range_check (result, name);
}
gfc_expr *
gfc_simplify_nint (gfc_expr * e, gfc_expr * k)
{
-
return simplify_nint ("NINT", e, k);
}
gfc_expr *
gfc_simplify_idnint (gfc_expr * e)
{
-
return simplify_nint ("IDNINT", e, NULL);
}
mpz_and (result->value.integer, result->value.integer,
gfc_integer_kinds[i].max_int);
+ twos_complement (result->value.integer, gfc_integer_kinds[i].bit_size);
+
return range_check (result, "NOT");
}
gfc_expr *
+gfc_simplify_or (gfc_expr * x, gfc_expr * y)
+{
+ gfc_expr *result;
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
+ {
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_ior (result->value.integer, x->value.integer, y->value.integer);
+ }
+ else /* BT_LOGICAL */
+ {
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = x->value.logical || y->value.logical;
+ }
+
+ return range_check (result, "OR");
+}
+
+
+gfc_expr *
gfc_simplify_precision (gfc_expr * e)
{
gfc_expr *result;
return range_check (result, "REAL");
}
+
+gfc_expr *
+gfc_simplify_realpart (gfc_expr * e)
+{
+ gfc_expr *result;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_constant_result (BT_REAL, e->ts.kind, &e->where);
+ mpfr_set (result->value.real, e->value.complex.r, GFC_RND_MODE);
+
+ return range_check (result, "REALPART");
+}
+
gfc_expr *
gfc_simplify_repeat (gfc_expr * e, gfc_expr * n)
{
e->shape = gfc_get_shape (rank);
for (i = 0; i < rank; i++)
- mpz_init_set_ui (e->shape[i], shape[order[i]]);
+ mpz_init_set_ui (e->shape[i], shape[i]);
- e->ts = head->expr->ts;
+ e->ts = source->ts;
e->rank = rank;
return e;
gfc_simplify_rrspacing (gfc_expr * x)
{
gfc_expr *result;
- mpfr_t i2, absv, ln2, lnx, frac, pow2, zero;
- unsigned long exp2;
+ mpfr_t absv, log2, exp, frac, pow2;
int i, p;
if (x->expr_type != EXPR_CONSTANT)
p = gfc_real_kinds[i].digits;
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
mpfr_ui_div (result->value.real, 1, gfc_real_kinds[i].tiny, GFC_RND_MODE);
- mpfr_clear (zero);
return result;
}
- mpfr_init (i2);
- mpfr_init (ln2);
+ mpfr_init (log2);
mpfr_init (absv);
- mpfr_init (lnx);
mpfr_init (frac);
mpfr_init (pow2);
- mpfr_set_ui (i2, 2, GFC_RND_MODE);
-
- mpfr_log (ln2, i2, GFC_RND_MODE);
mpfr_abs (absv, x->value.real, GFC_RND_MODE);
- mpfr_log (lnx, absv, GFC_RND_MODE);
+ mpfr_log2 (log2, absv, GFC_RND_MODE);
- mpfr_div (lnx, lnx, ln2, GFC_RND_MODE);
- mpfr_trunc (lnx, lnx);
- mpfr_add_ui (lnx, lnx, 1, GFC_RND_MODE);
+ mpfr_trunc (log2, log2);
+ mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
- exp2 = (unsigned long) mpfr_get_d (lnx, GFC_RND_MODE);
- mpfr_pow_ui (pow2, i2, exp2, GFC_RND_MODE);
+ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
mpfr_div (frac, absv, pow2, GFC_RND_MODE);
- exp2 = (unsigned long) p;
- mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
+ mpfr_mul_2exp (result->value.real, frac, (unsigned long)p, GFC_RND_MODE);
- mpfr_clear (i2);
- mpfr_clear (ln2);
+ mpfr_clear (log2);
mpfr_clear (absv);
- mpfr_clear (lnx);
mpfr_clear (frac);
mpfr_clear (pow2);
- mpfr_clear (zero);
return range_check (result, "RRSPACING");
}
gfc_simplify_set_exponent (gfc_expr * x, gfc_expr * i)
{
gfc_expr *result;
- mpfr_t i2, ln2, absv, lnx, pow2, frac, zero;
+ mpfr_t exp, absv, log2, pow2, frac;
unsigned long exp2;
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
- mpfr_set (result->value.real, zero, GFC_RND_MODE);
- mpfr_clear (zero);
+ mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
return result;
}
- mpfr_init (i2);
- mpfr_init (ln2);
mpfr_init (absv);
- mpfr_init (lnx);
+ mpfr_init (log2);
+ mpfr_init (exp);
mpfr_init (pow2);
mpfr_init (frac);
- mpfr_set_ui (i2, 2, GFC_RND_MODE);
- mpfr_log (ln2, i2, GFC_RND_MODE);
-
mpfr_abs (absv, x->value.real, GFC_RND_MODE);
- mpfr_log (lnx, absv, GFC_RND_MODE);
+ mpfr_log2 (log2, absv, GFC_RND_MODE);
- mpfr_div (lnx, lnx, ln2, GFC_RND_MODE);
- mpfr_trunc (lnx, lnx);
- mpfr_add_ui (lnx, lnx, 1, GFC_RND_MODE);
+ mpfr_trunc (log2, log2);
+ mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
/* Old exponent value, and fraction. */
- exp2 = (unsigned long) mpfr_get_d (lnx, GFC_RND_MODE);
- mpfr_pow_ui (pow2, i2, exp2, GFC_RND_MODE);
+ mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
mpfr_div (frac, absv, pow2, GFC_RND_MODE);
exp2 = (unsigned long) mpz_get_d (i->value.integer);
mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
- mpfr_clear (i2);
- mpfr_clear (ln2);
mpfr_clear (absv);
- mpfr_clear (lnx);
+ mpfr_clear (log2);
mpfr_clear (pow2);
mpfr_clear (frac);
- mpfr_clear (zero);
return range_check (result, "SET_EXPONENT");
}
gfc_simplify_spacing (gfc_expr * x)
{
gfc_expr *result;
- mpfr_t i1, i2, ln2, absv, lnx, zero;
+ mpfr_t absv, log2;
long diff;
- unsigned long exp2;
int i, p;
if (x->expr_type != EXPR_CONSTANT)
result = gfc_constant_result (BT_REAL, x->ts.kind, &x->where);
gfc_set_model_kind (x->ts.kind);
- mpfr_init (zero);
- mpfr_set_ui (zero, 0, GFC_RND_MODE);
- if (mpfr_cmp (x->value.real, zero) == 0)
+ if (mpfr_sgn (x->value.real) == 0)
{
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
- mpfr_clear (zero);
return result;
}
- mpfr_init (i1);
- mpfr_init (i2);
- mpfr_init (ln2);
+ mpfr_init (log2);
mpfr_init (absv);
- mpfr_init (lnx);
-
- mpfr_set_ui (i1, 1, GFC_RND_MODE);
- mpfr_set_ui (i2, 2, GFC_RND_MODE);
- mpfr_log (ln2, i2, GFC_RND_MODE);
mpfr_abs (absv, x->value.real, GFC_RND_MODE);
- mpfr_log (lnx, absv, GFC_RND_MODE);
+ mpfr_log2 (log2, absv, GFC_RND_MODE);
+ mpfr_trunc (log2, log2);
- mpfr_div (lnx, lnx, ln2, GFC_RND_MODE);
- mpfr_trunc (lnx, lnx);
- mpfr_add_ui (lnx, lnx, 1, GFC_RND_MODE);
+ mpfr_add_ui (log2, log2, 1, GFC_RND_MODE);
- diff = (long) mpfr_get_d (lnx, GFC_RND_MODE) - (long) p;
- if (diff >= 0)
- {
- exp2 = (unsigned) diff;
- mpfr_mul_2exp (result->value.real, i1, exp2, GFC_RND_MODE);
- }
- else
- {
- diff = -diff;
- exp2 = (unsigned) diff;
- mpfr_div_2exp (result->value.real, i1, exp2, GFC_RND_MODE);
- }
+ /* FIXME: We should be using mpfr_get_si here, but this function is
+ not available with the version of mpfr distributed with gmp (as of
+ 2004-09-17). Replace once mpfr has been imported into the gcc cvs
+ tree. */
+ diff = (long)mpfr_get_d (log2, GFC_RND_MODE) - (long)p;
+ mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
+ mpfr_mul_2si (result->value.real, result->value.real, diff, GFC_RND_MODE);
- mpfr_clear (i1);
- mpfr_clear (i2);
- mpfr_clear (ln2);
+ mpfr_clear (log2);
mpfr_clear (absv);
- mpfr_clear (lnx);
- mpfr_clear (zero);
if (mpfr_cmp (result->value.real, gfc_real_kinds[i].tiny) < 0)
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
gfc_expr *
gfc_simplify_ubound (gfc_expr * array, gfc_expr * dim)
{
- return gfc_simplify_bound (array, dim, 1);
+ return simplify_bound (array, dim, 1);
}
return result;
}
+
+gfc_expr *
+gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
+{
+ gfc_expr *result;
+ int kind;
+
+ if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
+ if (x->ts.type == BT_INTEGER)
+ {
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_xor (result->value.integer, x->value.integer, y->value.integer);
+ }
+ else /* BT_LOGICAL */
+ {
+ result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
+ result->value.logical = (x->value.logical && ! y->value.logical)
+ || (! x->value.logical && y->value.logical);
+ }
+
+ return range_check (result, "XOR");
+}
+
+
+
/****************** Constant simplification *****************/
/* Master function to convert one constant to another. While this is
case BT_COMPLEX:
f = gfc_int2complex;
break;
+ case BT_LOGICAL:
+ f = gfc_int2log;
+ break;
default:
goto oops;
}
break;
case BT_LOGICAL:
- if (type != BT_LOGICAL)
- goto oops;
- f = gfc_log2log;
+ switch (type)
+ {
+ case BT_INTEGER:
+ f = gfc_log2int;
+ break;
+ case BT_LOGICAL:
+ f = gfc_log2log;
+ break;
+ default:
+ goto oops;
+ }
+ break;
+
+ case BT_HOLLERITH:
+ switch (type)
+ {
+ case BT_INTEGER:
+ f = gfc_hollerith2int;
+ break;
+
+ case BT_REAL:
+ f = gfc_hollerith2real;
+ break;
+
+ case BT_COMPLEX:
+ f = gfc_hollerith2complex;
+ break;
+
+ case BT_CHARACTER:
+ f = gfc_hollerith2character;
+ break;
+
+ case BT_LOGICAL:
+ f = gfc_hollerith2logical;
+ break;
+
+ default:
+ goto oops;
+ }
break;
default:
OSDN Git Service
