/* Simplify intrinsic functions at compile-time.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 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"
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_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)
+ {
+ result = gfc_constant_result (BT_INTEGER, kind, &x->where);
+ mpz_and (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, "AND");
+}
+
+
+gfc_expr *
gfc_simplify_dnint (gfc_expr * e)
{
gfc_expr *result;
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");
-
}
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)
{
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 *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:
if (direction > 0)
mpfr_add (result->value.real,
- x->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
+ x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
else
mpfr_sub (result->value.real,
- x->value.real, gfc_real_kinds[k].tiny, GFC_RND_MODE);
-
-#if 0
- /* FIXME: This gives an arithmetic error because we compare
- against tiny when range-checking. Also, it doesn't give the
- right value. */
- /* TINY is the smallest model number, we want the smallest
- machine representable number. Therefore we have to shift the
- value to the right by the number of digits - 1. */
- mpfr_div_2ui (result->value.real, result->value.real,
- gfc_real_kinds[k].precision - 1, GFC_RND_MODE);
-#endif
+ x->value.real, gfc_real_kinds[k].subnormal, GFC_RND_MODE);
}
else
{
else
{
/* In this case the exponent can shrink, which makes us skip
- over one number because we substract one ulp with the
+ 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);
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)
{
for (i = 0; i < rank; i++)
mpz_init_set_ui (e->shape[i], shape[i]);
- e->ts = head->expr->ts;
+ e->ts = source->ts;
e->rank = rank;
return e;
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
