blob: d675f2c3aeff4ad1128ef32c215055effff12cdd [file] [log] [blame]
/* Simplify intrinsic functions at compile-time.
Copyright (C) 2000-2021 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
for more details.
You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h" /* For BITS_PER_UNIT. */
#include "gfortran.h"
#include "arith.h"
#include "intrinsic.h"
#include "match.h"
#include "target-memory.h"
#include "constructor.h"
#include "version.h" /* For version_string. */
/* Prototypes. */
static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false);
gfc_expr gfc_bad_expr;
static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);
/* Note that 'simplification' is not just transforming expressions.
For functions that are not simplified at compile time, range
checking is done if possible.
The return convention is that each simplification function returns:
A new expression node corresponding to the simplified arguments.
The original arguments are destroyed by the caller, and must not
be a part of the new expression.
NULL pointer indicating that no simplification was possible and
the original expression should remain intact.
An expression pointer to gfc_bad_expr (a static placeholder)
indicating that some error has prevented simplification. The
error is generated within the function and should be propagated
upwards
By the time a simplification function gets control, it has been
decided that the function call is really supposed to be the
intrinsic. No type checking is strictly necessary, since only
valid types will be passed on. On the other hand, a simplification
subroutine may have to look at the type of an argument as part of
its processing.
Array arguments are only passed to these subroutines that implement
the simplification of transformational intrinsics.
The functions in this file don't have much comment with them, but
everything is reasonably straight-forward. The Standard, chapter 13
is the best comment you'll find for this file anyway. */
/* Range checks an expression node. If all goes well, returns the
node, otherwise returns &gfc_bad_expr and frees the node. */
static gfc_expr *
range_check (gfc_expr *result, const char *name)
{
if (result == NULL)
return &gfc_bad_expr;
if (result->expr_type != EXPR_CONSTANT)
return result;
switch (gfc_range_check (result))
{
case ARITH_OK:
return result;
case ARITH_OVERFLOW:
gfc_error ("Result of %s overflows its kind at %L", name,
&result->where);
break;
case ARITH_UNDERFLOW:
gfc_error ("Result of %s underflows its kind at %L", name,
&result->where);
break;
case ARITH_NAN:
gfc_error ("Result of %s is NaN at %L", name, &result->where);
break;
default:
gfc_error ("Result of %s gives range error for its kind at %L", name,
&result->where);
break;
}
gfc_free_expr (result);
return &gfc_bad_expr;
}
/* A helper function that gets an optional and possibly missing
kind parameter. Returns the kind, -1 if something went wrong. */
static int
get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
if (k == NULL)
return default_kind;
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("KIND parameter of %s at %L must be an initialization "
"expression", name, &k->where);
return -1;
}
if (gfc_extract_int (k, &kind)
|| gfc_validate_kind (type, kind, true) < 0)
{
gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
return -1;
}
return kind;
}
/* 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
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 if we
are doing range checking. */
if (flag_range_check != 0)
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 if we
are doing range checking. */
if (flag_range_check != 0)
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. */
void
gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
{
mpz_t mask;
/* Confirm that no bits above the unsigned range are set if we are
doing range checking. */
if (flag_range_check != 0)
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);
/* 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);
}
}
/* Test that the expression is a constant array, simplifying if
we are dealing with a parameter array. */
static bool
is_constant_array_expr (gfc_expr *e)
{
gfc_constructor *c;
bool array_OK = true;
mpz_t size;
if (e == NULL)
return true;
if (e->expr_type == EXPR_VARIABLE && e->rank > 0
&& e->symtree->n.sym->attr.flavor == FL_PARAMETER)
gfc_simplify_expr (e, 1);
if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
return false;
for (c = gfc_constructor_first (e->value.constructor);
c; c = gfc_constructor_next (c))
if (c->expr->expr_type != EXPR_CONSTANT
&& c->expr->expr_type != EXPR_STRUCTURE)
{
array_OK = false;
break;
}
/* Check and expand the constructor. */
if (!array_OK && gfc_init_expr_flag && e->rank == 1)
{
array_OK = gfc_reduce_init_expr (e);
/* gfc_reduce_init_expr resets the flag. */
gfc_init_expr_flag = true;
}
else
return array_OK;
/* Recheck to make sure that any EXPR_ARRAYs have gone. */
for (c = gfc_constructor_first (e->value.constructor);
c; c = gfc_constructor_next (c))
if (c->expr->expr_type != EXPR_CONSTANT
&& c->expr->expr_type != EXPR_STRUCTURE)
return false;
/* Make sure that the array has a valid shape. */
if (e->shape == NULL && e->rank == 1)
{
if (!gfc_array_size(e, &size))
return false;
e->shape = gfc_get_shape (1);
mpz_init_set (e->shape[0], size);
mpz_clear (size);
}
return array_OK;
}
/* Test for a size zero array. */
bool
gfc_is_size_zero_array (gfc_expr *array)
{
if (array->rank == 0)
return false;
if (array->expr_type == EXPR_VARIABLE && array->rank > 0
&& array->symtree->n.sym->attr.flavor == FL_PARAMETER
&& array->shape != NULL)
{
for (int i = 0; i < array->rank; i++)
if (mpz_cmp_si (array->shape[i], 0) <= 0)
return true;
return false;
}
if (array->expr_type == EXPR_ARRAY)
return array->value.constructor == NULL;
return false;
}
/* Initialize a transformational result expression with a given value. */
static void
init_result_expr (gfc_expr *e, int init, gfc_expr *array)
{
if (e && e->expr_type == EXPR_ARRAY)
{
gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
while (ctor)
{
init_result_expr (ctor->expr, init, array);
ctor = gfc_constructor_next (ctor);
}
}
else if (e && e->expr_type == EXPR_CONSTANT)
{
int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
HOST_WIDE_INT length;
gfc_char_t *string;
switch (e->ts.type)
{
case BT_LOGICAL:
e->value.logical = (init ? 1 : 0);
break;
case BT_INTEGER:
if (init == INT_MIN)
mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
else if (init == INT_MAX)
mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
else
mpz_set_si (e->value.integer, init);
break;
case BT_REAL:
if (init == INT_MIN)
{
mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
}
else if (init == INT_MAX)
mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
else
mpfr_set_si (e->value.real, init, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
break;
case BT_CHARACTER:
if (init == INT_MIN)
{
gfc_expr *len = gfc_simplify_len (array, NULL);
gfc_extract_hwi (len, &length);
string = gfc_get_wide_string (length + 1);
gfc_wide_memset (string, 0, length);
}
else if (init == INT_MAX)
{
gfc_expr *len = gfc_simplify_len (array, NULL);
gfc_extract_hwi (len, &length);
string = gfc_get_wide_string (length + 1);
gfc_wide_memset (string, 255, length);
}
else
{
length = 0;
string = gfc_get_wide_string (1);
}
string[length] = '\0';
e->value.character.length = length;
e->value.character.string = string;
break;
default:
gcc_unreachable();
}
}
else
gcc_unreachable();
}
/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
if conj_a is true, the matrix_a is complex conjugated. */
static gfc_expr *
compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
gfc_expr *matrix_b, int stride_b, int offset_b,
bool conj_a)
{
gfc_expr *result, *a, *b, *c;
/* Set result to an INTEGER(1) 0 for numeric types and .false. for
LOGICAL. Mixed-mode math in the loop will promote result to the
correct type and kind. */
if (matrix_a->ts.type == BT_LOGICAL)
result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
else
result = gfc_get_int_expr (1, NULL, 0);
result->where = matrix_a->where;
a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
while (a && b)
{
/* Copying of expressions is required as operands are free'd
by the gfc_arith routines. */
switch (result->ts.type)
{
case BT_LOGICAL:
result = gfc_or (result,
gfc_and (gfc_copy_expr (a),
gfc_copy_expr (b)));
break;
case BT_INTEGER:
case BT_REAL:
case BT_COMPLEX:
if (conj_a && a->ts.type == BT_COMPLEX)
c = gfc_simplify_conjg (a);
else
c = gfc_copy_expr (a);
result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
break;
default:
gcc_unreachable();
}
offset_a += stride_a;
a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
offset_b += stride_b;
b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
}
return result;
}
/* Build a result expression for transformational intrinsics,
depending on DIM. */
static gfc_expr *
transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
int kind, locus* where)
{
gfc_expr *result;
int i, nelem;
if (!dim || array->rank == 1)
return gfc_get_constant_expr (type, kind, where);
result = gfc_get_array_expr (type, kind, where);
result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
result->rank = array->rank - 1;
/* gfc_array_size() would count the number of elements in the constructor,
we have not built those yet. */
nelem = 1;
for (i = 0; i < result->rank; ++i)
nelem *= mpz_get_ui (result->shape[i]);
for (i = 0; i < nelem; ++i)
{
gfc_constructor_append_expr (&result->value.constructor,
gfc_get_constant_expr (type, kind, where),
NULL);
}
return result;
}
typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
/* Wrapper function, implements 'op1 += 1'. Only called if MASK
of COUNT intrinsic is .TRUE..
Interface and implementation mimics arith functions as
gfc_add, gfc_multiply, etc. */
static gfc_expr *
gfc_count (gfc_expr *op1, gfc_expr *op2)
{
gfc_expr *result;
gcc_assert (op1->ts.type == BT_INTEGER);
gcc_assert (op2->ts.type == BT_LOGICAL);
gcc_assert (op2->value.logical);
result = gfc_copy_expr (op1);
mpz_add_ui (result->value.integer, result->value.integer, 1);
gfc_free_expr (op1);
gfc_free_expr (op2);
return result;
}
/* Transforms an ARRAY with operation OP, according to MASK, to a
scalar RESULT. E.g. called if
REAL, PARAMETER :: array(n, m) = ...
REAL, PARAMETER :: s = SUM(array)
where OP == gfc_add(). */
static gfc_expr *
simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
transformational_op op)
{
gfc_expr *a, *m;
gfc_constructor *array_ctor, *mask_ctor;
/* Shortcut for constant .FALSE. MASK. */
if (mask
&& mask->expr_type == EXPR_CONSTANT
&& !mask->value.logical)
return result;
array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
mask_ctor = gfc_constructor_first (mask->value.constructor);
while (array_ctor)
{
a = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
/* A constant MASK equals .TRUE. here and can be ignored. */
if (mask_ctor)
{
m = mask_ctor->expr;
mask_ctor = gfc_constructor_next (mask_ctor);
if (!m->value.logical)
continue;
}
result = op (result, gfc_copy_expr (a));
if (!result)
return result;
}
return result;
}
/* Transforms an ARRAY with operation OP, according to MASK, to an
array RESULT. E.g. called if
REAL, PARAMETER :: array(n, m) = ...
REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
where OP == gfc_multiply().
The result might be post processed using post_op. */
static gfc_expr *
simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
gfc_expr *mask, transformational_op op,
transformational_op post_op)
{
mpz_t size;
int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
tmpstride[GFC_MAX_DIMENSIONS];
/* Shortcut for constant .FALSE. MASK. */
if (mask
&& mask->expr_type == EXPR_CONSTANT
&& !mask->value.logical)
return result;
/* Build an indexed table for array element expressions to minimize
linked-list traversal. Masked elements are set to NULL. */
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
mpz_clear (size);
arrayvec = XCNEWVEC (gfc_expr*, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
if (mask && mask->expr_type == EXPR_ARRAY)
mask_ctor = gfc_constructor_first (mask->value.constructor);
for (i = 0; i < arraysize; ++i)
{
arrayvec[i] = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
if (mask_ctor)
{
if (!mask_ctor->expr->value.logical)
arrayvec[i] = NULL;
mask_ctor = gfc_constructor_next (mask_ctor);
}
}
/* Same for the result expression. */
gfc_array_size (result, &size);
resultsize = mpz_get_ui (size);
mpz_clear (size);
resultvec = XCNEWVEC (gfc_expr*, resultsize);
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
resultvec[i] = result_ctor->expr;
result_ctor = gfc_constructor_next (result_ctor);
}
gfc_extract_int (dim, &dim_index);
dim_index -= 1; /* zero-base index */
dim_extent = 0;
dim_stride = 0;
for (i = 0, n = 0; i < array->rank; ++i)
{
count[i] = 0;
tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
if (i == dim_index)
{
dim_extent = mpz_get_si (array->shape[i]);
dim_stride = tmpstride[i];
continue;
}
extent[n] = mpz_get_si (array->shape[i]);
sstride[n] = tmpstride[i];
dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
n += 1;
}
done = resultsize <= 0;
base = arrayvec;
dest = resultvec;
while (!done)
{
for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
if (*src)
*dest = op (*dest, gfc_copy_expr (*src));
if (post_op)
*dest = post_op (*dest, *dest);
count[0]++;
base += sstride[0];
dest += dstride[0];
n = 0;
while (!done && count[n] == extent[n])
{
count[n] = 0;
base -= sstride[n] * extent[n];
dest -= dstride[n] * extent[n];
n++;
if (n < result->rank)
{
/* If the nested loop is unrolled GFC_MAX_DIMENSIONS
times, we'd warn for the last iteration, because the
array index will have already been incremented to the
array sizes, and we can't tell that this must make
the test against result->rank false, because ranks
must not exceed GFC_MAX_DIMENSIONS. */
GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
count[n]++;
base += sstride[n];
dest += dstride[n];
GCC_DIAGNOSTIC_POP
}
else
done = true;
}
}
/* Place updated expression in result constructor. */
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor->expr = resultvec[i];
result_ctor = gfc_constructor_next (result_ctor);
}
free (arrayvec);
free (resultvec);
return result;
}
static gfc_expr *
simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
int init_val, transformational_op op)
{
gfc_expr *result;
bool size_zero;
size_zero = gfc_is_size_zero_array (array);
if (!(is_constant_array_expr (array) || size_zero)
|| !gfc_is_constant_expr (dim))
return NULL;
if (mask
&& !is_constant_array_expr (mask)
&& mask->expr_type != EXPR_CONSTANT)
return NULL;
result = transformational_result (array, dim, array->ts.type,
array->ts.kind, &array->where);
init_result_expr (result, init_val, array);
if (size_zero)
return result;
return !dim || array->rank == 1 ?
simplify_transformation_to_scalar (result, array, mask, op) :
simplify_transformation_to_array (result, array, dim, mask, op, NULL);
}
/********************** Simplification functions *****************************/
gfc_expr *
gfc_simplify_abs (gfc_expr *e)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
switch (e->ts.type)
{
case BT_INTEGER:
result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
mpz_abs (result->value.integer, e->value.integer);
return range_check (result, "IABS");
case BT_REAL:
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
return range_check (result, "ABS");
case BT_COMPLEX:
gfc_set_model_kind (e->ts.kind);
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
return range_check (result, "CABS");
default:
gfc_internal_error ("gfc_simplify_abs(): Bad type");
}
}
static gfc_expr *
simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
{
gfc_expr *result;
int kind;
bool too_large = false;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
if (kind == -1)
return &gfc_bad_expr;
if (mpz_cmp_si (e->value.integer, 0) < 0)
{
gfc_error ("Argument of %s function at %L is negative", name,
&e->where);
return &gfc_bad_expr;
}
if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
gfc_warning (OPT_Wsurprising,
"Argument of %s function at %L outside of range [0,127]",
name, &e->where);
if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
too_large = true;
else if (kind == 4)
{
mpz_t t;
mpz_init_set_ui (t, 2);
mpz_pow_ui (t, t, 32);
mpz_sub_ui (t, t, 1);
if (mpz_cmp (e->value.integer, t) > 0)
too_large = true;
mpz_clear (t);
}
if (too_large)
{
gfc_error ("Argument of %s function at %L is too large for the "
"collating sequence of kind %d", name, &e->where, kind);
return &gfc_bad_expr;
}
result = gfc_get_character_expr (kind, &e->where, NULL, 1);
result->value.character.string[0] = mpz_get_ui (e->value.integer);
return result;
}
/* We use the processor's collating sequence, because all
systems that gfortran currently works on are ASCII. */
gfc_expr *
gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
{
return simplify_achar_char (e, k, "ACHAR", true);
}
gfc_expr *
gfc_simplify_acos (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ACOS at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_acos(): Bad type");
}
return range_check (result, "ACOS");
}
gfc_expr *
gfc_simplify_acosh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
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_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
}
return range_check (result, "ACOSH");
}
gfc_expr *
gfc_simplify_adjustl (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
len = e->value.character.length;
for (count = 0, i = 0; i < len; ++i)
{
ch = e->value.character.string[i];
if (ch != ' ')
break;
++count;
}
result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < len - count; ++i)
result->value.character.string[i] = e->value.character.string[count + i];
return result;
}
gfc_expr *
gfc_simplify_adjustr (gfc_expr *e)
{
gfc_expr *result;
int count, i, len;
gfc_char_t ch;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
len = e->value.character.length;
for (count = 0, i = len - 1; i >= 0; --i)
{
ch = e->value.character.string[i];
if (ch != ' ')
break;
++count;
}
result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
for (i = 0; i < count; ++i)
result->value.character.string[i] = ' ';
for (i = count; i < len; ++i)
result->value.character.string[i] = e->value.character.string[i - count];
return result;
}
gfc_expr *
gfc_simplify_aimag (gfc_expr *e)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
return range_check (result, "AIMAG");
}
gfc_expr *
gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *rtrunc, *result;
int kind;
kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
if (kind == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, kind);
gfc_free_expr (rtrunc);
return range_check (result, "AINT");
}
gfc_expr *
gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
{
return simplify_transformation (mask, dim, NULL, true, gfc_and);
}
gfc_expr *
gfc_simplify_dint (gfc_expr *e)
{
gfc_expr *rtrunc, *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real);
result = gfc_real2real (rtrunc, gfc_default_double_kind);
gfc_free_expr (rtrunc);
return range_check (result, "DINT");
}
gfc_expr *
gfc_simplify_dreal (gfc_expr *e)
{
gfc_expr *result = NULL;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
return range_check (result, "DREAL");
}
gfc_expr *
gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
int kind;
kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
if (kind == -1)
return &gfc_bad_expr;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "ANINT");
}
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;
switch (x->ts.type)
{
case BT_INTEGER:
result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
mpz_and (result->value.integer, x->value.integer, y->value.integer);
return range_check (result, "AND");
case BT_LOGICAL:
return gfc_get_logical_expr (kind, &x->where,
x->value.logical && y->value.logical);
default:
gcc_unreachable ();
}
}
gfc_expr *
gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
{
return simplify_transformation (mask, dim, NULL, false, gfc_or);
}
gfc_expr *
gfc_simplify_dnint (gfc_expr *e)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
mpfr_round (result->value.real, e->value.real);
return range_check (result, "DNINT");
}
gfc_expr *
gfc_simplify_asin (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1) > 0
|| mpfr_cmp_si (x->value.real, -1) < 0)
{
gfc_error ("Argument of ASIN at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_asin(): Bad type");
}
return range_check (result, "ASIN");
}
/* Convert radians to degrees, i.e., x * 180 / pi. */
static void
rad2deg (mpfr_t x)
{
mpfr_t tmp;
mpfr_init (tmp);
mpfr_const_pi (tmp, GFC_RND_MODE);
mpfr_mul_ui (x, x, 180, GFC_RND_MODE);
mpfr_div (x, x, tmp, GFC_RND_MODE);
mpfr_clear (tmp);
}
/* Simplify ACOSD(X) where the returned value has units of degree. */
gfc_expr *
gfc_simplify_acosd (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 ACOSD at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
rad2deg (result->value.real);
return range_check (result, "ACOSD");
}
/* Simplify asind (x) where the returned value has units of degree. */
gfc_expr *
gfc_simplify_asind (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 ASIND at %L must be between -1 and 1",
&x->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
rad2deg (result->value.real);
return range_check (result, "ASIND");
}
/* Simplify atand (x) where the returned value has units of degree. */
gfc_expr *
gfc_simplify_atand (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
rad2deg (result->value.real);
return range_check (result, "ATAND");
}
gfc_expr *
gfc_simplify_asinh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
case BT_REAL:
mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
}
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_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
case BT_REAL:
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_atan(): Bad type");
}
return range_check (result, "ATAN");
}
gfc_expr *
gfc_simplify_atanh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
switch (x->ts.type)
{
case BT_REAL:
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_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
}
return range_check (result, "ATANH");
}
gfc_expr *
gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
gfc_error ("If first argument of ATAN2 at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ATAN2");
}
gfc_expr *
gfc_simplify_bessel_j0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J0");
}
gfc_expr *
gfc_simplify_bessel_j1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_J1");
}
gfc_expr *
gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
return NULL;
n = mpz_get_si (order->value.integer);
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_JN");
}
/* Simplify transformational form of JN and YN. */
static gfc_expr *
gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
bool jn)
{
gfc_expr *result;
gfc_expr *e;
long n1, n2;
int i;
mpfr_t x2rev, last1, last2;
if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
|| order2->expr_type != EXPR_CONSTANT)
return NULL;
n1 = mpz_get_si (order1->value.integer);
n2 = mpz_get_si (order2->value.integer);
result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
result->rank = 1;
result->shape = gfc_get_shape (1);
mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
if (n2 < n1)
return result;
/* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
YN(N, 0.0) = -Inf. */
if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
{
if (!jn && flag_range_check)
{
gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
gfc_free_expr (result);
return &gfc_bad_expr;
}
if (jn && n1 == 0)
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
gfc_constructor_append_expr (&result->value.constructor, e,
&x->where);
n1++;
}
for (i = n1; i <= n2; i++)
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
if (jn)
mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
else
mpfr_set_inf (e->value.real, -1);
gfc_constructor_append_expr (&result->value.constructor, e,
&x->where);
}
return result;
}
/* Use the faster but more verbose recurrence algorithm. Bessel functions
are stable for downward recursion and Neumann functions are stable
for upward recursion. It is
x2rev = 2.0/x,
J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1 */
gfc_set_model_kind (x->ts.kind);
/* Get first recursion anchor. */
mpfr_init (last1);
if (jn)
mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
else
mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (e->value.real, last1, GFC_RND_MODE);
if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
{
mpfr_clear (last1);
gfc_free_expr (e);
gfc_free_expr (result);
return &gfc_bad_expr;
}
gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
if (n1 == n2)
{
mpfr_clear (last1);
return result;
}
/* Get second recursion anchor. */
mpfr_init (last2);
if (jn)
mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
else
mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (e->value.real, last2, GFC_RND_MODE);
if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
{
mpfr_clear (last1);
mpfr_clear (last2);
gfc_free_expr (e);
gfc_free_expr (result);
return &gfc_bad_expr;
}
if (jn)
gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
else
gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
if (n1 + 1 == n2)
{
mpfr_clear (last1);
mpfr_clear (last2);
return result;
}
/* Start actual recursion. */
mpfr_init (x2rev);
mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
for (i = 2; i <= n2-n1; i++)
{
e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
/* Special case: For YN, if the previous N gave -INF, set
also N+1 to -INF. */
if (!jn && !flag_range_check && mpfr_inf_p (last2))
{
mpfr_set_inf (e->value.real, -1);
gfc_constructor_append_expr (&result->value.constructor, e,
&x->where);
continue;
}
mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
GFC_RND_MODE);
mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
{
/* Range_check frees "e" in that case. */
e = NULL;
goto error;
}
if (jn)
gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
-i-1);
else
gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
mpfr_set (last1, last2, GFC_RND_MODE);
mpfr_set (last2, e->value.real, GFC_RND_MODE);
}
mpfr_clear (last1);
mpfr_clear (last2);
mpfr_clear (x2rev);
return result;
error:
mpfr_clear (last1);
mpfr_clear (last2);
mpfr_clear (x2rev);
gfc_free_expr (e);
gfc_free_expr (result);
return &gfc_bad_expr;
}
gfc_expr *
gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
{
return gfc_simplify_bessel_n2 (order1, order2, x, true);
}
gfc_expr *
gfc_simplify_bessel_y0 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y0");
}
gfc_expr *
gfc_simplify_bessel_y1 (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_Y1");
}
gfc_expr *
gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
{
gfc_expr *result;
long n;
if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
return NULL;
n = mpz_get_si (order->value.integer);
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
return range_check (result, "BESSEL_YN");
}
gfc_expr *
gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
{
return gfc_simplify_bessel_n2 (order1, order2, x, false);
}
gfc_expr *
gfc_simplify_bit_size (gfc_expr *e)
{
int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
return gfc_get_int_expr (e->ts.kind, &e->where,
gfc_integer_kinds[i].bit_size);
}
gfc_expr *
gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
{
int b;
if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
return NULL;
if (gfc_extract_int (bit, &b) || b < 0)
return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
mpz_tstbit (e->value.integer, b));
}
static int
compare_bitwise (gfc_expr *i, gfc_expr *j)
{
mpz_t x, y;
int k, res;
gcc_assert (i->ts.type == BT_INTEGER);
gcc_assert (j->ts.type == BT_INTEGER);
mpz_init_set (x, i->value.integer);
k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
mpz_init_set (y, j->value.integer);
k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
res = mpz_cmp (x, y);
mpz_clear (x);
mpz_clear (y);
return res;
}
gfc_expr *
gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) >= 0);
}
gfc_expr *
gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) > 0);
}
gfc_expr *
gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) <= 0);
}
gfc_expr *
gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
return NULL;
return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
compare_bitwise (i, j) < 0);
}
gfc_expr *
gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
{
gfc_expr *ceil, *result;
int 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;
ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real);
result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
gfc_free_expr (ceil);
return range_check (result, "CEILING");
}
gfc_expr *
gfc_simplify_char (gfc_expr *e, gfc_expr *k)
{
return simplify_achar_char (e, k, "CHAR", false);
}
/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX. */
static gfc_expr *
simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
return NULL;
result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
switch (x->ts.type)
{
case BT_INTEGER:
mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
break;
case BT_REAL:
mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
}
if (!y)
return range_check (result, name);
switch (y->ts.type)
{
case BT_INTEGER:
mpfr_set_z (mpc_imagref (result->value.complex),
y->value.integer, GFC_RND_MODE);
break;
case BT_REAL:
mpfr_set (mpc_imagref (result->value.complex),
y->value.real, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
}
return range_check (result, name);
}
gfc_expr *
gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
{
int kind;
kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
if (kind == -1)
return &gfc_bad_expr;
return simplify_cmplx ("CMPLX", x, y, kind);
}
gfc_expr *
gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
{
int kind;
if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
kind = gfc_default_complex_kind;
else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
kind = x->ts.kind;
else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
kind = y->ts.kind;
else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
else
gcc_unreachable ();
return simplify_cmplx ("COMPLEX", x, y, kind);
}
gfc_expr *
gfc_simplify_conjg (gfc_expr *e)
{
gfc_expr *result;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_copy_expr (e);
mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
return range_check (result, "CONJG");
}
/* Simplify atan2d (x) where the unit is degree. */
gfc_expr *
gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
{
gfc_error ("If first argument of ATAN2D at %L is zero, then the "
"second argument must not be zero", &y->where);
return &gfc_bad_expr;
}
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
rad2deg (result->value.real);
return range_check (result, "ATAN2D");
}
gfc_expr *
gfc_simplify_cos (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
case BT_REAL:
mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
}
return range_check (result, "COS");
}
static void
deg2rad (mpfr_t x)
{
mpfr_t d2r;
mpfr_init (d2r);
mpfr_const_pi (d2r, GFC_RND_MODE);
mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODE);
mpfr_mul (x, x, d2r, GFC_RND_MODE);
mpfr_clear (d2r);
}
/* Simplification routines for SIND, COSD, TAND. */
#include "trigd_fe.inc"
/* Simplify COSD(X) where X has the unit of degree. */
gfc_expr *
gfc_simplify_cosd (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
simplify_cosd (result->value.real);
return range_check (result, "COSD");
}
/* Simplify SIND(X) where X has the unit of degree. */
gfc_expr *
gfc_simplify_sind (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
simplify_sind (result->value.real);
return range_check (result, "SIND");
}
/* Simplify TAND(X) where X has the unit of degree. */
gfc_expr *
gfc_simplify_tand (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
simplify_tand (result->value.real);
return range_check (result, "TAND");
}
/* Simplify COTAND(X) where X has the unit of degree. */
gfc_expr *
gfc_simplify_cotand (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
/* Implement COTAND = -TAND(x+90).
TAND offers correct exact values for multiples of 30 degrees.
This implementation is also compatible with the behavior of some legacy
compilers. Keep this consistent with gfc_conv_intrinsic_cotand. */
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODE);
simplify_tand (result->value.real);
mpfr_neg (result->value.real, result->value.real, GFC_RND_MODE);
return range_check (result, "COTAND");
}
gfc_expr *
gfc_simplify_cosh (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
switch (x->ts.type)
{
case BT_REAL:
mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
break;
case BT_COMPLEX:
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
break;
default:
gcc_unreachable ();
}
return range_check (result, "COSH");
}
gfc_expr *
gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
{
gfc_expr *result;
bool size_zero;
size_zero = gfc_is_size_zero_array (mask);
if (!(is_constant_array_expr (mask) || size_zero)
|| !gfc_is_constant_expr (dim)
|| !gfc_is_constant_expr (kind))
return NULL;
result = transformational_result (mask, dim,
BT_INTEGER,
get_kind (BT_INTEGER, kind, "COUNT",
gfc_default_integer_kind),
&mask->where);
init_result_expr (result, 0, NULL);
if (size_zero)
return result;
/* Passing MASK twice, once as data array, once as mask.
Whenever gfc_count is called, '1' is added to the result. */
return !dim || mask->rank == 1 ?
simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
}
/* Simplification routine for cshift. This works by copying the array
expressions into a one-dimensional array, shuffling the values into another
one-dimensional array and creating the new array expression from this. The
shuffling part is basically taken from the library routine. */
gfc_expr *
gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
{
gfc_expr *result;
int which;
gfc_expr **arrayvec, **resultvec;
gfc_expr **rptr, **sptr;
mpz_t size;
size_t arraysize, shiftsize, i;
gfc_constructor *array_ctor, *shift_ctor;
ssize_t *shiftvec, *hptr;
ssize_t shift_val, len;
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
hs_ex[GFC_MAX_DIMENSIONS + 1],
hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
h_extent[GFC_MAX_DIMENSIONS],
ss_ex[GFC_MAX_DIMENSIONS + 1];
ssize_t rsoffset;
int d, n;
bool continue_loop;
gfc_expr **src, **dest;
if (!is_constant_array_expr (array))
return NULL;
if (shift->rank > 0)
gfc_simplify_expr (shift, 1);
if (!gfc_is_constant_expr (shift))
return NULL;
/* Make dim zero-based. */
if (dim)
{
if (!gfc_is_constant_expr (dim))
return NULL;
which = mpz_get_si (dim->value.integer) - 1;
}
else
which = 0;
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
mpz_clear (size);
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
result->shape = gfc_copy_shape (array->shape, array->rank);
result->rank = array->rank;
result->ts.u.derived = array->ts.u.derived;
if (arraysize == 0)
return result;
arrayvec = XCNEWVEC (gfc_expr *, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
for (i = 0; i < arraysize; i++)
{
arrayvec[i] = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
}
resultvec = XCNEWVEC (gfc_expr *, arraysize);
extent[0] = 1;
count[0] = 0;
for (d=0; d < array->rank; d++)
{
a_extent[d] = mpz_get_si (array->shape[d]);
a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
}
if (shift->rank > 0)
{
gfc_array_size (shift, &size);
shiftsize = mpz_get_ui (size);
mpz_clear (size);
shiftvec = XCNEWVEC (ssize_t, shiftsize);
shift_ctor = gfc_constructor_first (shift->value.constructor);
for (d = 0; d < shift->rank; d++)
{
h_extent[d] = mpz_get_si (shift->shape[d]);
hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
}
}
else
shiftvec = NULL;
/* Shut up compiler */
len = 1;
rsoffset = 1;
n = 0;
for (d=0; d < array->rank; d++)
{
if (d == which)
{
rsoffset = a_stride[d];
len = a_extent[d];
}
else
{
count[n] = 0;
extent[n] = a_extent[d];
sstride[n] = a_stride[d];
ss_ex[n] = sstride[n] * extent[n];
if (shiftvec)
hs_ex[n] = hstride[n] * extent[n];
n++;
}
}
ss_ex[n] = 0;
hs_ex[n] = 0;
if (shiftvec)
{
for (i = 0; i < shiftsize; i++)
{
ssize_t val;
val = mpz_get_si (shift_ctor->expr->value.integer);
val = val % len;
if (val < 0)
val += len;
shiftvec[i] = val;
shift_ctor = gfc_constructor_next (shift_ctor);
}
shift_val = 0;
}
else
{
shift_val = mpz_get_si (shift->value.integer);
shift_val = shift_val % len;
if (shift_val < 0)
shift_val += len;
}
continue_loop = true;
d = array->rank;
rptr = resultvec;
sptr = arrayvec;
hptr = shiftvec;
while (continue_loop)
{
ssize_t sh;
if (shiftvec)
sh = *hptr;
else
sh = shift_val;
src = &sptr[sh * rsoffset];
dest = rptr;
for (n = 0; n < len - sh; n++)
{
*dest = *src;
dest += rsoffset;
src += rsoffset;
}
src = sptr;
for ( n = 0; n < sh; n++)
{
*dest = *src;
dest += rsoffset;
src += rsoffset;
}
rptr += sstride[0];
sptr += sstride[0];
if (shiftvec)
hptr += hstride[0];
count[0]++;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
rptr -= ss_ex[n];
sptr -= ss_ex[n];
if (shiftvec)
hptr -= hs_ex[n];
n++;
if (n >= d - 1)
{
continue_loop = false;
break;
}
else
{
count[n]++;
rptr += sstride[n];
sptr += sstride[n];
if (shiftvec)
hptr += hstride[n];
}
}
}
for (i = 0; i < arraysize; i++)
{
gfc_constructor_append_expr (&result->value.constructor,
gfc_copy_expr (resultvec[i]),
NULL);
}
return result;
}
gfc_expr *
gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
{
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
}
gfc_expr *
gfc_simplify_dble (gfc_expr *e)
{
gfc_expr *result = NULL;
int tmp1, tmp2;
if (e->expr_type != EXPR_CONSTANT)
return NULL;
/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
warnings. */
tmp1 = warn_conversion;
tmp2 = warn_conversion_extra;
warn_conversion = warn_conversion_extra = 0;
result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
warn_conversion = tmp1;
warn_conversion_extra = tmp2;
if (result == &gfc_bad_expr)
return &gfc_bad_expr;
return range_check (result, "DBLE");
}
gfc_expr *
gfc_simplify_digits (gfc_expr *x)
{
int i, digits;
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
switch (x->ts.type)
{
case BT_INTEGER:
digits = gfc_integer_kinds[i].digits;
break;
case BT_REAL:
case BT_COMPLEX:
digits = gfc_real_kinds[i].digits;
break;
default:
gcc_unreachable ();
}
return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
}
gfc_expr *
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;
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
switch (x->ts.type)
{
case BT_INTEGER:
if (mpz_cmp (x->value.integer, y->value.integer) > 0)
mpz_sub (result->value.integer, x->value.integer, y->value.integer);
else
mpz_set_ui (result->value.integer, 0);
break;
case BT_REAL:
if (mpfr_cmp (x->value.real, y->value.real) > 0)
mpfr_sub (result->value.real, x->value.real, y->value.real,
GFC_RND_MODE);
else
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
break;
default:
gfc_internal_error ("gfc_simplify_dim(): Bad type");
}
return range_check (result, "DIM");
}
gfc_expr*
gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
{
/* If vector_a is a zero-sized array, the result is 0 for INTEGER,
REAL, and COMPLEX types and .false. for LOGICAL. */
if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0)
{
if (vector_a->ts.type == BT_LOGICAL)
return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
else
return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
}
if (!is_constant_array_expr (vector_a)
|| !is_constant_array_expr (vector_b))
return NULL;
return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
}
gfc_expr *
gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
{
gfc_expr *a1, *a2, *result;
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
a1 = gfc_real2real (x, gfc_default_double_kind);
a2 = gfc_real2real (y, gfc_default_double_kind);
result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
gfc_free_expr (a2);
gfc_free_expr (a1);
return range_check (result, "DPROD");
}
static gfc_expr *
simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
bool right)
{
gfc_expr *result;
int i, k, size, shift;
if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
|| shiftarg->expr_type != EXPR_CONSTANT)
return NULL;
k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
size = gfc_integer_kinds[k].bit_size;
gfc_extract_int (shiftarg, &shift);
/* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
if (right)
shift = size - shift;
result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
mpz_set_ui (result->value.integer, 0);
for (i = 0; i < shift; i++)
if (mpz_tstbit (arg2->value.integer, size - shift + i))
mpz_setbit (result->value.integer, i);
for (i = 0; i < size - shift; i++)
if (mpz_tstbit (arg1->value.integer, i))
mpz_setbit (result->value.integer, shift + i);
/* Convert to a signed value. */
gfc_convert_mpz_to_signed (result->value.integer, size);
return result;
}
gfc_expr *
gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
{
return simplify_dshift (arg1, arg2, shiftarg, true);
}
gfc_expr *
gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
{
return simplify_dshift (arg1, arg2, shiftarg, false);
}
gfc_expr *
gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
gfc_expr *dim)
{
bool temp_boundary;
gfc_expr *bnd;
gfc_expr *result;
int which;
gfc_expr **arrayvec, **resultvec;
gfc_expr **rptr, **sptr;
mpz_t size;
size_t arraysize, i;
gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
ssize_t shift_val, len;
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1];
ssize_t rsoffset;
int d, n;
bool continue_loop;
gfc_expr **src, **dest;
size_t s_len;
if (!is_constant_array_expr (array))
return NULL;
if (shift->rank > 0)
gfc_simplify_expr (shift, 1);
if (!gfc_is_constant_expr (shift))
return NULL;
if (boundary)
{
if (boundary->rank > 0)
gfc_simplify_expr (boundary, 1);
if (!gfc_is_constant_expr (boundary))
return NULL;
}
if (dim)
{
if (!gfc_is_constant_expr (dim))
return NULL;
which = mpz_get_si (dim->value.integer) - 1;
}
else
which = 0;
s_len = 0;
if (boundary == NULL)
{
temp_boundary = true;
switch (array->ts.type)
{
case BT_INTEGER:
bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
break;
case BT_LOGICAL:
bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
break;
case BT_REAL:
bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
break;
case BT_COMPLEX:
bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
break;
case BT_CHARACTER:
s_len = mpz_get_ui (array->ts.u.cl->length->value.integer);
bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len);
break;
default:
gcc_unreachable();
}
}
else
{
temp_boundary = false;
bnd = boundary;
}
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
mpz_clear (size);
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
result->shape = gfc_copy_shape (array->shape, array->rank);
result->rank = array->rank;
result->ts = array->ts;
if (arraysize == 0)
goto final;
arrayvec = XCNEWVEC (gfc_expr *, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
for (i = 0; i < arraysize; i++)
{
arrayvec[i] = array_ctor->expr;
array_ctor = gfc_constructor_next (array_ctor);
}
resultvec = XCNEWVEC (gfc_expr *, arraysize);
extent[0] = 1;
count[0] = 0;
for (d=0; d < array->rank; d++)
{
a_extent[d] = mpz_get_si (array->shape[d]);
a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
}
if (shift->rank > 0)
{
shift_ctor = gfc_constructor_first (shift->value.constructor);
shift_val = 0;
}
else
{
shift_ctor = NULL;
shift_val = mpz_get_si (shift->value.integer);
}
if (bnd->rank > 0)
bnd_ctor = gfc_constructor_first (bnd->value.constructor);
else
bnd_ctor = NULL;
/* Shut up compiler */
len = 1;
rsoffset = 1;
n = 0;
for (d=0; d < array->rank; d++)
{
if (d == which)
{
rsoffset = a_stride[d];
len = a_extent[d];
}
else
{
count[n] = 0;
extent[n] = a_extent[d];
sstride[n] = a_stride[d];
ss_ex[n] = sstride[n] * extent[n];
n++;
}
}
ss_ex[n] = 0;
continue_loop = true;
d = array->rank;
rptr = resultvec;
sptr = arrayvec;
while (continue_loop)
{
ssize_t sh, delta;
if (shift_ctor)
sh = mpz_get_si (shift_ctor->expr->value.integer);
else
sh = shift_val;
if (( sh >= 0 ? sh : -sh ) > len)
{
delta = len;
sh = len;
}
else
delta = (sh >= 0) ? sh: -sh;
if (sh > 0)
{
src = &sptr[delta * rsoffset];
dest = rptr;
}
else
{
src = sptr;
dest = &rptr[delta * rsoffset];
}
for (n = 0; n < len - delta; n++)
{
*dest = *src;
dest += rsoffset;
src += rsoffset;
}
if (sh < 0)
dest = rptr;
n = delta;
if (bnd_ctor)
{
while (n--)
{
*dest = gfc_copy_expr (bnd_ctor->expr);
dest += rsoffset;
}
}
else
{
while (n--)
{
*dest = gfc_copy_expr (bnd);
dest += rsoffset;
}
}
rptr += sstride[0];
sptr += sstride[0];
if (shift_ctor)
shift_ctor = gfc_constructor_next (shift_ctor);
if (bnd_ctor)
bnd_ctor = gfc_constructor_next (bnd_ctor);
count[0]++;
n = 0;
while (count[n] == extent[n])
{
count[n] = 0;
rptr -= ss_ex[n];
sptr -= ss_ex[n];
n++;
if (n >= d - 1)
{
continue_loop = false;
break;
}
else
{
count[n]++;
rptr += sstride[n];
sptr += sstride[n];
}
}
}
for (i = 0; i < arraysize; i++)
{
gfc_constructor_append_expr (&result->value.constructor,
gfc_copy_expr (resultvec[i]),
NULL);
}
final:
if (temp_boundary)
gfc_free_expr (bnd);
return result;
}
gfc_expr *
gfc_simplify_erf (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
return range_check (result, "ERF");
}
gfc_expr *
gfc_simplify_erfc (gfc_expr *x)
{
gfc_expr *result;
if (x->expr_type != EXPR_CONSTANT)
return NULL;
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);