mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-03 00:29:47 +00:00
8913 lines
208 KiB
C++
8913 lines
208 KiB
C++
/* Simplify intrinsic functions at compile-time.
|
|
Copyright (C) 2000-2022 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;
|
|
|
|
if (array->shape == NULL)
|
|
return NULL;
|
|
|
|
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);
|
|
|
|
sstride[0] = 0;
|
|
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;
|
|
|
|
if (array->shape == NULL)
|
|
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);
|
|
mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
|
|
|
|
return range_check (result, "ERFC");
|
|
}
|
|
|
|
|
|
/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2). */
|
|
|
|
#define MAX_ITER 200
|
|
#define ARG_LIMIT 12
|
|
|
|
/* Calculate ERFC_SCALED directly by its definition:
|
|
|
|
ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
|
|
|
|
using a large precision for intermediate results. This is used for all
|
|
but large values of the argument. */
|
|
static void
|
|
fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
|
|
{
|
|
mpfr_prec_t prec;
|
|
mpfr_t a, b;
|
|
|
|
prec = mpfr_get_default_prec ();
|
|
mpfr_set_default_prec (10 * prec);
|
|
|
|
mpfr_init (a);
|
|
mpfr_init (b);
|
|
|
|
mpfr_set (a, arg, GFC_RND_MODE);
|
|
mpfr_sqr (b, a, GFC_RND_MODE);
|
|
mpfr_exp (b, b, GFC_RND_MODE);
|
|
mpfr_erfc (a, a, GFC_RND_MODE);
|
|
mpfr_mul (a, a, b, GFC_RND_MODE);
|
|
|
|
mpfr_set (res, a, GFC_RND_MODE);
|
|
mpfr_set_default_prec (prec);
|
|
|
|
mpfr_clear (a);
|
|
mpfr_clear (b);
|
|
}
|
|
|
|
/* Calculate ERFC_SCALED using a power series expansion in 1/arg:
|
|
|
|
ERFC_SCALED(x) = 1 / (x * sqrt(pi))
|
|
* (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
|
|
/ (2 * x**2)**n)
|
|
|
|
This is used for large values of the argument. Intermediate calculations
|
|
are performed with twice the precision. We don't do a fixed number of
|
|
iterations of the sum, but stop when it has converged to the required
|
|
precision. */
|
|
static void
|
|
asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
|
|
{
|
|
mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
|
|
mpz_t num;
|
|
mpfr_prec_t prec;
|
|
unsigned i;
|
|
|
|
prec = mpfr_get_default_prec ();
|
|
mpfr_set_default_prec (2 * prec);
|
|
|
|
mpfr_init (sum);
|
|
mpfr_init (x);
|
|
mpfr_init (u);
|
|
mpfr_init (v);
|
|
mpfr_init (w);
|
|
mpz_init (num);
|
|
|
|
mpfr_init (oldsum);
|
|
mpfr_init (sumtrunc);
|
|
mpfr_set_prec (oldsum, prec);
|
|
mpfr_set_prec (sumtrunc, prec);
|
|
|
|
mpfr_set (x, arg, GFC_RND_MODE);
|
|
mpfr_set_ui (sum, 1, GFC_RND_MODE);
|
|
mpz_set_ui (num, 1);
|
|
|
|
mpfr_set (u, x, GFC_RND_MODE);
|
|
mpfr_sqr (u, u, GFC_RND_MODE);
|
|
mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
|
|
mpfr_pow_si (u, u, -1, GFC_RND_MODE);
|
|
|
|
for (i = 1; i < MAX_ITER; i++)
|
|
{
|
|
mpfr_set (oldsum, sum, GFC_RND_MODE);
|
|
|
|
mpz_mul_ui (num, num, 2 * i - 1);
|
|
mpz_neg (num, num);
|
|
|
|
mpfr_set (w, u, GFC_RND_MODE);
|
|
mpfr_pow_ui (w, w, i, GFC_RND_MODE);
|
|
|
|
mpfr_set_z (v, num, GFC_RND_MODE);
|
|
mpfr_mul (v, v, w, GFC_RND_MODE);
|
|
|
|
mpfr_add (sum, sum, v, GFC_RND_MODE);
|
|
|
|
mpfr_set (sumtrunc, sum, GFC_RND_MODE);
|
|
if (mpfr_cmp (sumtrunc, oldsum) == 0)
|
|
break;
|
|
}
|
|
|
|
/* We should have converged by now; otherwise, ARG_LIMIT is probably
|
|
set too low. */
|
|
gcc_assert (i < MAX_ITER);
|
|
|
|
/* Divide by x * sqrt(Pi). */
|
|
mpfr_const_pi (u, GFC_RND_MODE);
|
|
mpfr_sqrt (u, u, GFC_RND_MODE);
|
|
mpfr_mul (u, u, x, GFC_RND_MODE);
|
|
mpfr_div (sum, sum, u, GFC_RND_MODE);
|
|
|
|
mpfr_set (res, sum, GFC_RND_MODE);
|
|
mpfr_set_default_prec (prec);
|
|
|
|
mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
|
|
mpz_clear (num);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_erfc_scaled (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);
|
|
if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
|
|
asympt_erfc_scaled (result->value.real, x->value.real);
|
|
else
|
|
fullprec_erfc_scaled (result->value.real, x->value.real);
|
|
|
|
return range_check (result, "ERFC_SCALED");
|
|
}
|
|
|
|
#undef MAX_ITER
|
|
#undef ARG_LIMIT
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_epsilon (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
|
|
mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
|
|
|
|
return range_check (result, "EPSILON");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_exp (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_exp (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
gfc_set_model_kind (x->ts.kind);
|
|
mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("in gfc_simplify_exp(): Bad type");
|
|
}
|
|
|
|
return range_check (result, "EXP");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_exponent (gfc_expr *x)
|
|
{
|
|
long int val;
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&x->where);
|
|
|
|
/* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
|
|
if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
|
|
{
|
|
int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
|
|
mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
|
|
return result;
|
|
}
|
|
|
|
/* EXPONENT(+/- 0.0) = 0 */
|
|
if (mpfr_zero_p (x->value.real))
|
|
{
|
|
mpz_set_ui (result->value.integer, 0);
|
|
return result;
|
|
}
|
|
|
|
gfc_set_model (x->value.real);
|
|
|
|
val = (long int) mpfr_get_exp (x->value.real);
|
|
mpz_set_si (result->value.integer, val);
|
|
|
|
return range_check (result, "EXPONENT");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
|
|
gfc_expr *kind)
|
|
{
|
|
if (flag_coarray == GFC_FCOARRAY_NONE)
|
|
{
|
|
gfc_current_locus = *gfc_current_intrinsic_where;
|
|
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (flag_coarray == GFC_FCOARRAY_SINGLE)
|
|
{
|
|
gfc_expr *result;
|
|
int actual_kind;
|
|
if (kind)
|
|
gfc_extract_int (kind, &actual_kind);
|
|
else
|
|
actual_kind = gfc_default_integer_kind;
|
|
|
|
result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
|
|
result->rank = 1;
|
|
return result;
|
|
}
|
|
|
|
/* For fcoarray = lib no simplification is possible, because it is not known
|
|
what images failed or are stopped at compile time. */
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
|
|
{
|
|
if (flag_coarray == GFC_FCOARRAY_NONE)
|
|
{
|
|
gfc_current_locus = *gfc_current_intrinsic_where;
|
|
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (flag_coarray == GFC_FCOARRAY_SINGLE)
|
|
{
|
|
gfc_expr *result;
|
|
result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
|
|
result->rank = 0;
|
|
return result;
|
|
}
|
|
|
|
/* For fcoarray = lib no simplification is possible, because it is not known
|
|
what images failed or are stopped at compile time. */
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_float (gfc_expr *a)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (a->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_int2real (a, gfc_default_real_kind);
|
|
|
|
return range_check (result, "FLOAT");
|
|
}
|
|
|
|
|
|
static bool
|
|
is_last_ref_vtab (gfc_expr *e)
|
|
{
|
|
gfc_ref *ref;
|
|
gfc_component *comp = NULL;
|
|
|
|
if (e->expr_type != EXPR_VARIABLE)
|
|
return false;
|
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
|
if (ref->type == REF_COMPONENT)
|
|
comp = ref->u.c.component;
|
|
|
|
if (!e->ref || !comp)
|
|
return e->symtree->n.sym->attr.vtab;
|
|
|
|
if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
|
|
return true;
|
|
|
|
return false;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
|
|
{
|
|
/* Avoid simplification of resolved symbols. */
|
|
if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
|
|
return NULL;
|
|
|
|
if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_type_is_extension_of (mold->ts.u.derived,
|
|
a->ts.u.derived));
|
|
|
|
if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
|
|
return NULL;
|
|
|
|
if ((a->ts.type == BT_CLASS && !gfc_expr_attr (a).class_ok)
|
|
|| (mold->ts.type == BT_CLASS && !gfc_expr_attr (mold).class_ok))
|
|
return NULL;
|
|
|
|
/* Return .false. if the dynamic type can never be an extension. */
|
|
if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
|
|
&& !gfc_type_is_extension_of
|
|
(mold->ts.u.derived->components->ts.u.derived,
|
|
a->ts.u.derived->components->ts.u.derived)
|
|
&& !gfc_type_is_extension_of
|
|
(a->ts.u.derived->components->ts.u.derived,
|
|
mold->ts.u.derived->components->ts.u.derived))
|
|
|| (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
|
|
&& !gfc_type_is_extension_of
|
|
(mold->ts.u.derived->components->ts.u.derived,
|
|
a->ts.u.derived))
|
|
|| (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
|
|
&& !gfc_type_is_extension_of
|
|
(mold->ts.u.derived,
|
|
a->ts.u.derived->components->ts.u.derived)
|
|
&& !gfc_type_is_extension_of
|
|
(a->ts.u.derived->components->ts.u.derived,
|
|
mold->ts.u.derived)))
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
|
|
|
|
/* Return .true. if the dynamic type is guaranteed to be an extension. */
|
|
if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
|
|
&& gfc_type_is_extension_of (mold->ts.u.derived,
|
|
a->ts.u.derived->components->ts.u.derived))
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
|
|
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
|
|
{
|
|
/* Avoid simplification of resolved symbols. */
|
|
if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
|
|
return NULL;
|
|
|
|
/* Return .false. if the dynamic type can never be the
|
|
same. */
|
|
if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
|
|
|| (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
|
|
&& !gfc_type_compatible (&a->ts, &b->ts)
|
|
&& !gfc_type_compatible (&b->ts, &a->ts))
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
|
|
|
|
if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_compare_derived_types (a->ts.u.derived,
|
|
b->ts.u.derived));
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
|
|
{
|
|
gfc_expr *result;
|
|
mpfr_t floor;
|
|
int kind;
|
|
|
|
kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
|
|
if (kind == -1)
|
|
gfc_internal_error ("gfc_simplify_floor(): Bad kind");
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
mpfr_init2 (floor, mpfr_get_prec (e->value.real));
|
|
mpfr_floor (floor, e->value.real);
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
|
|
gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
|
|
|
|
mpfr_clear (floor);
|
|
|
|
return range_check (result, "FLOOR");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_fraction (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
mpfr_exp_t e;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
|
|
|
|
/* FRACTION(inf) = NaN. */
|
|
if (mpfr_inf_p (x->value.real))
|
|
{
|
|
mpfr_set_nan (result->value.real);
|
|
return result;
|
|
}
|
|
|
|
/* mpfr_frexp() correctly handles zeros and NaNs. */
|
|
mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
|
|
|
|
return range_check (result, "FRACTION");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_gamma (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_gamma (result->value.real, x->value.real, GFC_RND_MODE);
|
|
|
|
return range_check (result, "GAMMA");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_huge (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
|
|
break;
|
|
|
|
case BT_REAL:
|
|
mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
|
|
mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
|
|
return range_check (result, "HYPOT");
|
|
}
|
|
|
|
|
|
/* We use the processor's collating sequence, because all
|
|
systems that gfortran currently works on are ASCII. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_char_t index;
|
|
int k;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (e->value.character.length != 1)
|
|
{
|
|
gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
index = e->value.character.string[0];
|
|
|
|
if (warn_surprising && index > 127)
|
|
gfc_warning (OPT_Wsurprising,
|
|
"Argument of IACHAR function at %L outside of range 0..127",
|
|
&e->where);
|
|
|
|
k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_int_expr (k, &e->where, index);
|
|
|
|
return range_check (result, "IACHAR");
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
do_bit_and (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_INTEGER
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
mpz_and (result->value.integer, result->value.integer, e->value.integer);
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, -1, do_bit_and);
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
do_bit_ior (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_INTEGER
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
mpz_ior (result->value.integer, result->value.integer, e->value.integer);
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, 0, do_bit_ior);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
|
|
mpz_and (result->value.integer, x->value.integer, y->value.integer);
|
|
|
|
return range_check (result, "IAND");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
int k, pos;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (y, &pos);
|
|
|
|
k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
|
|
|
|
result = gfc_copy_expr (x);
|
|
|
|
convert_mpz_to_unsigned (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
mpz_clrbit (result->value.integer, pos);
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
|
|
{
|
|
gfc_expr *result;
|
|
int pos, len;
|
|
int i, k, bitsize;
|
|
int *bits;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT
|
|
|| y->expr_type != EXPR_CONSTANT
|
|
|| z->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (y, &pos);
|
|
gfc_extract_int (z, &len);
|
|
|
|
k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
|
|
|
|
bitsize = gfc_integer_kinds[k].bit_size;
|
|
|
|
if (pos + len > bitsize)
|
|
{
|
|
gfc_error ("Sum of second and third arguments of IBITS exceeds "
|
|
"bit size at %L", &y->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
|
|
convert_mpz_to_unsigned (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
bits = XCNEWVEC (int, bitsize);
|
|
|
|
for (i = 0; i < bitsize; i++)
|
|
bits[i] = 0;
|
|
|
|
for (i = 0; i < len; i++)
|
|
bits[i] = mpz_tstbit (x->value.integer, i + pos);
|
|
|
|
for (i = 0; i < bitsize; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i);
|
|
else if (bits[i] == 1)
|
|
mpz_setbit (result->value.integer, i);
|
|
else
|
|
gfc_internal_error ("IBITS: Bad bit");
|
|
}
|
|
|
|
free (bits);
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
int k, pos;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (y, &pos);
|
|
|
|
k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
|
|
|
|
result = gfc_copy_expr (x);
|
|
|
|
convert_mpz_to_unsigned (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
mpz_setbit (result->value.integer, pos);
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer,
|
|
gfc_integer_kinds[k].bit_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_char_t index;
|
|
int k;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (e->value.character.length != 1)
|
|
{
|
|
gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
index = e->value.character.string[0];
|
|
|
|
k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_int_expr (k, &e->where, index);
|
|
|
|
return range_check (result, "ICHAR");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
|
|
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
|
|
|
|
return range_check (result, "IEOR");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
bool back;
|
|
HOST_WIDE_INT len, lensub, start, last, i, index = 0;
|
|
int k, delta;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
|
|
|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
|
|
return NULL;
|
|
|
|
back = (b != NULL && b->value.logical != 0);
|
|
|
|
k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
|
|
|
|
len = x->value.character.length;
|
|
lensub = y->value.character.length;
|
|
|
|
if (len < lensub)
|
|
{
|
|
mpz_set_si (result->value.integer, 0);
|
|
return result;
|
|
}
|
|
|
|
if (lensub == 0)
|
|
{
|
|
if (back)
|
|
index = len + 1;
|
|
else
|
|
index = 1;
|
|
goto done;
|
|
}
|
|
|
|
if (!back)
|
|
{
|
|
last = len + 1 - lensub;
|
|
start = 0;
|
|
delta = 1;
|
|
}
|
|
else
|
|
{
|
|
last = -1;
|
|
start = len - lensub;
|
|
delta = -1;
|
|
}
|
|
|
|
for (; start != last; start += delta)
|
|
{
|
|
for (i = 0; i < lensub; i++)
|
|
{
|
|
if (x->value.character.string[start + i]
|
|
!= y->value.character.string[i])
|
|
break;
|
|
}
|
|
if (i == lensub)
|
|
{
|
|
index = start + 1;
|
|
goto done;
|
|
}
|
|
}
|
|
|
|
done:
|
|
mpz_set_si (result->value.integer, index);
|
|
return range_check (result, "INDEX");
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_intconv (gfc_expr *e, int kind, const char *name)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
int tmp1, tmp2;
|
|
|
|
/* Convert BOZ to integer, and return without range checking. */
|
|
if (e->ts.type == BT_BOZ)
|
|
{
|
|
if (!gfc_boz2int (e, kind))
|
|
return NULL;
|
|
result = gfc_copy_expr (e);
|
|
return result;
|
|
}
|
|
|
|
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_INTEGER, kind);
|
|
|
|
warn_conversion = tmp1;
|
|
warn_conversion_extra = tmp2;
|
|
|
|
if (result == &gfc_bad_expr)
|
|
return &gfc_bad_expr;
|
|
|
|
return range_check (result, name);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_int (gfc_expr *e, gfc_expr *k)
|
|
{
|
|
int kind;
|
|
|
|
kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
|
|
if (kind == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
return simplify_intconv (e, kind, "INT");
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_int2 (gfc_expr *e)
|
|
{
|
|
return simplify_intconv (e, 2, "INT2");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_int8 (gfc_expr *e)
|
|
{
|
|
return simplify_intconv (e, 8, "INT8");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_long (gfc_expr *e)
|
|
{
|
|
return simplify_intconv (e, 4, "LONG");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ifix (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_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&e->where);
|
|
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
|
|
|
|
gfc_free_expr (rtrunc);
|
|
|
|
return range_check (result, "IFIX");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_idint (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_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&e->where);
|
|
gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
|
|
|
|
gfc_free_expr (rtrunc);
|
|
|
|
return range_check (result, "IDINT");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
|
|
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
|
|
|
|
return range_check (result, "IOR");
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
do_bit_xor (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_INTEGER
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
mpz_xor (result->value.integer, result->value.integer, e->value.integer);
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, 0, do_bit_xor);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_is_iostat_end (gfc_expr *x)
|
|
{
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
|
|
mpz_cmp_si (x->value.integer,
|
|
LIBERROR_END) == 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_is_iostat_eor (gfc_expr *x)
|
|
{
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
|
|
mpz_cmp_si (x->value.integer,
|
|
LIBERROR_EOR) == 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_isnan (gfc_expr *x)
|
|
{
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
|
|
mpfr_nan_p (x->value.real));
|
|
}
|
|
|
|
|
|
/* Performs a shift on its first argument. Depending on the last
|
|
argument, the shift can be arithmetic, i.e. with filling from the
|
|
left like in the SHIFTA intrinsic. */
|
|
static gfc_expr *
|
|
simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
|
|
bool arithmetic, int direction)
|
|
{
|
|
gfc_expr *result;
|
|
int ashift, *bits, i, k, bitsize, shift;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (s, &shift);
|
|
|
|
k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
|
|
bitsize = gfc_integer_kinds[k].bit_size;
|
|
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
|
|
if (shift == 0)
|
|
{
|
|
mpz_set (result->value.integer, e->value.integer);
|
|
return result;
|
|
}
|
|
|
|
if (direction > 0 && shift < 0)
|
|
{
|
|
/* Left shift, as in SHIFTL. */
|
|
gfc_error ("Second argument of %s is negative at %L", name, &e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
else if (direction < 0)
|
|
{
|
|
/* Right shift, as in SHIFTR or SHIFTA. */
|
|
if (shift < 0)
|
|
{
|
|
gfc_error ("Second argument of %s is negative at %L",
|
|
name, &e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
shift = -shift;
|
|
}
|
|
|
|
ashift = (shift >= 0 ? shift : -shift);
|
|
|
|
if (ashift > bitsize)
|
|
{
|
|
gfc_error ("Magnitude of second argument of %s exceeds bit size "
|
|
"at %L", name, &e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
bits = XCNEWVEC (int, bitsize);
|
|
|
|
for (i = 0; i < bitsize; i++)
|
|
bits[i] = mpz_tstbit (e->value.integer, i);
|
|
|
|
if (shift > 0)
|
|
{
|
|
/* Left shift. */
|
|
for (i = 0; i < shift; i++)
|
|
mpz_clrbit (result->value.integer, i);
|
|
|
|
for (i = 0; i < bitsize - shift; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i + shift);
|
|
else
|
|
mpz_setbit (result->value.integer, i + shift);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
/* Right shift. */
|
|
if (arithmetic && bits[bitsize - 1])
|
|
for (i = bitsize - 1; i >= bitsize - ashift; i--)
|
|
mpz_setbit (result->value.integer, i);
|
|
else
|
|
for (i = bitsize - 1; i >= bitsize - ashift; i--)
|
|
mpz_clrbit (result->value.integer, i);
|
|
|
|
for (i = bitsize - 1; i >= ashift; i--)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i - ashift);
|
|
else
|
|
mpz_setbit (result->value.integer, i - ashift);
|
|
}
|
|
}
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer, bitsize);
|
|
free (bits);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "ISHFT", false, 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "LSHIFT", false, 1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "RSHIFT", true, -1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "SHIFTA", true, -1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "SHIFTL", false, 1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
|
|
{
|
|
return simplify_shift (e, s, "SHIFTR", false, -1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
|
|
{
|
|
gfc_expr *result;
|
|
int shift, ashift, isize, ssize, delta, k;
|
|
int i, *bits;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (s, &shift);
|
|
|
|
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
isize = gfc_integer_kinds[k].bit_size;
|
|
|
|
if (sz != NULL)
|
|
{
|
|
if (sz->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
gfc_extract_int (sz, &ssize);
|
|
}
|
|
else
|
|
ssize = isize;
|
|
|
|
if (shift >= 0)
|
|
ashift = shift;
|
|
else
|
|
ashift = -shift;
|
|
|
|
if (ashift > ssize)
|
|
{
|
|
if (sz == NULL)
|
|
gfc_error ("Magnitude of second argument of ISHFTC exceeds "
|
|
"BIT_SIZE of first argument at %C");
|
|
else
|
|
gfc_error ("Absolute value of SHIFT shall be less than or equal "
|
|
"to SIZE at %C");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
|
|
mpz_set (result->value.integer, e->value.integer);
|
|
|
|
if (shift == 0)
|
|
return result;
|
|
|
|
convert_mpz_to_unsigned (result->value.integer, isize);
|
|
|
|
bits = XCNEWVEC (int, ssize);
|
|
|
|
for (i = 0; i < ssize; i++)
|
|
bits[i] = mpz_tstbit (e->value.integer, i);
|
|
|
|
delta = ssize - ashift;
|
|
|
|
if (shift > 0)
|
|
{
|
|
for (i = 0; i < delta; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i + shift);
|
|
else
|
|
mpz_setbit (result->value.integer, i + shift);
|
|
}
|
|
|
|
for (i = delta; i < ssize; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i - delta);
|
|
else
|
|
mpz_setbit (result->value.integer, i - delta);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
for (i = 0; i < ashift; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i + delta);
|
|
else
|
|
mpz_setbit (result->value.integer, i + delta);
|
|
}
|
|
|
|
for (i = ashift; i < ssize; i++)
|
|
{
|
|
if (bits[i] == 0)
|
|
mpz_clrbit (result->value.integer, i + shift);
|
|
else
|
|
mpz_setbit (result->value.integer, i + shift);
|
|
}
|
|
}
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer, isize);
|
|
|
|
free (bits);
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_kind (gfc_expr *e)
|
|
{
|
|
return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
|
|
gfc_array_spec *as, gfc_ref *ref, bool coarray)
|
|
{
|
|
gfc_expr *l, *u, *result;
|
|
int k;
|
|
|
|
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
|
|
gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
|
|
|
|
/* For non-variables, LBOUND(expr, DIM=n) = 1 and
|
|
UBOUND(expr, DIM=n) = SIZE(expr, DIM=n). */
|
|
if (!coarray && array->expr_type != EXPR_VARIABLE)
|
|
{
|
|
if (upper)
|
|
{
|
|
gfc_expr* dim = result;
|
|
mpz_set_si (dim->value.integer, d);
|
|
|
|
result = simplify_size (array, dim, k);
|
|
gfc_free_expr (dim);
|
|
if (!result)
|
|
goto returnNull;
|
|
}
|
|
else
|
|
mpz_set_si (result->value.integer, 1);
|
|
|
|
goto done;
|
|
}
|
|
|
|
/* Otherwise, we have a variable expression. */
|
|
gcc_assert (array->expr_type == EXPR_VARIABLE);
|
|
gcc_assert (as);
|
|
|
|
if (!gfc_resolve_array_spec (as, 0))
|
|
return NULL;
|
|
|
|
/* The last dimension of an assumed-size array is special. */
|
|
if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
|
|
|| (coarray && d == as->rank + as->corank
|
|
&& (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
|
|
{
|
|
if (as->lower[d-1] && as->lower[d-1]->expr_type == EXPR_CONSTANT)
|
|
{
|
|
gfc_free_expr (result);
|
|
return gfc_copy_expr (as->lower[d-1]);
|
|
}
|
|
|
|
goto returnNull;
|
|
}
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
|
|
|
|
/* Then, we need to know the extent of the given dimension. */
|
|
if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
|
|
{
|
|
gfc_expr *declared_bound;
|
|
int empty_bound;
|
|
bool constant_lbound, constant_ubound;
|
|
|
|
l = as->lower[d-1];
|
|
u = as->upper[d-1];
|
|
|
|
gcc_assert (l != NULL);
|
|
|
|
constant_lbound = l->expr_type == EXPR_CONSTANT;
|
|
constant_ubound = u && u->expr_type == EXPR_CONSTANT;
|
|
|
|
empty_bound = upper ? 0 : 1;
|
|
declared_bound = upper ? u : l;
|
|
|
|
if ((!upper && !constant_lbound)
|
|
|| (upper && !constant_ubound))
|
|
goto returnNull;
|
|
|
|
if (!coarray)
|
|
{
|
|
/* For {L,U}BOUND, the value depends on whether the array
|
|
is empty. We can nevertheless simplify if the declared bound
|
|
has the same value as that of an empty array, in which case
|
|
the result isn't dependent on the array emptyness. */
|
|
if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
|
|
mpz_set_si (result->value.integer, empty_bound);
|
|
else if (!constant_lbound || !constant_ubound)
|
|
/* Array emptyness can't be determined, we can't simplify. */
|
|
goto returnNull;
|
|
else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
|
|
mpz_set_si (result->value.integer, empty_bound);
|
|
else
|
|
mpz_set (result->value.integer, declared_bound->value.integer);
|
|
}
|
|
else
|
|
mpz_set (result->value.integer, declared_bound->value.integer);
|
|
}
|
|
else
|
|
{
|
|
if (upper)
|
|
{
|
|
int d2 = 0, cnt = 0;
|
|
for (int idx = 0; idx < ref->u.ar.dimen; ++idx)
|
|
{
|
|
if (ref->u.ar.dimen_type[idx] == DIMEN_ELEMENT)
|
|
d2++;
|
|
else if (cnt < d - 1)
|
|
cnt++;
|
|
else
|
|
break;
|
|
}
|
|
if (!gfc_ref_dimen_size (&ref->u.ar, d2 + d - 1, &result->value.integer, NULL))
|
|
goto returnNull;
|
|
}
|
|
else
|
|
mpz_set_si (result->value.integer, (long int) 1);
|
|
}
|
|
|
|
done:
|
|
return range_check (result, upper ? "UBOUND" : "LBOUND");
|
|
|
|
returnNull:
|
|
gfc_free_expr (result);
|
|
return NULL;
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
|
|
{
|
|
gfc_ref *ref;
|
|
gfc_array_spec *as;
|
|
ar_type type = AR_UNKNOWN;
|
|
int d;
|
|
|
|
if (array->ts.type == BT_CLASS)
|
|
return NULL;
|
|
|
|
if (array->expr_type != EXPR_VARIABLE)
|
|
{
|
|
as = NULL;
|
|
ref = NULL;
|
|
goto done;
|
|
}
|
|
|
|
/* Do not attempt to resolve if error has already been issued. */
|
|
if (array->symtree->n.sym->error)
|
|
return NULL;
|
|
|
|
/* Follow any component references. */
|
|
as = array->symtree->n.sym->as;
|
|
for (ref = array->ref; ref; ref = ref->next)
|
|
{
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
type = ref->u.ar.type;
|
|
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_UNKNOWN:
|
|
return NULL;
|
|
|
|
case AR_SECTION:
|
|
as = ref->u.ar.as;
|
|
goto done;
|
|
}
|
|
|
|
gcc_unreachable ();
|
|
|
|
case REF_COMPONENT:
|
|
as = ref->u.c.component->as;
|
|
continue;
|
|
|
|
case REF_SUBSTRING:
|
|
case REF_INQUIRY:
|
|
continue;
|
|
}
|
|
}
|
|
|
|
gcc_unreachable ();
|
|
|
|
done:
|
|
|
|
if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
|
|
|| (as->type == AS_ASSUMED_SHAPE && upper)))
|
|
return NULL;
|
|
|
|
/* 'array' shall not be an unallocated allocatable variable or a pointer that
|
|
is not associated. */
|
|
if (array->expr_type == EXPR_VARIABLE
|
|
&& (gfc_expr_attr (array).allocatable || gfc_expr_attr (array).pointer))
|
|
return NULL;
|
|
|
|
gcc_assert (!as
|
|
|| (as->type != AS_DEFERRED
|
|
&& array->expr_type == EXPR_VARIABLE
|
|
&& !gfc_expr_attr (array).allocatable
|
|
&& !gfc_expr_attr (array).pointer));
|
|
|
|
if (dim == NULL)
|
|
{
|
|
/* Multi-dimensional bounds. */
|
|
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
|
|
gfc_expr *e;
|
|
int k;
|
|
|
|
/* UBOUND(ARRAY) is not valid for an assumed-size array. */
|
|
if (upper && type == AR_FULL && as && as->type == AS_ASSUMED_SIZE)
|
|
{
|
|
/* An error message will be emitted in
|
|
check_assumed_size_reference (resolve.cc). */
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
/* Simplify the bounds for each dimension. */
|
|
for (d = 0; d < array->rank; d++)
|
|
{
|
|
bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
|
|
false);
|
|
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
|
|
{
|
|
int j;
|
|
|
|
for (j = 0; j < d; j++)
|
|
gfc_free_expr (bounds[j]);
|
|
|
|
if (gfc_seen_div0)
|
|
return &gfc_bad_expr;
|
|
else
|
|
return bounds[d];
|
|
}
|
|
}
|
|
|
|
/* Allocate the result expression. */
|
|
k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
|
|
gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
|
|
|
|
/* The result is a rank 1 array; its size is the rank of the first
|
|
argument to {L,U}BOUND. */
|
|
e->rank = 1;
|
|
e->shape = gfc_get_shape (1);
|
|
mpz_init_set_ui (e->shape[0], array->rank);
|
|
|
|
/* Create the constructor for this array. */
|
|
for (d = 0; d < array->rank; d++)
|
|
gfc_constructor_append_expr (&e->value.constructor,
|
|
bounds[d], &e->where);
|
|
|
|
return e;
|
|
}
|
|
else
|
|
{
|
|
/* A DIM argument is specified. */
|
|
if (dim->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
d = mpz_get_si (dim->value.integer);
|
|
|
|
if ((d < 1 || d > array->rank)
|
|
|| (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
|
|
{
|
|
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (as && as->type == AS_ASSUMED_RANK)
|
|
return NULL;
|
|
|
|
return simplify_bound_dim (array, kind, d, upper, as, ref, false);
|
|
}
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
|
|
{
|
|
gfc_ref *ref;
|
|
gfc_array_spec *as;
|
|
int d;
|
|
|
|
if (array->expr_type != EXPR_VARIABLE)
|
|
return NULL;
|
|
|
|
/* Follow any component references. */
|
|
as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
|
|
? array->ts.u.derived->components->as
|
|
: array->symtree->n.sym->as;
|
|
for (ref = array->ref; ref; ref = ref->next)
|
|
{
|
|
switch (ref->type)
|
|
{
|
|
case REF_ARRAY:
|
|
switch (ref->u.ar.type)
|
|
{
|
|
case AR_ELEMENT:
|
|
if (ref->u.ar.as->corank > 0)
|
|
{
|
|
gcc_assert (as == ref->u.ar.as);
|
|
goto done;
|
|
}
|
|
as = NULL;
|
|
continue;
|
|
|
|
case AR_FULL:
|
|
/* We're done because 'as' has already been set in the
|
|
previous iteration. */
|
|
goto done;
|
|
|
|
case AR_UNKNOWN:
|
|
return NULL;
|
|
|
|
case AR_SECTION:
|
|
as = ref->u.ar.as;
|
|
goto done;
|
|
}
|
|
|
|
gcc_unreachable ();
|
|
|
|
case REF_COMPONENT:
|
|
as = ref->u.c.component->as;
|
|
continue;
|
|
|
|
case REF_SUBSTRING:
|
|
case REF_INQUIRY:
|
|
continue;
|
|
}
|
|
}
|
|
|
|
if (!as)
|
|
gcc_unreachable ();
|
|
|
|
done:
|
|
|
|
if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
|
|
return NULL;
|
|
|
|
if (dim == NULL)
|
|
{
|
|
/* Multi-dimensional cobounds. */
|
|
gfc_expr *bounds[GFC_MAX_DIMENSIONS];
|
|
gfc_expr *e;
|
|
int k;
|
|
|
|
/* Simplify the cobounds for each dimension. */
|
|
for (d = 0; d < as->corank; d++)
|
|
{
|
|
bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
|
|
upper, as, ref, true);
|
|
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
|
|
{
|
|
int j;
|
|
|
|
for (j = 0; j < d; j++)
|
|
gfc_free_expr (bounds[j]);
|
|
return bounds[d];
|
|
}
|
|
}
|
|
|
|
/* Allocate the result expression. */
|
|
e = gfc_get_expr ();
|
|
e->where = array->where;
|
|
e->expr_type = EXPR_ARRAY;
|
|
e->ts.type = BT_INTEGER;
|
|
k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
|
|
gfc_default_integer_kind);
|
|
if (k == -1)
|
|
{
|
|
gfc_free_expr (e);
|
|
return &gfc_bad_expr;
|
|
}
|
|
e->ts.kind = k;
|
|
|
|
/* The result is a rank 1 array; its size is the rank of the first
|
|
argument to {L,U}COBOUND. */
|
|
e->rank = 1;
|
|
e->shape = gfc_get_shape (1);
|
|
mpz_init_set_ui (e->shape[0], as->corank);
|
|
|
|
/* Create the constructor for this array. */
|
|
for (d = 0; d < as->corank; d++)
|
|
gfc_constructor_append_expr (&e->value.constructor,
|
|
bounds[d], &e->where);
|
|
return e;
|
|
}
|
|
else
|
|
{
|
|
/* A DIM argument is specified. */
|
|
if (dim->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
d = mpz_get_si (dim->value.integer);
|
|
|
|
if (d < 1 || d > as->corank)
|
|
{
|
|
gfc_error ("DIM argument at %L is out of bounds", &dim->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
|
|
}
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
|
{
|
|
return simplify_bound (array, dim, kind, 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
|
{
|
|
return simplify_cobound (array, dim, kind, 0);
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_leadz (gfc_expr *e)
|
|
{
|
|
unsigned long lz, bs;
|
|
int i;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
bs = gfc_integer_kinds[i].bit_size;
|
|
if (mpz_cmp_si (e->value.integer, 0) == 0)
|
|
lz = bs;
|
|
else if (mpz_cmp_si (e->value.integer, 0) < 0)
|
|
lz = 0;
|
|
else
|
|
lz = bs - mpz_sizeinbase (e->value.integer, 2);
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
|
|
}
|
|
|
|
|
|
/* Check for constant length of a substring. */
|
|
|
|
static bool
|
|
substring_has_constant_len (gfc_expr *e)
|
|
{
|
|
gfc_ref *ref;
|
|
HOST_WIDE_INT istart, iend, length;
|
|
bool equal_length = false;
|
|
|
|
if (e->ts.type != BT_CHARACTER)
|
|
return false;
|
|
|
|
for (ref = e->ref; ref; ref = ref->next)
|
|
if (ref->type != REF_COMPONENT && ref->type != REF_ARRAY)
|
|
break;
|
|
|
|
if (!ref
|
|
|| ref->type != REF_SUBSTRING
|
|
|| !ref->u.ss.start
|
|
|| ref->u.ss.start->expr_type != EXPR_CONSTANT
|
|
|| !ref->u.ss.end
|
|
|| ref->u.ss.end->expr_type != EXPR_CONSTANT)
|
|
return false;
|
|
|
|
/* Basic checks on substring starting and ending indices. */
|
|
if (!gfc_resolve_substring (ref, &equal_length))
|
|
return false;
|
|
|
|
istart = gfc_mpz_get_hwi (ref->u.ss.start->value.integer);
|
|
iend = gfc_mpz_get_hwi (ref->u.ss.end->value.integer);
|
|
|
|
if (istart <= iend)
|
|
length = iend - istart + 1;
|
|
else
|
|
length = 0;
|
|
|
|
/* Fix substring length. */
|
|
e->value.character.length = length;
|
|
|
|
return true;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
|
|
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
if (e->expr_type == EXPR_CONSTANT
|
|
|| substring_has_constant_len (e))
|
|
{
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
|
|
mpz_set_si (result->value.integer, e->value.character.length);
|
|
return range_check (result, "LEN");
|
|
}
|
|
else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
|
|
&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT
|
|
&& e->ts.u.cl->length->ts.type == BT_INTEGER)
|
|
{
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
|
|
mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
|
|
return range_check (result, "LEN");
|
|
}
|
|
else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
|
|
&& e->symtree->n.sym
|
|
&& e->symtree->n.sym->ts.type != BT_DERIVED
|
|
&& e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
|
|
&& e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
|
|
&& e->symtree->n.sym->assoc->target->symtree->n.sym
|
|
&& UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
|
|
|
|
/* The expression in assoc->target points to a ref to the _data component
|
|
of the unlimited polymorphic entity. To get the _len component the last
|
|
_data ref needs to be stripped and a ref to the _len component added. */
|
|
return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
|
|
else
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
size_t count, len, i;
|
|
int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
|
|
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
len = e->value.character.length;
|
|
for (count = 0, i = 1; i <= len; i++)
|
|
if (e->value.character.string[len - i] == ' ')
|
|
count++;
|
|
else
|
|
break;
|
|
|
|
result = gfc_get_int_expr (k, &e->where, len - count);
|
|
return range_check (result, "LEN_TRIM");
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lgamma (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
int sg;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
|
|
mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
|
|
|
|
return range_check (result, "LGAMMA");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
|
|
{
|
|
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_compare_string (a, b) >= 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
|
|
{
|
|
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_compare_string (a, b) > 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
|
|
{
|
|
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_compare_string (a, b) <= 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
|
|
{
|
|
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
|
|
gfc_compare_string (a, b) < 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_log (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:
|
|
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);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
if (mpfr_zero_p (mpc_realref (x->value.complex))
|
|
&& mpfr_zero_p (mpc_imagref (x->value.complex)))
|
|
{
|
|
gfc_error ("Complex argument of LOG at %L cannot be zero",
|
|
&x->where);
|
|
gfc_free_expr (result);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
gfc_set_model_kind (x->ts.kind);
|
|
mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("gfc_simplify_log: bad type");
|
|
}
|
|
|
|
return range_check (result, "LOG");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_log10 (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (mpfr_sgn (x->value.real) <= 0)
|
|
{
|
|
gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
|
|
"to zero", &x->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
|
|
mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
|
|
|
|
return range_check (result, "LOG10");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
|
|
{
|
|
int kind;
|
|
|
|
kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
|
|
if (kind < 0)
|
|
return &gfc_bad_expr;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
return gfc_get_logical_expr (kind, &e->where, e->value.logical);
|
|
}
|
|
|
|
|
|
gfc_expr*
|
|
gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
|
|
{
|
|
gfc_expr *result;
|
|
int row, result_rows, col, result_columns;
|
|
int stride_a, offset_a, stride_b, offset_b;
|
|
|
|
if (!is_constant_array_expr (matrix_a)
|
|
|| !is_constant_array_expr (matrix_b))
|
|
return NULL;
|
|
|
|
/* MATMUL should do mixed-mode arithmetic. Set the result type. */
|
|
if (matrix_a->ts.type != matrix_b->ts.type)
|
|
{
|
|
gfc_expr e;
|
|
e.expr_type = EXPR_OP;
|
|
gfc_clear_ts (&e.ts);
|
|
e.value.op.op = INTRINSIC_NONE;
|
|
e.value.op.op1 = matrix_a;
|
|
e.value.op.op2 = matrix_b;
|
|
gfc_type_convert_binary (&e, 1);
|
|
result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
|
|
}
|
|
else
|
|
{
|
|
result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
|
|
&matrix_a->where);
|
|
}
|
|
|
|
if (matrix_a->rank == 1 && matrix_b->rank == 2)
|
|
{
|
|
result_rows = 1;
|
|
result_columns = mpz_get_si (matrix_b->shape[1]);
|
|
stride_a = 1;
|
|
stride_b = mpz_get_si (matrix_b->shape[0]);
|
|
|
|
result->rank = 1;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
mpz_init_set_si (result->shape[0], result_columns);
|
|
}
|
|
else if (matrix_a->rank == 2 && matrix_b->rank == 1)
|
|
{
|
|
result_rows = mpz_get_si (matrix_a->shape[0]);
|
|
result_columns = 1;
|
|
stride_a = mpz_get_si (matrix_a->shape[0]);
|
|
stride_b = 1;
|
|
|
|
result->rank = 1;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
mpz_init_set_si (result->shape[0], result_rows);
|
|
}
|
|
else if (matrix_a->rank == 2 && matrix_b->rank == 2)
|
|
{
|
|
result_rows = mpz_get_si (matrix_a->shape[0]);
|
|
result_columns = mpz_get_si (matrix_b->shape[1]);
|
|
stride_a = mpz_get_si (matrix_a->shape[0]);
|
|
stride_b = mpz_get_si (matrix_b->shape[0]);
|
|
|
|
result->rank = 2;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
mpz_init_set_si (result->shape[0], result_rows);
|
|
mpz_init_set_si (result->shape[1], result_columns);
|
|
}
|
|
else
|
|
gcc_unreachable();
|
|
|
|
offset_b = 0;
|
|
for (col = 0; col < result_columns; ++col)
|
|
{
|
|
offset_a = 0;
|
|
|
|
for (row = 0; row < result_rows; ++row)
|
|
{
|
|
gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
|
|
matrix_b, 1, offset_b, false);
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
e, NULL);
|
|
|
|
offset_a += 1;
|
|
}
|
|
|
|
offset_b += stride_b;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
|
|
{
|
|
gfc_expr *result;
|
|
int kind, arg, k;
|
|
|
|
if (i->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
|
|
if (kind == -1)
|
|
return &gfc_bad_expr;
|
|
k = gfc_validate_kind (BT_INTEGER, kind, false);
|
|
|
|
bool fail = gfc_extract_int (i, &arg);
|
|
gcc_assert (!fail);
|
|
|
|
if (!gfc_check_mask (i, kind_arg))
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
|
|
|
|
/* MASKR(n) = 2^n - 1 */
|
|
mpz_set_ui (result->value.integer, 1);
|
|
mpz_mul_2exp (result->value.integer, result->value.integer, arg);
|
|
mpz_sub_ui (result->value.integer, result->value.integer, 1);
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
|
|
{
|
|
gfc_expr *result;
|
|
int kind, arg, k;
|
|
mpz_t z;
|
|
|
|
if (i->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
|
|
if (kind == -1)
|
|
return &gfc_bad_expr;
|
|
k = gfc_validate_kind (BT_INTEGER, kind, false);
|
|
|
|
bool fail = gfc_extract_int (i, &arg);
|
|
gcc_assert (!fail);
|
|
|
|
if (!gfc_check_mask (i, kind_arg))
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
|
|
|
|
/* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
|
|
mpz_init_set_ui (z, 1);
|
|
mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
|
|
mpz_set_ui (result->value.integer, 1);
|
|
mpz_mul_2exp (result->value.integer, result->value.integer,
|
|
gfc_integer_kinds[k].bit_size - arg);
|
|
mpz_sub (result->value.integer, z, result->value.integer);
|
|
mpz_clear (z);
|
|
|
|
gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
|
|
{
|
|
gfc_expr * result;
|
|
gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
|
|
|
|
if (mask->expr_type == EXPR_CONSTANT)
|
|
{
|
|
result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
|
|
/* Parenthesis is needed to get lower bounds of 1. */
|
|
result = gfc_get_parentheses (result);
|
|
gfc_simplify_expr (result, 1);
|
|
return result;
|
|
}
|
|
|
|
if (!mask->rank || !is_constant_array_expr (mask)
|
|
|| !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
|
|
return NULL;
|
|
|
|
result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
|
|
&tsource->where);
|
|
if (tsource->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = tsource->ts.u.derived;
|
|
else if (tsource->ts.type == BT_CHARACTER)
|
|
result->ts.u.cl = tsource->ts.u.cl;
|
|
|
|
tsource_ctor = gfc_constructor_first (tsource->value.constructor);
|
|
fsource_ctor = gfc_constructor_first (fsource->value.constructor);
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
|
|
while (mask_ctor)
|
|
{
|
|
if (mask_ctor->expr->value.logical)
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (tsource_ctor->expr),
|
|
NULL);
|
|
else
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (fsource_ctor->expr),
|
|
NULL);
|
|
tsource_ctor = gfc_constructor_next (tsource_ctor);
|
|
fsource_ctor = gfc_constructor_next (fsource_ctor);
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
|
}
|
|
|
|
result->shape = gfc_get_shape (1);
|
|
gfc_array_size (result, &result->shape[0]);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
|
|
{
|
|
mpz_t arg1, arg2, mask;
|
|
gfc_expr *result;
|
|
|
|
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
|
|
|| mask_expr->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
|
|
|
|
/* Convert all argument to unsigned. */
|
|
mpz_init_set (arg1, i->value.integer);
|
|
mpz_init_set (arg2, j->value.integer);
|
|
mpz_init_set (mask, mask_expr->value.integer);
|
|
|
|
/* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))). */
|
|
mpz_and (arg1, arg1, mask);
|
|
mpz_com (mask, mask);
|
|
mpz_and (arg2, arg2, mask);
|
|
mpz_ior (result->value.integer, arg1, arg2);
|
|
|
|
mpz_clear (arg1);
|
|
mpz_clear (arg2);
|
|
mpz_clear (mask);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
/* Selects between current value and extremum for simplify_min_max
|
|
and simplify_minval_maxval. */
|
|
static int
|
|
min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
|
|
{
|
|
int ret;
|
|
|
|
switch (arg->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
if (extremum->ts.kind < arg->ts.kind)
|
|
extremum->ts.kind = arg->ts.kind;
|
|
ret = mpz_cmp (arg->value.integer,
|
|
extremum->value.integer) * sign;
|
|
if (ret > 0)
|
|
mpz_set (extremum->value.integer, arg->value.integer);
|
|
break;
|
|
|
|
case BT_REAL:
|
|
if (extremum->ts.kind < arg->ts.kind)
|
|
extremum->ts.kind = arg->ts.kind;
|
|
if (mpfr_nan_p (extremum->value.real))
|
|
{
|
|
ret = 1;
|
|
mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
|
|
}
|
|
else if (mpfr_nan_p (arg->value.real))
|
|
ret = -1;
|
|
else
|
|
{
|
|
ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
|
|
if (ret > 0)
|
|
mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
|
|
}
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
#define LENGTH(x) ((x)->value.character.length)
|
|
#define STRING(x) ((x)->value.character.string)
|
|
if (LENGTH (extremum) < LENGTH(arg))
|
|
{
|
|
gfc_char_t *tmp = STRING(extremum);
|
|
|
|
STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
|
|
memcpy (STRING(extremum), tmp,
|
|
LENGTH(extremum) * sizeof (gfc_char_t));
|
|
gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
|
|
LENGTH(arg) - LENGTH(extremum));
|
|
STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
|
|
LENGTH(extremum) = LENGTH(arg);
|
|
free (tmp);
|
|
}
|
|
ret = gfc_compare_string (arg, extremum) * sign;
|
|
if (ret > 0)
|
|
{
|
|
free (STRING(extremum));
|
|
STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
|
|
memcpy (STRING(extremum), STRING(arg),
|
|
LENGTH(arg) * sizeof (gfc_char_t));
|
|
gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
|
|
LENGTH(extremum) - LENGTH(arg));
|
|
STRING(extremum)[LENGTH(extremum)] = '\0'; /* For debugger */
|
|
}
|
|
#undef LENGTH
|
|
#undef STRING
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("simplify_min_max(): Bad type in arglist");
|
|
}
|
|
if (back_val && ret == 0)
|
|
ret = 1;
|
|
|
|
return ret;
|
|
}
|
|
|
|
|
|
/* This function is special since MAX() can take any number of
|
|
arguments. The simplified expression is a rewritten version of the
|
|
argument list containing at most one constant element. Other
|
|
constant elements are deleted. Because the argument list has
|
|
already been checked, this function always succeeds. sign is 1 for
|
|
MAX(), -1 for MIN(). */
|
|
|
|
static gfc_expr *
|
|
simplify_min_max (gfc_expr *expr, int sign)
|
|
{
|
|
int tmp1, tmp2;
|
|
gfc_actual_arglist *arg, *last, *extremum;
|
|
gfc_expr *tmp, *ret;
|
|
const char *fname;
|
|
|
|
last = NULL;
|
|
extremum = NULL;
|
|
|
|
arg = expr->value.function.actual;
|
|
|
|
for (; arg; last = arg, arg = arg->next)
|
|
{
|
|
if (arg->expr->expr_type != EXPR_CONSTANT)
|
|
continue;
|
|
|
|
if (extremum == NULL)
|
|
{
|
|
extremum = arg;
|
|
continue;
|
|
}
|
|
|
|
min_max_choose (arg->expr, extremum->expr, sign);
|
|
|
|
/* Delete the extra constant argument. */
|
|
last->next = arg->next;
|
|
|
|
arg->next = NULL;
|
|
gfc_free_actual_arglist (arg);
|
|
arg = last;
|
|
}
|
|
|
|
/* If there is one value left, replace the function call with the
|
|
expression. */
|
|
if (expr->value.function.actual->next != NULL)
|
|
return NULL;
|
|
|
|
/* Handle special cases of specific functions (min|max)1 and
|
|
a(min|max)0. */
|
|
|
|
tmp = expr->value.function.actual->expr;
|
|
fname = expr->value.function.isym->name;
|
|
|
|
if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
|
|
&& (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
|
|
{
|
|
/* Explicit conversion, turn off -Wconversion and -Wconversion-extra
|
|
warnings. */
|
|
tmp1 = warn_conversion;
|
|
tmp2 = warn_conversion_extra;
|
|
warn_conversion = warn_conversion_extra = 0;
|
|
|
|
ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
|
|
|
|
warn_conversion = tmp1;
|
|
warn_conversion_extra = tmp2;
|
|
}
|
|
else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
|
|
&& (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
|
|
{
|
|
ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
|
|
}
|
|
else
|
|
ret = gfc_copy_expr (tmp);
|
|
|
|
return ret;
|
|
|
|
}
|
|
|
|
|
|
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);
|
|
}
|
|
|
|
/* Helper function for gfc_simplify_minval. */
|
|
|
|
static gfc_expr *
|
|
gfc_min (gfc_expr *op1, gfc_expr *op2)
|
|
{
|
|
min_max_choose (op1, op2, -1);
|
|
gfc_free_expr (op1);
|
|
return op2;
|
|
}
|
|
|
|
/* Simplify minval for constant arrays. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
|
|
}
|
|
|
|
/* Helper function for gfc_simplify_maxval. */
|
|
|
|
static gfc_expr *
|
|
gfc_max (gfc_expr *op1, gfc_expr *op2)
|
|
{
|
|
min_max_choose (op1, op2, 1);
|
|
gfc_free_expr (op1);
|
|
return op2;
|
|
}
|
|
|
|
|
|
/* Simplify maxval for constant arrays. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
|
|
}
|
|
|
|
|
|
/* Transform minloc or maxloc of an array, according to MASK,
|
|
to the scalar result. This code is mostly identical to
|
|
simplify_transformation_to_scalar. */
|
|
|
|
static gfc_expr *
|
|
simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
|
|
gfc_expr *extremum, int sign, bool back_val)
|
|
{
|
|
gfc_expr *a, *m;
|
|
gfc_constructor *array_ctor, *mask_ctor;
|
|
mpz_t count;
|
|
|
|
mpz_set_si (result->value.integer, 0);
|
|
|
|
|
|
/* 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);
|
|
if (mask && mask->expr_type == EXPR_ARRAY)
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
else
|
|
mask_ctor = NULL;
|
|
|
|
mpz_init_set_si (count, 0);
|
|
while (array_ctor)
|
|
{
|
|
mpz_add_ui (count, count, 1);
|
|
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;
|
|
}
|
|
if (min_max_choose (a, extremum, sign, back_val) > 0)
|
|
mpz_set (result->value.integer, count);
|
|
}
|
|
mpz_clear (count);
|
|
gfc_free_expr (extremum);
|
|
return result;
|
|
}
|
|
|
|
/* Simplify minloc / maxloc in the absence of a dim argument. */
|
|
|
|
static gfc_expr *
|
|
simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
|
|
gfc_expr *array, gfc_expr *mask, int sign,
|
|
bool back_val)
|
|
{
|
|
ssize_t res[GFC_MAX_DIMENSIONS];
|
|
int i, n;
|
|
gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
|
|
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
|
|
sstride[GFC_MAX_DIMENSIONS];
|
|
gfc_expr *a, *m;
|
|
bool continue_loop;
|
|
bool ma;
|
|
|
|
for (i = 0; i<array->rank; i++)
|
|
res[i] = -1;
|
|
|
|
/* Shortcut for constant .FALSE. MASK. */
|
|
if (mask
|
|
&& mask->expr_type == EXPR_CONSTANT
|
|
&& !mask->value.logical)
|
|
goto finish;
|
|
|
|
if (array->shape == NULL)
|
|
goto finish;
|
|
|
|
for (i = 0; i < array->rank; i++)
|
|
{
|
|
count[i] = 0;
|
|
sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
|
|
extent[i] = mpz_get_si (array->shape[i]);
|
|
if (extent[i] <= 0)
|
|
goto finish;
|
|
}
|
|
|
|
continue_loop = true;
|
|
array_ctor = gfc_constructor_first (array->value.constructor);
|
|
if (mask && mask->rank > 0)
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
else
|
|
mask_ctor = NULL;
|
|
|
|
/* Loop over the array elements (and mask), keeping track of
|
|
the indices to return. */
|
|
while (continue_loop)
|
|
{
|
|
do
|
|
{
|
|
a = array_ctor->expr;
|
|
if (mask_ctor)
|
|
{
|
|
m = mask_ctor->expr;
|
|
ma = m->value.logical;
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
|
}
|
|
else
|
|
ma = true;
|
|
|
|
if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
|
|
{
|
|
for (i = 0; i<array->rank; i++)
|
|
res[i] = count[i];
|
|
}
|
|
array_ctor = gfc_constructor_next (array_ctor);
|
|
count[0] ++;
|
|
} while (count[0] != extent[0]);
|
|
n = 0;
|
|
do
|
|
{
|
|
/* When we get to the end of a dimension, reset it and increment
|
|
the next dimension. */
|
|
count[n] = 0;
|
|
n++;
|
|
if (n >= array->rank)
|
|
{
|
|
continue_loop = false;
|
|
break;
|
|
}
|
|
else
|
|
count[n] ++;
|
|
} while (count[n] == extent[n]);
|
|
}
|
|
|
|
finish:
|
|
gfc_free_expr (extremum);
|
|
result_ctor = gfc_constructor_first (result->value.constructor);
|
|
for (i = 0; i<array->rank; i++)
|
|
{
|
|
gfc_expr *r_expr;
|
|
r_expr = result_ctor->expr;
|
|
mpz_set_si (r_expr->value.integer, res[i] + 1);
|
|
result_ctor = gfc_constructor_next (result_ctor);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
/* Helper function for gfc_simplify_minmaxloc - build an array
|
|
expression with n elements. */
|
|
|
|
static gfc_expr *
|
|
new_array (bt type, int kind, int n, locus *where)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
|
|
result = gfc_get_array_expr (type, kind, where);
|
|
result->rank = 1;
|
|
result->shape = gfc_get_shape(1);
|
|
mpz_init_set_si (result->shape[0], n);
|
|
for (i = 0; i < n; i++)
|
|
{
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_get_constant_expr (type, kind, where),
|
|
NULL);
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
/* Simplify minloc and maxloc. This code is mostly identical to
|
|
simplify_transformation_to_array. */
|
|
|
|
static gfc_expr *
|
|
simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
|
|
gfc_expr *dim, gfc_expr *mask,
|
|
gfc_expr *extremum, int sign, bool back_val)
|
|
{
|
|
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)
|
|
{
|
|
gfc_expr *ex;
|
|
ex = gfc_copy_expr (extremum);
|
|
for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
|
|
{
|
|
if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
|
|
mpz_set_si ((*dest)->value.integer, n + 1);
|
|
}
|
|
|
|
count[0]++;
|
|
base += sstride[0];
|
|
dest += dstride[0];
|
|
gfc_free_expr (ex);
|
|
|
|
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);
|
|
free (extremum);
|
|
return result;
|
|
}
|
|
|
|
/* Simplify minloc and maxloc for constant arrays. */
|
|
|
|
static gfc_expr *
|
|
gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
|
|
gfc_expr *kind, gfc_expr *back, int sign)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_expr *extremum;
|
|
int ikind;
|
|
int init_val;
|
|
bool back_val = false;
|
|
|
|
if (!is_constant_array_expr (array)
|
|
|| !gfc_is_constant_expr (dim))
|
|
return NULL;
|
|
|
|
if (mask
|
|
&& !is_constant_array_expr (mask)
|
|
&& mask->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (kind)
|
|
{
|
|
if (gfc_extract_int (kind, &ikind, -1))
|
|
return NULL;
|
|
}
|
|
else
|
|
ikind = gfc_default_integer_kind;
|
|
|
|
if (back)
|
|
{
|
|
if (back->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
back_val = back->value.logical;
|
|
}
|
|
|
|
if (sign < 0)
|
|
init_val = INT_MAX;
|
|
else if (sign > 0)
|
|
init_val = INT_MIN;
|
|
else
|
|
gcc_unreachable();
|
|
|
|
extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
|
|
init_result_expr (extremum, init_val, array);
|
|
|
|
if (dim)
|
|
{
|
|
result = transformational_result (array, dim, BT_INTEGER,
|
|
ikind, &array->where);
|
|
init_result_expr (result, 0, array);
|
|
|
|
if (array->rank == 1)
|
|
return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
|
|
sign, back_val);
|
|
else
|
|
return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
|
|
sign, back_val);
|
|
}
|
|
else
|
|
{
|
|
result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
|
|
return simplify_minmaxloc_nodim (result, extremum, array, mask,
|
|
sign, back_val);
|
|
}
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
|
|
gfc_expr *back)
|
|
{
|
|
return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
|
|
gfc_expr *back)
|
|
{
|
|
return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
|
|
}
|
|
|
|
/* Simplify findloc to scalar. Similar to
|
|
simplify_minmaxloc_to_scalar. */
|
|
|
|
static gfc_expr *
|
|
simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
|
|
gfc_expr *mask, int back_val)
|
|
{
|
|
gfc_expr *a, *m;
|
|
gfc_constructor *array_ctor, *mask_ctor;
|
|
mpz_t count;
|
|
|
|
mpz_set_si (result->value.integer, 0);
|
|
|
|
/* 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);
|
|
if (mask && mask->expr_type == EXPR_ARRAY)
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
else
|
|
mask_ctor = NULL;
|
|
|
|
mpz_init_set_si (count, 0);
|
|
while (array_ctor)
|
|
{
|
|
mpz_add_ui (count, count, 1);
|
|
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;
|
|
}
|
|
if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
|
|
{
|
|
/* We have a match. If BACK is true, continue so we find
|
|
the last one. */
|
|
mpz_set (result->value.integer, count);
|
|
if (!back_val)
|
|
break;
|
|
}
|
|
}
|
|
mpz_clear (count);
|
|
return result;
|
|
}
|
|
|
|
/* Simplify findloc in the absence of a dim argument. Similar to
|
|
simplify_minmaxloc_nodim. */
|
|
|
|
static gfc_expr *
|
|
simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
|
|
gfc_expr *mask, bool back_val)
|
|
{
|
|
ssize_t res[GFC_MAX_DIMENSIONS];
|
|
int i, n;
|
|
gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
|
|
ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
|
|
sstride[GFC_MAX_DIMENSIONS];
|
|
gfc_expr *a, *m;
|
|
bool continue_loop;
|
|
bool ma;
|
|
|
|
for (i = 0; i < array->rank; i++)
|
|
res[i] = -1;
|
|
|
|
/* Shortcut for constant .FALSE. MASK. */
|
|
if (mask
|
|
&& mask->expr_type == EXPR_CONSTANT
|
|
&& !mask->value.logical)
|
|
goto finish;
|
|
|
|
for (i = 0; i < array->rank; i++)
|
|
{
|
|
count[i] = 0;
|
|
sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
|
|
extent[i] = mpz_get_si (array->shape[i]);
|
|
if (extent[i] <= 0)
|
|
goto finish;
|
|
}
|
|
|
|
continue_loop = true;
|
|
array_ctor = gfc_constructor_first (array->value.constructor);
|
|
if (mask && mask->rank > 0)
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
else
|
|
mask_ctor = NULL;
|
|
|
|
/* Loop over the array elements (and mask), keeping track of
|
|
the indices to return. */
|
|
while (continue_loop)
|
|
{
|
|
do
|
|
{
|
|
a = array_ctor->expr;
|
|
if (mask_ctor)
|
|
{
|
|
m = mask_ctor->expr;
|
|
ma = m->value.logical;
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
|
}
|
|
else
|
|
ma = true;
|
|
|
|
if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
|
|
{
|
|
for (i = 0; i < array->rank; i++)
|
|
res[i] = count[i];
|
|
if (!back_val)
|
|
goto finish;
|
|
}
|
|
array_ctor = gfc_constructor_next (array_ctor);
|
|
count[0] ++;
|
|
} while (count[0] != extent[0]);
|
|
n = 0;
|
|
do
|
|
{
|
|
/* When we get to the end of a dimension, reset it and increment
|
|
the next dimension. */
|
|
count[n] = 0;
|
|
n++;
|
|
if (n >= array->rank)
|
|
{
|
|
continue_loop = false;
|
|
break;
|
|
}
|
|
else
|
|
count[n] ++;
|
|
} while (count[n] == extent[n]);
|
|
}
|
|
|
|
finish:
|
|
result_ctor = gfc_constructor_first (result->value.constructor);
|
|
for (i = 0; i < array->rank; i++)
|
|
{
|
|
gfc_expr *r_expr;
|
|
r_expr = result_ctor->expr;
|
|
mpz_set_si (r_expr->value.integer, res[i] + 1);
|
|
result_ctor = gfc_constructor_next (result_ctor);
|
|
}
|
|
return result;
|
|
}
|
|
|
|
|
|
/* Simplify findloc to an array. Similar to
|
|
simplify_minmaxloc_to_array. */
|
|
|
|
static gfc_expr *
|
|
simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
|
|
gfc_expr *dim, gfc_expr *mask, bool back_val)
|
|
{
|
|
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 && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
|
|
{
|
|
mpz_set_si ((*dest)->value.integer, n + 1);
|
|
if (!back_val)
|
|
break;
|
|
}
|
|
}
|
|
|
|
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;
|
|
}
|
|
|
|
/* Simplify findloc. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
|
|
gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
|
|
{
|
|
gfc_expr *result;
|
|
int ikind;
|
|
bool back_val = false;
|
|
|
|
if (!is_constant_array_expr (array)
|
|
|| !gfc_is_constant_expr (dim))
|
|
return NULL;
|
|
|
|
if (! gfc_is_constant_expr (value))
|
|
return 0;
|
|
|
|
if (mask
|
|
&& !is_constant_array_expr (mask)
|
|
&& mask->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (kind)
|
|
{
|
|
if (gfc_extract_int (kind, &ikind, -1))
|
|
return NULL;
|
|
}
|
|
else
|
|
ikind = gfc_default_integer_kind;
|
|
|
|
if (back)
|
|
{
|
|
if (back->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
back_val = back->value.logical;
|
|
}
|
|
|
|
if (dim)
|
|
{
|
|
result = transformational_result (array, dim, BT_INTEGER,
|
|
ikind, &array->where);
|
|
init_result_expr (result, 0, array);
|
|
|
|
if (array->rank == 1)
|
|
return simplify_findloc_to_scalar (result, array, value, mask,
|
|
back_val);
|
|
else
|
|
return simplify_findloc_to_array (result, array, value, dim, mask,
|
|
back_val);
|
|
}
|
|
else
|
|
{
|
|
result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
|
|
return simplify_findloc_nodim (result, value, array, mask, back_val);
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_maxexponent (gfc_expr *x)
|
|
{
|
|
int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
|
|
gfc_real_kinds[i].max_exponent);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_minexponent (gfc_expr *x)
|
|
{
|
|
int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
|
|
gfc_real_kinds[i].min_exponent);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
|
|
{
|
|
gfc_expr *result;
|
|
int kind;
|
|
|
|
/* First check p. */
|
|
if (p->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
/* p shall not be 0. */
|
|
switch (p->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
if (mpz_cmp_ui (p->value.integer, 0) == 0)
|
|
{
|
|
gfc_error ("Argument %qs of MOD at %L shall not be zero",
|
|
"P", &p->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
break;
|
|
case BT_REAL:
|
|
if (mpfr_cmp_ui (p->value.real, 0) == 0)
|
|
{
|
|
gfc_error ("Argument %qs of MOD at %L shall not be zero",
|
|
"P", &p->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
break;
|
|
default:
|
|
gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
|
|
}
|
|
|
|
if (a->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
|
|
result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
|
|
|
|
if (a->ts.type == BT_INTEGER)
|
|
mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
|
|
else
|
|
{
|
|
gfc_set_model_kind (kind);
|
|
mpfr_fmod (result->value.real, a->value.real, p->value.real,
|
|
GFC_RND_MODE);
|
|
}
|
|
|
|
return range_check (result, "MOD");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
|
|
{
|
|
gfc_expr *result;
|
|
int kind;
|
|
|
|
/* First check p. */
|
|
if (p->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
/* p shall not be 0. */
|
|
switch (p->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
if (mpz_cmp_ui (p->value.integer, 0) == 0)
|
|
{
|
|
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
|
|
"P", &p->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
break;
|
|
case BT_REAL:
|
|
if (mpfr_cmp_ui (p->value.real, 0) == 0)
|
|
{
|
|
gfc_error ("Argument %qs of MODULO at %L shall not be zero",
|
|
"P", &p->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
break;
|
|
default:
|
|
gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
|
|
}
|
|
|
|
if (a->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
|
|
result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
|
|
|
|
if (a->ts.type == BT_INTEGER)
|
|
mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
|
|
else
|
|
{
|
|
gfc_set_model_kind (kind);
|
|
mpfr_fmod (result->value.real, a->value.real, p->value.real,
|
|
GFC_RND_MODE);
|
|
if (mpfr_cmp_ui (result->value.real, 0) != 0)
|
|
{
|
|
if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
|
|
mpfr_add (result->value.real, result->value.real, p->value.real,
|
|
GFC_RND_MODE);
|
|
}
|
|
else
|
|
mpfr_copysign (result->value.real, result->value.real,
|
|
p->value.real, GFC_RND_MODE);
|
|
}
|
|
|
|
return range_check (result, "MODULO");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
|
|
{
|
|
gfc_expr *result;
|
|
mpfr_exp_t emin, emax;
|
|
int kind;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_copy_expr (x);
|
|
|
|
/* Save current values of emin and emax. */
|
|
emin = mpfr_get_emin ();
|
|
emax = mpfr_get_emax ();
|
|
|
|
/* Set emin and emax for the current model number. */
|
|
kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
|
|
mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
|
|
mpfr_get_prec(result->value.real) + 1);
|
|
mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1);
|
|
mpfr_check_range (result->value.real, 0, MPFR_RNDU);
|
|
|
|
if (mpfr_sgn (s->value.real) > 0)
|
|
{
|
|
mpfr_nextabove (result->value.real);
|
|
mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
|
|
}
|
|
else
|
|
{
|
|
mpfr_nextbelow (result->value.real);
|
|
mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
|
|
}
|
|
|
|
mpfr_set_emin (emin);
|
|
mpfr_set_emax (emax);
|
|
|
|
/* Only NaN can occur. Do not use range check as it gives an
|
|
error for denormal numbers. */
|
|
if (mpfr_nan_p (result->value.real) && flag_range_check)
|
|
{
|
|
gfc_error ("Result of NEAREST is NaN at %L", &result->where);
|
|
gfc_free_expr (result);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
|
|
{
|
|
gfc_expr *itrunc, *result;
|
|
int kind;
|
|
|
|
kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
|
|
if (kind == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
itrunc = gfc_copy_expr (e);
|
|
mpfr_round (itrunc->value.real, e->value.real);
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
|
|
gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
|
|
|
|
gfc_free_expr (itrunc);
|
|
|
|
return range_check (result, name);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_new_line (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
|
|
result->value.character.string[0] = '\n';
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
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);
|
|
}
|
|
|
|
static int norm2_scale;
|
|
|
|
static gfc_expr *
|
|
norm2_add_squared (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
mpfr_t tmp;
|
|
|
|
gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_REAL
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
gfc_set_model_kind (result->ts.kind);
|
|
int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
|
|
mpfr_exp_t exp;
|
|
if (mpfr_regular_p (result->value.real))
|
|
{
|
|
exp = mpfr_get_exp (result->value.real);
|
|
/* If result is getting close to overflowing, scale down. */
|
|
if (exp >= gfc_real_kinds[index].max_exponent - 4
|
|
&& norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
|
|
{
|
|
norm2_scale += 2;
|
|
mpfr_div_ui (result->value.real, result->value.real, 16,
|
|
GFC_RND_MODE);
|
|
}
|
|
}
|
|
|
|
mpfr_init (tmp);
|
|
if (mpfr_regular_p (e->value.real))
|
|
{
|
|
exp = mpfr_get_exp (e->value.real);
|
|
/* If e**2 would overflow or close to overflowing, scale down. */
|
|
if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
|
|
{
|
|
int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
|
|
mpfr_set_ui (tmp, 1, GFC_RND_MODE);
|
|
mpfr_set_exp (tmp, new_scale - norm2_scale);
|
|
mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
|
|
mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
|
|
norm2_scale = new_scale;
|
|
}
|
|
}
|
|
if (norm2_scale)
|
|
{
|
|
mpfr_set_ui (tmp, 1, GFC_RND_MODE);
|
|
mpfr_set_exp (tmp, norm2_scale);
|
|
mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
|
|
}
|
|
else
|
|
mpfr_set (tmp, e->value.real, GFC_RND_MODE);
|
|
mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
|
|
mpfr_add (result->value.real, result->value.real, tmp,
|
|
GFC_RND_MODE);
|
|
mpfr_clear (tmp);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_REAL
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
if (result != e)
|
|
mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
|
|
mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
|
|
if (norm2_scale && mpfr_regular_p (result->value.real))
|
|
{
|
|
mpfr_t tmp;
|
|
mpfr_init (tmp);
|
|
mpfr_set_ui (tmp, 1, GFC_RND_MODE);
|
|
mpfr_set_exp (tmp, norm2_scale);
|
|
mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
|
|
mpfr_clear (tmp);
|
|
}
|
|
norm2_scale = 0;
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
|
|
{
|
|
gfc_expr *result;
|
|
bool size_zero;
|
|
|
|
size_zero = gfc_is_size_zero_array (e);
|
|
|
|
if (!(is_constant_array_expr (e) || size_zero)
|
|
|| (dim != NULL && !gfc_is_constant_expr (dim)))
|
|
return NULL;
|
|
|
|
result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
|
|
init_result_expr (result, 0, NULL);
|
|
|
|
if (size_zero)
|
|
return result;
|
|
|
|
norm2_scale = 0;
|
|
if (!dim || e->rank == 1)
|
|
{
|
|
result = simplify_transformation_to_scalar (result, e, NULL,
|
|
norm2_add_squared);
|
|
mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
|
|
if (norm2_scale && mpfr_regular_p (result->value.real))
|
|
{
|
|
mpfr_t tmp;
|
|
mpfr_init (tmp);
|
|
mpfr_set_ui (tmp, 1, GFC_RND_MODE);
|
|
mpfr_set_exp (tmp, norm2_scale);
|
|
mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
|
|
mpfr_clear (tmp);
|
|
}
|
|
norm2_scale = 0;
|
|
}
|
|
else
|
|
result = simplify_transformation_to_array (result, e, dim, NULL,
|
|
norm2_add_squared,
|
|
norm2_do_sqrt);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_not (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
mpz_com (result->value.integer, e->value.integer);
|
|
|
|
return range_check (result, "NOT");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_null (gfc_expr *mold)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (mold)
|
|
{
|
|
result = gfc_copy_expr (mold);
|
|
result->expr_type = EXPR_NULL;
|
|
}
|
|
else
|
|
result = gfc_get_null_expr (NULL);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (flag_coarray == GFC_FCOARRAY_NONE)
|
|
{
|
|
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (flag_coarray != GFC_FCOARRAY_SINGLE)
|
|
return NULL;
|
|
|
|
if (failed && failed->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
/* FIXME: gfc_current_locus is wrong. */
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&gfc_current_locus);
|
|
|
|
if (failed && failed->value.logical != 0)
|
|
mpz_set_si (result->value.integer, 0);
|
|
else
|
|
mpz_set_si (result->value.integer, 1);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
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;
|
|
|
|
switch (x->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
|
|
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
|
|
return range_check (result, "OR");
|
|
|
|
case BT_LOGICAL:
|
|
return gfc_get_logical_expr (kind, &x->where,
|
|
x->value.logical || y->value.logical);
|
|
default:
|
|
gcc_unreachable();
|
|
}
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
|
|
|
|
if (!is_constant_array_expr (array)
|
|
|| !is_constant_array_expr (vector)
|
|
|| (!gfc_is_constant_expr (mask)
|
|
&& !is_constant_array_expr (mask)))
|
|
return NULL;
|
|
|
|
result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
|
|
if (array->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = array->ts.u.derived;
|
|
|
|
array_ctor = gfc_constructor_first (array->value.constructor);
|
|
vector_ctor = vector
|
|
? gfc_constructor_first (vector->value.constructor)
|
|
: NULL;
|
|
|
|
if (mask->expr_type == EXPR_CONSTANT
|
|
&& mask->value.logical)
|
|
{
|
|
/* Copy all elements of ARRAY to RESULT. */
|
|
while (array_ctor)
|
|
{
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (array_ctor->expr),
|
|
NULL);
|
|
|
|
array_ctor = gfc_constructor_next (array_ctor);
|
|
vector_ctor = gfc_constructor_next (vector_ctor);
|
|
}
|
|
}
|
|
else if (mask->expr_type == EXPR_ARRAY)
|
|
{
|
|
/* Copy only those elements of ARRAY to RESULT whose
|
|
MASK equals .TRUE.. */
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
while (mask_ctor)
|
|
{
|
|
if (mask_ctor->expr->value.logical)
|
|
{
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (array_ctor->expr),
|
|
NULL);
|
|
vector_ctor = gfc_constructor_next (vector_ctor);
|
|
}
|
|
|
|
array_ctor = gfc_constructor_next (array_ctor);
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
|
}
|
|
}
|
|
|
|
/* Append any left-over elements from VECTOR to RESULT. */
|
|
while (vector_ctor)
|
|
{
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (vector_ctor->expr),
|
|
NULL);
|
|
vector_ctor = gfc_constructor_next (vector_ctor);
|
|
}
|
|
|
|
result->shape = gfc_get_shape (1);
|
|
gfc_array_size (result, &result->shape[0]);
|
|
|
|
if (array->ts.type == BT_CHARACTER)
|
|
result->ts.u.cl = array->ts.u.cl;
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
do_xor (gfc_expr *result, gfc_expr *e)
|
|
{
|
|
gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
|
|
gcc_assert (result->ts.type == BT_LOGICAL
|
|
&& result->expr_type == EXPR_CONSTANT);
|
|
|
|
result->value.logical = result->value.logical != e->value.logical;
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_is_contiguous (gfc_expr *array)
|
|
{
|
|
if (gfc_is_simply_contiguous (array, false, true))
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
|
|
|
|
if (gfc_is_not_contiguous (array))
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
|
|
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
|
|
{
|
|
return simplify_transformation (e, dim, NULL, 0, do_xor);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_popcnt (gfc_expr *e)
|
|
{
|
|
int res, k;
|
|
mpz_t x;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
|
|
/* Convert argument to unsigned, then count the '1' bits. */
|
|
mpz_init_set (x, e->value.integer);
|
|
convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
|
|
res = mpz_popcount (x);
|
|
mpz_clear (x);
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_poppar (gfc_expr *e)
|
|
{
|
|
gfc_expr *popcnt;
|
|
int i;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
popcnt = gfc_simplify_popcnt (e);
|
|
gcc_assert (popcnt);
|
|
|
|
bool fail = gfc_extract_int (popcnt, &i);
|
|
gcc_assert (!fail);
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_precision (gfc_expr *e)
|
|
{
|
|
int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
|
|
gfc_real_kinds[i].precision);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, 1, gfc_multiply);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_radix (gfc_expr *e)
|
|
{
|
|
int i;
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
i = gfc_integer_kinds[i].radix;
|
|
break;
|
|
|
|
case BT_REAL:
|
|
i = gfc_real_kinds[i].radix;
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_range (gfc_expr *e)
|
|
{
|
|
int i;
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
i = gfc_integer_kinds[i].range;
|
|
break;
|
|
|
|
case BT_REAL:
|
|
case BT_COMPLEX:
|
|
i = gfc_real_kinds[i].range;
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_rank (gfc_expr *e)
|
|
{
|
|
/* Assumed rank. */
|
|
if (e->rank == -1)
|
|
return NULL;
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
int kind, tmp1, tmp2;
|
|
|
|
/* Convert BOZ to real, and return without range checking. */
|
|
if (e->ts.type == BT_BOZ)
|
|
{
|
|
/* Determine kind for conversion of the BOZ. */
|
|
if (k)
|
|
gfc_extract_int (k, &kind);
|
|
else
|
|
kind = gfc_default_real_kind;
|
|
|
|
if (!gfc_boz2real (e, kind))
|
|
return NULL;
|
|
result = gfc_copy_expr (e);
|
|
return result;
|
|
}
|
|
|
|
if (e->ts.type == BT_COMPLEX)
|
|
kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
|
|
else
|
|
kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
|
|
|
|
if (kind == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
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, kind);
|
|
|
|
warn_conversion = tmp1;
|
|
warn_conversion_extra = tmp2;
|
|
|
|
if (result == &gfc_bad_expr)
|
|
return &gfc_bad_expr;
|
|
|
|
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_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, "REALPART");
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_charlen_t len;
|
|
mpz_t ncopies;
|
|
bool have_length = false;
|
|
|
|
/* If NCOPIES isn't a constant, there's nothing we can do. */
|
|
if (n->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
/* If NCOPIES is negative, it's an error. */
|
|
if (mpz_sgn (n->value.integer) < 0)
|
|
{
|
|
gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
|
|
&n->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
/* If we don't know the character length, we can do no more. */
|
|
if (e->ts.u.cl && e->ts.u.cl->length
|
|
&& e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
|
|
{
|
|
len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
|
|
have_length = true;
|
|
}
|
|
else if (e->expr_type == EXPR_CONSTANT
|
|
&& (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
|
|
{
|
|
len = e->value.character.length;
|
|
}
|
|
else
|
|
return NULL;
|
|
|
|
/* If the source length is 0, any value of NCOPIES is valid
|
|
and everything behaves as if NCOPIES == 0. */
|
|
mpz_init (ncopies);
|
|
if (len == 0)
|
|
mpz_set_ui (ncopies, 0);
|
|
else
|
|
mpz_set (ncopies, n->value.integer);
|
|
|
|
/* Check that NCOPIES isn't too large. */
|
|
if (len)
|
|
{
|
|
mpz_t max, mlen;
|
|
int i;
|
|
|
|
/* Compute the maximum value allowed for NCOPIES: huge(cl) / len. */
|
|
mpz_init (max);
|
|
i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
|
|
|
|
if (have_length)
|
|
{
|
|
mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
|
|
e->ts.u.cl->length->value.integer);
|
|
}
|
|
else
|
|
{
|
|
mpz_init (mlen);
|
|
gfc_mpz_set_hwi (mlen, len);
|
|
mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
|
|
mpz_clear (mlen);
|
|
}
|
|
|
|
/* The check itself. */
|
|
if (mpz_cmp (ncopies, max) > 0)
|
|
{
|
|
mpz_clear (max);
|
|
mpz_clear (ncopies);
|
|
gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
|
|
&n->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
mpz_clear (max);
|
|
}
|
|
mpz_clear (ncopies);
|
|
|
|
/* For further simplification, we need the character string to be
|
|
constant. */
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
HOST_WIDE_INT ncop;
|
|
if (len ||
|
|
(e->ts.u.cl->length &&
|
|
mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
|
|
{
|
|
bool fail = gfc_extract_hwi (n, &ncop);
|
|
gcc_assert (!fail);
|
|
}
|
|
else
|
|
ncop = 0;
|
|
|
|
if (ncop == 0)
|
|
return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
|
|
|
|
len = e->value.character.length;
|
|
gfc_charlen_t nlen = ncop * len;
|
|
|
|
/* Here's a semi-arbitrary limit. If the string is longer than 1 GB
|
|
(2**28 elements * 4 bytes (wide chars) per element) defer to
|
|
runtime instead of consuming (unbounded) memory and CPU at
|
|
compile time. */
|
|
if (nlen > 268435456)
|
|
{
|
|
gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
|
|
" deferred to runtime, expect bugs", &e->where);
|
|
return NULL;
|
|
}
|
|
|
|
result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
|
|
for (size_t i = 0; i < (size_t) ncop; i++)
|
|
for (size_t j = 0; j < (size_t) len; j++)
|
|
result->value.character.string[j+i*len]= e->value.character.string[j];
|
|
|
|
result->value.character.string[nlen] = '\0'; /* For debugger */
|
|
return result;
|
|
}
|
|
|
|
|
|
/* This one is a bear, but mainly has to do with shuffling elements. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
|
|
gfc_expr *pad, gfc_expr *order_exp)
|
|
{
|
|
int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
|
|
int i, rank, npad, x[GFC_MAX_DIMENSIONS];
|
|
mpz_t index, size;
|
|
unsigned long j;
|
|
size_t nsource;
|
|
gfc_expr *e, *result;
|
|
bool zerosize = false;
|
|
|
|
/* Check that argument expression types are OK. */
|
|
if (!is_constant_array_expr (source)
|
|
|| !is_constant_array_expr (shape_exp)
|
|
|| !is_constant_array_expr (pad)
|
|
|| !is_constant_array_expr (order_exp))
|
|
return NULL;
|
|
|
|
if (source->shape == NULL)
|
|
return NULL;
|
|
|
|
/* Proceed with simplification, unpacking the array. */
|
|
|
|
mpz_init (index);
|
|
rank = 0;
|
|
|
|
for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
|
|
x[i] = 0;
|
|
|
|
for (;;)
|
|
{
|
|
e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
|
|
if (e == NULL)
|
|
break;
|
|
|
|
gfc_extract_int (e, &shape[rank]);
|
|
|
|
gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
|
|
if (shape[rank] < 0)
|
|
{
|
|
gfc_error ("The SHAPE array for the RESHAPE intrinsic at %L has a "
|
|
"negative value %d for dimension %d",
|
|
&shape_exp->where, shape[rank], rank+1);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
rank++;
|
|
}
|
|
|
|
gcc_assert (rank > 0);
|
|
|
|
/* Now unpack the order array if present. */
|
|
if (order_exp == NULL)
|
|
{
|
|
for (i = 0; i < rank; i++)
|
|
order[i] = i;
|
|
}
|
|
else
|
|
{
|
|
mpz_t size;
|
|
int order_size, shape_size;
|
|
|
|
if (order_exp->rank != shape_exp->rank)
|
|
{
|
|
gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
|
|
&order_exp->where, &shape_exp->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
gfc_array_size (shape_exp, &size);
|
|
shape_size = mpz_get_ui (size);
|
|
mpz_clear (size);
|
|
gfc_array_size (order_exp, &size);
|
|
order_size = mpz_get_ui (size);
|
|
mpz_clear (size);
|
|
if (order_size != shape_size)
|
|
{
|
|
gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
|
|
&order_exp->where, &shape_exp->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
for (i = 0; i < rank; i++)
|
|
{
|
|
e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
|
|
gcc_assert (e);
|
|
|
|
gfc_extract_int (e, &order[i]);
|
|
|
|
if (order[i] < 1 || order[i] > rank)
|
|
{
|
|
gfc_error ("Element with a value of %d in ORDER at %L must be "
|
|
"in the range [1, ..., %d] for the RESHAPE intrinsic "
|
|
"near %L", order[i], &order_exp->where, rank,
|
|
&shape_exp->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
order[i]--;
|
|
if (x[order[i]] != 0)
|
|
{
|
|
gfc_error ("ORDER at %L is not a permutation of the size of "
|
|
"SHAPE at %L", &order_exp->where, &shape_exp->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
x[order[i]] = 1;
|
|
}
|
|
}
|
|
|
|
/* Count the elements in the source and padding arrays. */
|
|
|
|
npad = 0;
|
|
if (pad != NULL)
|
|
{
|
|
gfc_array_size (pad, &size);
|
|
npad = mpz_get_ui (size);
|
|
mpz_clear (size);
|
|
}
|
|
|
|
gfc_array_size (source, &size);
|
|
nsource = mpz_get_ui (size);
|
|
mpz_clear (size);
|
|
|
|
/* If it weren't for that pesky permutation we could just loop
|
|
through the source and round out any shortage with pad elements.
|
|
But no, someone just had to have the compiler do something the
|
|
user should be doing. */
|
|
|
|
for (i = 0; i < rank; i++)
|
|
x[i] = 0;
|
|
|
|
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
|
|
&source->where);
|
|
if (source->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = source->ts.u.derived;
|
|
if (source->ts.type == BT_CHARACTER && result->ts.u.cl == NULL)
|
|
result->ts = source->ts;
|
|
result->rank = rank;
|
|
result->shape = gfc_get_shape (rank);
|
|
for (i = 0; i < rank; i++)
|
|
{
|
|
mpz_init_set_ui (result->shape[i], shape[i]);
|
|
if (shape[i] == 0)
|
|
zerosize = true;
|
|
}
|
|
|
|
if (zerosize)
|
|
goto sizezero;
|
|
|
|
while (nsource > 0 || npad > 0)
|
|
{
|
|
/* Figure out which element to extract. */
|
|
mpz_set_ui (index, 0);
|
|
|
|
for (i = rank - 1; i >= 0; i--)
|
|
{
|
|
mpz_add_ui (index, index, x[order[i]]);
|
|
if (i != 0)
|
|
mpz_mul_ui (index, index, shape[order[i - 1]]);
|
|
}
|
|
|
|
if (mpz_cmp_ui (index, INT_MAX) > 0)
|
|
gfc_internal_error ("Reshaped array too large at %C");
|
|
|
|
j = mpz_get_ui (index);
|
|
|
|
if (j < nsource)
|
|
e = gfc_constructor_lookup_expr (source->value.constructor, j);
|
|
else
|
|
{
|
|
if (npad <= 0)
|
|
{
|
|
mpz_clear (index);
|
|
return NULL;
|
|
}
|
|
j = j - nsource;
|
|
j = j % npad;
|
|
e = gfc_constructor_lookup_expr (pad->value.constructor, j);
|
|
}
|
|
gcc_assert (e);
|
|
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (e), &e->where);
|
|
|
|
/* Calculate the next element. */
|
|
i = 0;
|
|
|
|
inc:
|
|
if (++x[i] < shape[i])
|
|
continue;
|
|
x[i++] = 0;
|
|
if (i < rank)
|
|
goto inc;
|
|
|
|
break;
|
|
}
|
|
|
|
sizezero:
|
|
|
|
mpz_clear (index);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_rrspacing (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
long int e, p;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
|
|
|
|
/* RRSPACING(+/- 0.0) = 0.0 */
|
|
if (mpfr_zero_p (x->value.real))
|
|
{
|
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
/* RRSPACING(inf) = NaN */
|
|
if (mpfr_inf_p (x->value.real))
|
|
{
|
|
mpfr_set_nan (result->value.real);
|
|
return result;
|
|
}
|
|
|
|
/* RRSPACING(NaN) = same NaN */
|
|
if (mpfr_nan_p (x->value.real))
|
|
{
|
|
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
/* | x * 2**(-e) | * 2**p. */
|
|
mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
|
|
e = - (long int) mpfr_get_exp (x->value.real);
|
|
mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
|
|
|
|
p = (long int) gfc_real_kinds[i].digits;
|
|
mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
|
|
|
|
return range_check (result, "RRSPACING");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
|
|
{
|
|
int k, neg_flag, power, exp_range;
|
|
mpfr_t scale, radix;
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
|
|
|
|
if (mpfr_zero_p (x->value.real))
|
|
{
|
|
mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
|
|
|
|
exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
|
|
|
|
/* This check filters out values of i that would overflow an int. */
|
|
if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
|
|
|| mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
|
|
{
|
|
gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
|
|
gfc_free_expr (result);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
/* Compute scale = radix ** power. */
|
|
power = mpz_get_si (i->value.integer);
|
|
|
|
if (power >= 0)
|
|
neg_flag = 0;
|
|
else
|
|
{
|
|
neg_flag = 1;
|
|
power = -power;
|
|
}
|
|
|
|
gfc_set_model_kind (x->ts.kind);
|
|
mpfr_init (scale);
|
|
mpfr_init (radix);
|
|
mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
|
|
mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
|
|
|
|
if (neg_flag)
|
|
mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
|
|
else
|
|
mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
|
|
|
|
mpfr_clears (scale, radix, NULL);
|
|
|
|
return range_check (result, "SCALE");
|
|
}
|
|
|
|
|
|
/* Variants of strspn and strcspn that operate on wide characters. */
|
|
|
|
static size_t
|
|
wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
|
|
{
|
|
size_t i = 0;
|
|
const gfc_char_t *c;
|
|
|
|
while (s1[i])
|
|
{
|
|
for (c = s2; *c; c++)
|
|
{
|
|
if (s1[i] == *c)
|
|
break;
|
|
}
|
|
if (*c == '\0')
|
|
break;
|
|
i++;
|
|
}
|
|
|
|
return i;
|
|
}
|
|
|
|
static size_t
|
|
wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
|
|
{
|
|
size_t i = 0;
|
|
const gfc_char_t *c;
|
|
|
|
while (s1[i])
|
|
{
|
|
for (c = s2; *c; c++)
|
|
{
|
|
if (s1[i] == *c)
|
|
break;
|
|
}
|
|
if (*c)
|
|
break;
|
|
i++;
|
|
}
|
|
|
|
return i;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
int back;
|
|
size_t i;
|
|
size_t indx, len, lenc;
|
|
int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
|
|
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
|
|
|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
|
|
return NULL;
|
|
|
|
if (b != NULL && b->value.logical != 0)
|
|
back = 1;
|
|
else
|
|
back = 0;
|
|
|
|
len = e->value.character.length;
|
|
lenc = c->value.character.length;
|
|
|
|
if (len == 0 || lenc == 0)
|
|
{
|
|
indx = 0;
|
|
}
|
|
else
|
|
{
|
|
if (back == 0)
|
|
{
|
|
indx = wide_strcspn (e->value.character.string,
|
|
c->value.character.string) + 1;
|
|
if (indx > len)
|
|
indx = 0;
|
|
}
|
|
else
|
|
for (indx = len; indx > 0; indx--)
|
|
{
|
|
for (i = 0; i < lenc; i++)
|
|
{
|
|
if (c->value.character.string[i]
|
|
== e->value.character.string[indx - 1])
|
|
break;
|
|
}
|
|
if (i < lenc)
|
|
break;
|
|
}
|
|
}
|
|
|
|
result = gfc_get_int_expr (k, &e->where, indx);
|
|
return range_check (result, "SCAN");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_selected_char_kind (gfc_expr *e)
|
|
{
|
|
int kind;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
if (gfc_compare_with_Cstring (e, "ascii", false) == 0
|
|
|| gfc_compare_with_Cstring (e, "default", false) == 0)
|
|
kind = 1;
|
|
else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
|
|
kind = 4;
|
|
else
|
|
kind = -1;
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_selected_int_kind (gfc_expr *e)
|
|
{
|
|
int i, kind, range;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
|
|
return NULL;
|
|
|
|
kind = INT_MAX;
|
|
|
|
for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
|
|
if (gfc_integer_kinds[i].range >= range
|
|
&& gfc_integer_kinds[i].kind < kind)
|
|
kind = gfc_integer_kinds[i].kind;
|
|
|
|
if (kind == INT_MAX)
|
|
kind = -1;
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
|
|
{
|
|
int range, precision, radix, i, kind, found_precision, found_range,
|
|
found_radix;
|
|
locus *loc = &gfc_current_locus;
|
|
|
|
if (p == NULL)
|
|
precision = 0;
|
|
else
|
|
{
|
|
if (p->expr_type != EXPR_CONSTANT
|
|
|| gfc_extract_int (p, &precision))
|
|
return NULL;
|
|
loc = &p->where;
|
|
}
|
|
|
|
if (q == NULL)
|
|
range = 0;
|
|
else
|
|
{
|
|
if (q->expr_type != EXPR_CONSTANT
|
|
|| gfc_extract_int (q, &range))
|
|
return NULL;
|
|
|
|
if (!loc)
|
|
loc = &q->where;
|
|
}
|
|
|
|
if (rdx == NULL)
|
|
radix = 0;
|
|
else
|
|
{
|
|
if (rdx->expr_type != EXPR_CONSTANT
|
|
|| gfc_extract_int (rdx, &radix))
|
|
return NULL;
|
|
|
|
if (!loc)
|
|
loc = &rdx->where;
|
|
}
|
|
|
|
kind = INT_MAX;
|
|
found_precision = 0;
|
|
found_range = 0;
|
|
found_radix = 0;
|
|
|
|
for (i = 0; gfc_real_kinds[i].kind != 0; i++)
|
|
{
|
|
if (gfc_real_kinds[i].precision >= precision)
|
|
found_precision = 1;
|
|
|
|
if (gfc_real_kinds[i].range >= range)
|
|
found_range = 1;
|
|
|
|
if (radix == 0 || gfc_real_kinds[i].radix == radix)
|
|
found_radix = 1;
|
|
|
|
if (gfc_real_kinds[i].precision >= precision
|
|
&& gfc_real_kinds[i].range >= range
|
|
&& (radix == 0 || gfc_real_kinds[i].radix == radix)
|
|
&& gfc_real_kinds[i].kind < kind)
|
|
kind = gfc_real_kinds[i].kind;
|
|
}
|
|
|
|
if (kind == INT_MAX)
|
|
{
|
|
if (found_radix && found_range && !found_precision)
|
|
kind = -1;
|
|
else if (found_radix && found_precision && !found_range)
|
|
kind = -2;
|
|
else if (found_radix && !found_precision && !found_range)
|
|
kind = -3;
|
|
else if (found_radix)
|
|
kind = -4;
|
|
else
|
|
kind = -5;
|
|
}
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
|
|
{
|
|
gfc_expr *result;
|
|
mpfr_t exp, absv, log2, pow2, frac;
|
|
unsigned long exp2;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
|
|
|
|
/* SET_EXPONENT (+/-0.0, I) = +/- 0.0
|
|
SET_EXPONENT (NaN) = same NaN */
|
|
if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
|
|
{
|
|
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
/* SET_EXPONENT (inf) = NaN */
|
|
if (mpfr_inf_p (x->value.real))
|
|
{
|
|
mpfr_set_nan (result->value.real);
|
|
return result;
|
|
}
|
|
|
|
gfc_set_model_kind (x->ts.kind);
|
|
mpfr_init (absv);
|
|
mpfr_init (log2);
|
|
mpfr_init (exp);
|
|
mpfr_init (pow2);
|
|
mpfr_init (frac);
|
|
|
|
mpfr_abs (absv, x->value.real, GFC_RND_MODE);
|
|
mpfr_log2 (log2, absv, GFC_RND_MODE);
|
|
|
|
mpfr_trunc (log2, log2);
|
|
mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
|
|
|
|
/* Old exponent value, and fraction. */
|
|
mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
|
|
|
|
mpfr_div (frac, absv, pow2, GFC_RND_MODE);
|
|
|
|
/* New exponent. */
|
|
exp2 = (unsigned long) mpz_get_d (i->value.integer);
|
|
mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
|
|
|
|
mpfr_clears (absv, log2, pow2, frac, NULL);
|
|
|
|
return range_check (result, "SET_EXPONENT");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
|
|
{
|
|
mpz_t shape[GFC_MAX_DIMENSIONS];
|
|
gfc_expr *result, *e, *f;
|
|
gfc_array_ref *ar;
|
|
int n;
|
|
bool t;
|
|
int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
|
|
|
|
if (source->rank == -1)
|
|
return NULL;
|
|
|
|
result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
|
|
result->shape = gfc_get_shape (1);
|
|
mpz_init (result->shape[0]);
|
|
|
|
if (source->rank == 0)
|
|
return result;
|
|
|
|
if (source->expr_type == EXPR_VARIABLE)
|
|
{
|
|
ar = gfc_find_array_ref (source);
|
|
t = gfc_array_ref_shape (ar, shape);
|
|
}
|
|
else if (source->shape)
|
|
{
|
|
t = true;
|
|
for (n = 0; n < source->rank; n++)
|
|
{
|
|
mpz_init (shape[n]);
|
|
mpz_set (shape[n], source->shape[n]);
|
|
}
|
|
}
|
|
else
|
|
t = false;
|
|
|
|
for (n = 0; n < source->rank; n++)
|
|
{
|
|
e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
|
|
|
|
if (t)
|
|
mpz_set (e->value.integer, shape[n]);
|
|
else
|
|
{
|
|
mpz_set_ui (e->value.integer, n + 1);
|
|
|
|
f = simplify_size (source, e, k);
|
|
gfc_free_expr (e);
|
|
if (f == NULL)
|
|
{
|
|
gfc_free_expr (result);
|
|
return NULL;
|
|
}
|
|
else
|
|
e = f;
|
|
}
|
|
|
|
if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
|
|
{
|
|
gfc_free_expr (result);
|
|
if (t)
|
|
gfc_clear_shape (shape, source->rank);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
gfc_constructor_append_expr (&result->value.constructor, e, NULL);
|
|
}
|
|
|
|
if (t)
|
|
gfc_clear_shape (shape, source->rank);
|
|
|
|
mpz_set_si (result->shape[0], source->rank);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
static gfc_expr *
|
|
simplify_size (gfc_expr *array, gfc_expr *dim, int k)
|
|
{
|
|
mpz_t size;
|
|
gfc_expr *return_value;
|
|
int d;
|
|
gfc_ref *ref;
|
|
|
|
/* For unary operations, the size of the result is given by the size
|
|
of the operand. For binary ones, it's the size of the first operand
|
|
unless it is scalar, then it is the size of the second. */
|
|
if (array->expr_type == EXPR_OP && !array->value.op.uop)
|
|
{
|
|
gfc_expr* replacement;
|
|
gfc_expr* simplified;
|
|
|
|
switch (array->value.op.op)
|
|
{
|
|
/* Unary operations. */
|
|
case INTRINSIC_NOT:
|
|
case INTRINSIC_UPLUS:
|
|
case INTRINSIC_UMINUS:
|
|
case INTRINSIC_PARENTHESES:
|
|
replacement = array->value.op.op1;
|
|
break;
|
|
|
|
/* Binary operations. If any one of the operands is scalar, take
|
|
the other one's size. If both of them are arrays, it does not
|
|
matter -- try to find one with known shape, if possible. */
|
|
default:
|
|
if (array->value.op.op1->rank == 0)
|
|
replacement = array->value.op.op2;
|
|
else if (array->value.op.op2->rank == 0)
|
|
replacement = array->value.op.op1;
|
|
else
|
|
{
|
|
simplified = simplify_size (array->value.op.op1, dim, k);
|
|
if (simplified)
|
|
return simplified;
|
|
|
|
replacement = array->value.op.op2;
|
|
}
|
|
break;
|
|
}
|
|
|
|
/* Try to reduce it directly if possible. */
|
|
simplified = simplify_size (replacement, dim, k);
|
|
|
|
/* Otherwise, we build a new SIZE call. This is hopefully at least
|
|
simpler than the original one. */
|
|
if (!simplified)
|
|
{
|
|
gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
|
|
simplified = gfc_build_intrinsic_call (gfc_current_ns,
|
|
GFC_ISYM_SIZE, "size",
|
|
array->where, 3,
|
|
gfc_copy_expr (replacement),
|
|
gfc_copy_expr (dim),
|
|
kind);
|
|
}
|
|
return simplified;
|
|
}
|
|
|
|
for (ref = array->ref; ref; ref = ref->next)
|
|
if (ref->type == REF_ARRAY && ref->u.ar.as)
|
|
gfc_resolve_array_spec (ref->u.ar.as, 0);
|
|
|
|
if (dim == NULL)
|
|
{
|
|
if (!gfc_array_size (array, &size))
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
if (dim->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
d = mpz_get_ui (dim->value.integer) - 1;
|
|
if (!gfc_array_dimen_size (array, d, &size))
|
|
return NULL;
|
|
}
|
|
|
|
return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
|
|
mpz_set (return_value->value.integer, size);
|
|
mpz_clear (size);
|
|
|
|
return return_value;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
|
|
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = simplify_size (array, dim, k);
|
|
if (result == NULL || result == &gfc_bad_expr)
|
|
return result;
|
|
|
|
return range_check (result, "SIZE");
|
|
}
|
|
|
|
|
|
/* SIZEOF and C_SIZEOF return the size in bytes of an array element
|
|
multiplied by the array size. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sizeof (gfc_expr *x)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
mpz_t array_size;
|
|
size_t res_size;
|
|
|
|
if (x->ts.type == BT_CLASS || x->ts.deferred)
|
|
return NULL;
|
|
|
|
if (x->ts.type == BT_CHARACTER
|
|
&& (!x->ts.u.cl || !x->ts.u.cl->length
|
|
|| x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
|
|
return NULL;
|
|
|
|
if (x->rank && x->expr_type != EXPR_ARRAY
|
|
&& !gfc_array_size (x, &array_size))
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
|
|
&x->where);
|
|
gfc_target_expr_size (x, &res_size);
|
|
mpz_set_si (result->value.integer, res_size);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
/* STORAGE_SIZE returns the size in bits of a single array element. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_storage_size (gfc_expr *x,
|
|
gfc_expr *kind)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
int k;
|
|
size_t siz;
|
|
|
|
if (x->ts.type == BT_CLASS || x->ts.deferred)
|
|
return NULL;
|
|
|
|
if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
|
|
&& (!x->ts.u.cl || !x->ts.u.cl->length
|
|
|| x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
|
|
return NULL;
|
|
|
|
k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
|
|
|
|
gfc_element_size (x, &siz);
|
|
mpz_set_si (result->value.integer, siz);
|
|
mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
|
|
|
|
return range_check (result, "STORAGE_SIZE");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
|
|
{
|
|
gfc_expr *result;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT || y->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_INTEGER:
|
|
mpz_abs (result->value.integer, x->value.integer);
|
|
if (mpz_sgn (y->value.integer) < 0)
|
|
mpz_neg (result->value.integer, result->value.integer);
|
|
break;
|
|
|
|
case BT_REAL:
|
|
if (flag_sign_zero)
|
|
mpfr_copysign (result->value.real, x->value.real, y->value.real,
|
|
GFC_RND_MODE);
|
|
else
|
|
mpfr_setsign (result->value.real, x->value.real,
|
|
mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("Bad type in gfc_simplify_sign");
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sin (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_sin (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
gfc_set_model (x->value.real);
|
|
mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("in gfc_simplify_sin(): Bad type");
|
|
}
|
|
|
|
return range_check (result, "SIN");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sinh (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_sinh (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return range_check (result, "SINH");
|
|
}
|
|
|
|
|
|
/* The argument is always a double precision real that is converted to
|
|
single precision. TODO: Rounding! */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sngl (gfc_expr *a)
|
|
{
|
|
gfc_expr *result;
|
|
int tmp1, tmp2;
|
|
|
|
if (a->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_real2real (a, gfc_default_real_kind);
|
|
|
|
warn_conversion = tmp1;
|
|
warn_conversion_extra = tmp2;
|
|
|
|
return range_check (result, "SNGL");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_spacing (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
long int en, ep;
|
|
|
|
if (x->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
|
|
result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
|
|
|
|
/* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0) */
|
|
if (mpfr_zero_p (x->value.real))
|
|
{
|
|
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
/* SPACING(inf) = NaN */
|
|
if (mpfr_inf_p (x->value.real))
|
|
{
|
|
mpfr_set_nan (result->value.real);
|
|
return result;
|
|
}
|
|
|
|
/* SPACING(NaN) = same NaN */
|
|
if (mpfr_nan_p (x->value.real))
|
|
{
|
|
mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
|
|
return result;
|
|
}
|
|
|
|
/* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
|
|
are the radix, exponent of x, and precision. This excludes the
|
|
possibility of subnormal numbers. Fortran 2003 states the result is
|
|
b**max(e - p, emin - 1). */
|
|
|
|
ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
|
|
en = (long int) gfc_real_kinds[i].min_exponent - 1;
|
|
en = en > ep ? en : ep;
|
|
|
|
mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
|
|
mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
|
|
|
|
return range_check (result, "SPACING");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
int nelem, i, j, dim, ncopies;
|
|
mpz_t size;
|
|
|
|
if ((!gfc_is_constant_expr (source)
|
|
&& !is_constant_array_expr (source))
|
|
|| !gfc_is_constant_expr (dim_expr)
|
|
|| !gfc_is_constant_expr (ncopies_expr))
|
|
return NULL;
|
|
|
|
gcc_assert (dim_expr->ts.type == BT_INTEGER);
|
|
gfc_extract_int (dim_expr, &dim);
|
|
dim -= 1; /* zero-base DIM */
|
|
|
|
gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
|
|
gfc_extract_int (ncopies_expr, &ncopies);
|
|
ncopies = MAX (ncopies, 0);
|
|
|
|
/* Do not allow the array size to exceed the limit for an array
|
|
constructor. */
|
|
if (source->expr_type == EXPR_ARRAY)
|
|
{
|
|
if (!gfc_array_size (source, &size))
|
|
gfc_internal_error ("Failure getting length of a constant array.");
|
|
}
|
|
else
|
|
mpz_init_set_ui (size, 1);
|
|
|
|
nelem = mpz_get_si (size) * ncopies;
|
|
if (nelem > flag_max_array_constructor)
|
|
{
|
|
if (gfc_init_expr_flag)
|
|
{
|
|
gfc_error ("The number of elements (%d) in the array constructor "
|
|
"at %L requires an increase of the allowed %d upper "
|
|
"limit. See %<-fmax-array-constructor%> option.",
|
|
nelem, &source->where, flag_max_array_constructor);
|
|
return &gfc_bad_expr;
|
|
}
|
|
else
|
|
return NULL;
|
|
}
|
|
|
|
if (source->expr_type == EXPR_CONSTANT
|
|
|| source->expr_type == EXPR_STRUCTURE)
|
|
{
|
|
gcc_assert (dim == 0);
|
|
|
|
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
|
|
&source->where);
|
|
if (source->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = source->ts.u.derived;
|
|
result->rank = 1;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
mpz_init_set_si (result->shape[0], ncopies);
|
|
|
|
for (i = 0; i < ncopies; ++i)
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
gfc_copy_expr (source), NULL);
|
|
}
|
|
else if (source->expr_type == EXPR_ARRAY)
|
|
{
|
|
int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
|
|
gfc_constructor *source_ctor;
|
|
|
|
gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
|
|
gcc_assert (dim >= 0 && dim <= source->rank);
|
|
|
|
result = gfc_get_array_expr (source->ts.type, source->ts.kind,
|
|
&source->where);
|
|
if (source->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = source->ts.u.derived;
|
|
result->rank = source->rank + 1;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
|
|
for (i = 0, j = 0; i < result->rank; ++i)
|
|
{
|
|
if (i != dim)
|
|
mpz_init_set (result->shape[i], source->shape[j++]);
|
|
else
|
|
mpz_init_set_si (result->shape[i], ncopies);
|
|
|
|
extent[i] = mpz_get_si (result->shape[i]);
|
|
rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
|
|
}
|
|
|
|
offset = 0;
|
|
for (source_ctor = gfc_constructor_first (source->value.constructor);
|
|
source_ctor; source_ctor = gfc_constructor_next (source_ctor))
|
|
{
|
|
for (i = 0; i < ncopies; ++i)
|
|
gfc_constructor_insert_expr (&result->value.constructor,
|
|
gfc_copy_expr (source_ctor->expr),
|
|
NULL, offset + i * rstride[dim]);
|
|
|
|
offset += (dim == 0 ? ncopies : 1);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
gfc_error ("Simplification of SPREAD at %C not yet implemented");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (source->ts.type == BT_CHARACTER)
|
|
result->ts.u.cl = source->ts.u.cl;
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sqrt (gfc_expr *e)
|
|
{
|
|
gfc_expr *result = NULL;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_REAL:
|
|
if (mpfr_cmp_si (e->value.real, 0) < 0)
|
|
{
|
|
gfc_error ("Argument of SQRT at %L has a negative value",
|
|
&e->where);
|
|
return &gfc_bad_expr;
|
|
}
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
gfc_set_model (e->value.real);
|
|
|
|
result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
|
|
mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
|
|
}
|
|
|
|
return range_check (result, "SQRT");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
|
|
{
|
|
return simplify_transformation (array, dim, mask, 0, gfc_add);
|
|
}
|
|
|
|
|
|
/* Simplify COTAN(X) where X has the unit of radian. */
|
|
|
|
gfc_expr *
|
|
gfc_simplify_cotan (gfc_expr *x)
|
|
{
|
|
gfc_expr *result;
|
|
mpc_t swp, *val;
|
|
|
|
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_cot (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
/* There is no builtin mpc_cot, so compute cot = cos / sin. */
|
|
val = &result->value.complex;
|
|
mpc_init2 (swp, mpfr_get_default_prec ());
|
|
mpc_sin_cos (*val, swp, x->value.complex, GFC_MPC_RND_MODE,
|
|
GFC_MPC_RND_MODE);
|
|
mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
|
|
mpc_clear (swp);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return range_check (result, "COTAN");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_tan (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_tan (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return range_check (result, "TAN");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_tanh (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_tanh (result->value.real, x->value.real, GFC_RND_MODE);
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
|
|
break;
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
|
|
return range_check (result, "TANH");
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_tiny (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
|
|
i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
|
|
|
|
result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
|
|
mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_trailz (gfc_expr *e)
|
|
{
|
|
unsigned long tz, bs;
|
|
int i;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
|
|
bs = gfc_integer_kinds[i].bit_size;
|
|
tz = mpz_scan1 (e->value.integer, 0);
|
|
|
|
return gfc_get_int_expr (gfc_default_integer_kind,
|
|
&e->where, MIN (tz, bs));
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_expr *mold_element;
|
|
size_t source_size;
|
|
size_t result_size;
|
|
size_t buffer_size;
|
|
mpz_t tmp;
|
|
unsigned char *buffer;
|
|
size_t result_length;
|
|
|
|
if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
|
|
return NULL;
|
|
|
|
if (!gfc_resolve_expr (mold))
|
|
return NULL;
|
|
if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
|
|
return NULL;
|
|
|
|
if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
|
|
&result_size, &result_length))
|
|
return NULL;
|
|
|
|
/* Calculate the size of the source. */
|
|
if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
|
|
gfc_internal_error ("Failure getting length of a constant array.");
|
|
|
|
/* Create an empty new expression with the appropriate characteristics. */
|
|
result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
|
|
&source->where);
|
|
result->ts = mold->ts;
|
|
|
|
mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
|
|
? gfc_constructor_first (mold->value.constructor)->expr
|
|
: mold;
|
|
|
|
/* Set result character length, if needed. Note that this needs to be
|
|
set even for array expressions, in order to pass this information into
|
|
gfc_target_interpret_expr. */
|
|
if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
|
|
{
|
|
result->value.character.length = mold_element->value.character.length;
|
|
|
|
/* Let the typespec of the result inherit the string length.
|
|
This is crucial if a resulting array has size zero. */
|
|
if (mold_element->ts.u.cl->length)
|
|
result->ts.u.cl->length = gfc_copy_expr (mold_element->ts.u.cl->length);
|
|
else
|
|
result->ts.u.cl->length =
|
|
gfc_get_int_expr (gfc_charlen_int_kind, NULL,
|
|
mold_element->value.character.length);
|
|
}
|
|
|
|
/* Set the number of elements in the result, and determine its size. */
|
|
|
|
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
|
|
{
|
|
result->expr_type = EXPR_ARRAY;
|
|
result->rank = 1;
|
|
result->shape = gfc_get_shape (1);
|
|
mpz_init_set_ui (result->shape[0], result_length);
|
|
}
|
|
else
|
|
result->rank = 0;
|
|
|
|
/* Allocate the buffer to store the binary version of the source. */
|
|
buffer_size = MAX (source_size, result_size);
|
|
buffer = (unsigned char*)alloca (buffer_size);
|
|
memset (buffer, 0, buffer_size);
|
|
|
|
/* Now write source to the buffer. */
|
|
gfc_target_encode_expr (source, buffer, buffer_size);
|
|
|
|
/* And read the buffer back into the new expression. */
|
|
gfc_target_interpret_expr (buffer, buffer_size, result, false);
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_transpose (gfc_expr *matrix)
|
|
{
|
|
int row, matrix_rows, col, matrix_cols;
|
|
gfc_expr *result;
|
|
|
|
if (!is_constant_array_expr (matrix))
|
|
return NULL;
|
|
|
|
gcc_assert (matrix->rank == 2);
|
|
|
|
if (matrix->shape == NULL)
|
|
return NULL;
|
|
|
|
result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
|
|
&matrix->where);
|
|
result->rank = 2;
|
|
result->shape = gfc_get_shape (result->rank);
|
|
mpz_init_set (result->shape[0], matrix->shape[1]);
|
|
mpz_init_set (result->shape[1], matrix->shape[0]);
|
|
|
|
if (matrix->ts.type == BT_CHARACTER)
|
|
result->ts.u.cl = matrix->ts.u.cl;
|
|
else if (matrix->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = matrix->ts.u.derived;
|
|
|
|
matrix_rows = mpz_get_si (matrix->shape[0]);
|
|
matrix_cols = mpz_get_si (matrix->shape[1]);
|
|
for (row = 0; row < matrix_rows; ++row)
|
|
for (col = 0; col < matrix_cols; ++col)
|
|
{
|
|
gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
|
|
col * matrix_rows + row);
|
|
gfc_constructor_insert_expr (&result->value.constructor,
|
|
gfc_copy_expr (e), &matrix->where,
|
|
row * matrix_cols + col);
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_trim (gfc_expr *e)
|
|
{
|
|
gfc_expr *result;
|
|
int count, i, len, lentrim;
|
|
|
|
if (e->expr_type != EXPR_CONSTANT)
|
|
return NULL;
|
|
|
|
len = e->value.character.length;
|
|
for (count = 0, i = 1; i <= len; ++i)
|
|
{
|
|
if (e->value.character.string[len - i] == ' ')
|
|
count++;
|
|
else
|
|
break;
|
|
}
|
|
|
|
lentrim = len - count;
|
|
|
|
result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
|
|
for (i = 0; i < lentrim; i++)
|
|
result->value.character.string[i] = e->value.character.string[i];
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
|
|
{
|
|
gfc_expr *result;
|
|
gfc_ref *ref;
|
|
gfc_array_spec *as;
|
|
gfc_constructor *sub_cons;
|
|
bool first_image;
|
|
int d;
|
|
|
|
if (!is_constant_array_expr (sub))
|
|
return NULL;
|
|
|
|
/* Follow any component references. */
|
|
as = coarray->symtree->n.sym->as;
|
|
for (ref = coarray->ref; ref; ref = ref->next)
|
|
if (ref->type == REF_COMPONENT)
|
|
as = ref->u.ar.as;
|
|
|
|
if (as->type == AS_DEFERRED)
|
|
return NULL;
|
|
|
|
/* "valid sequence of cosubscripts" are required; thus, return 0 unless
|
|
the cosubscript addresses the first image. */
|
|
|
|
sub_cons = gfc_constructor_first (sub->value.constructor);
|
|
first_image = true;
|
|
|
|
for (d = 1; d <= as->corank; d++)
|
|
{
|
|
gfc_expr *ca_bound;
|
|
int cmp;
|
|
|
|
gcc_assert (sub_cons != NULL);
|
|
|
|
ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
|
|
NULL, true);
|
|
if (ca_bound == NULL)
|
|
return NULL;
|
|
|
|
if (ca_bound == &gfc_bad_expr)
|
|
return ca_bound;
|
|
|
|
cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
|
|
|
|
if (cmp == 0)
|
|
{
|
|
gfc_free_expr (ca_bound);
|
|
sub_cons = gfc_constructor_next (sub_cons);
|
|
continue;
|
|
}
|
|
|
|
first_image = false;
|
|
|
|
if (cmp > 0)
|
|
{
|
|
gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
|
|
"SUB has %ld and COARRAY lower bound is %ld)",
|
|
&coarray->where, d,
|
|
mpz_get_si (sub_cons->expr->value.integer),
|
|
mpz_get_si (ca_bound->value.integer));
|
|
gfc_free_expr (ca_bound);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
gfc_free_expr (ca_bound);
|
|
|
|
/* Check whether upperbound is valid for the multi-images case. */
|
|
if (d < as->corank)
|
|
{
|
|
ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 1, as,
|
|
NULL, true);
|
|
if (ca_bound == &gfc_bad_expr)
|
|
return ca_bound;
|
|
|
|
if (ca_bound && ca_bound->expr_type == EXPR_CONSTANT
|
|
&& mpz_cmp (ca_bound->value.integer,
|
|
sub_cons->expr->value.integer) < 0)
|
|
{
|
|
gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
|
|
"SUB has %ld and COARRAY upper bound is %ld)",
|
|
&coarray->where, d,
|
|
mpz_get_si (sub_cons->expr->value.integer),
|
|
mpz_get_si (ca_bound->value.integer));
|
|
gfc_free_expr (ca_bound);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (ca_bound)
|
|
gfc_free_expr (ca_bound);
|
|
}
|
|
|
|
sub_cons = gfc_constructor_next (sub_cons);
|
|
}
|
|
|
|
gcc_assert (sub_cons == NULL);
|
|
|
|
if (flag_coarray != GFC_FCOARRAY_SINGLE && !first_image)
|
|
return NULL;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&gfc_current_locus);
|
|
if (first_image)
|
|
mpz_set_si (result->value.integer, 1);
|
|
else
|
|
mpz_set_si (result->value.integer, 0);
|
|
|
|
return result;
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_image_status (gfc_expr *image, gfc_expr *team ATTRIBUTE_UNUSED)
|
|
{
|
|
if (flag_coarray == GFC_FCOARRAY_NONE)
|
|
{
|
|
gfc_current_locus = *gfc_current_intrinsic_where;
|
|
gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
/* Simplification is possible for fcoarray = single only. For all other modes
|
|
the result depends on runtime conditions. */
|
|
if (flag_coarray != GFC_FCOARRAY_SINGLE)
|
|
return NULL;
|
|
|
|
if (gfc_is_constant_expr (image))
|
|
{
|
|
gfc_expr *result;
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&image->where);
|
|
if (mpz_get_si (image->value.integer) == 1)
|
|
mpz_set_si (result->value.integer, 0);
|
|
else
|
|
mpz_set_si (result->value.integer, GFC_STAT_STOPPED_IMAGE);
|
|
return result;
|
|
}
|
|
else
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim,
|
|
gfc_expr *distance ATTRIBUTE_UNUSED)
|
|
{
|
|
if (flag_coarray != GFC_FCOARRAY_SINGLE)
|
|
return NULL;
|
|
|
|
/* If no coarray argument has been passed or when the first argument
|
|
is actually a distance argument. */
|
|
if (coarray == NULL || !gfc_is_coarray (coarray))
|
|
{
|
|
gfc_expr *result;
|
|
/* FIXME: gfc_current_locus is wrong. */
|
|
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
|
|
&gfc_current_locus);
|
|
mpz_set_si (result->value.integer, 1);
|
|
return result;
|
|
}
|
|
|
|
/* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
|
|
return simplify_cobound (coarray, dim, NULL, 0);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ubound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
|
{
|
|
return simplify_bound (array, dim, kind, 1);
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
|
|
{
|
|
return simplify_cobound (array, dim, kind, 1);
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_unpack (gfc_expr *vector, gfc_expr *mask, gfc_expr *field)
|
|
{
|
|
gfc_expr *result, *e;
|
|
gfc_constructor *vector_ctor, *mask_ctor, *field_ctor;
|
|
|
|
if (!is_constant_array_expr (vector)
|
|
|| !is_constant_array_expr (mask)
|
|
|| (!gfc_is_constant_expr (field)
|
|
&& !is_constant_array_expr (field)))
|
|
return NULL;
|
|
|
|
result = gfc_get_array_expr (vector->ts.type, vector->ts.kind,
|
|
&vector->where);
|
|
if (vector->ts.type == BT_DERIVED)
|
|
result->ts.u.derived = vector->ts.u.derived;
|
|
result->rank = mask->rank;
|
|
result->shape = gfc_copy_shape (mask->shape, mask->rank);
|
|
|
|
if (vector->ts.type == BT_CHARACTER)
|
|
result->ts.u.cl = vector->ts.u.cl;
|
|
|
|
vector_ctor = gfc_constructor_first (vector->value.constructor);
|
|
mask_ctor = gfc_constructor_first (mask->value.constructor);
|
|
field_ctor
|
|
= field->expr_type == EXPR_ARRAY
|
|
? gfc_constructor_first (field->value.constructor)
|
|
: NULL;
|
|
|
|
while (mask_ctor)
|
|
{
|
|
if (mask_ctor->expr->value.logical)
|
|
{
|
|
gcc_assert (vector_ctor);
|
|
e = gfc_copy_expr (vector_ctor->expr);
|
|
vector_ctor = gfc_constructor_next (vector_ctor);
|
|
}
|
|
else if (field->expr_type == EXPR_ARRAY)
|
|
e = gfc_copy_expr (field_ctor->expr);
|
|
else
|
|
e = gfc_copy_expr (field);
|
|
|
|
gfc_constructor_append_expr (&result->value.constructor, e, NULL);
|
|
|
|
mask_ctor = gfc_constructor_next (mask_ctor);
|
|
field_ctor = gfc_constructor_next (field_ctor);
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_verify (gfc_expr *s, gfc_expr *set, gfc_expr *b, gfc_expr *kind)
|
|
{
|
|
gfc_expr *result;
|
|
int back;
|
|
size_t index, len, lenset;
|
|
size_t i;
|
|
int k = get_kind (BT_INTEGER, kind, "VERIFY", gfc_default_integer_kind);
|
|
|
|
if (k == -1)
|
|
return &gfc_bad_expr;
|
|
|
|
if (s->expr_type != EXPR_CONSTANT || set->expr_type != EXPR_CONSTANT
|
|
|| ( b != NULL && b->expr_type != EXPR_CONSTANT))
|
|
return NULL;
|
|
|
|
if (b != NULL && b->value.logical != 0)
|
|
back = 1;
|
|
else
|
|
back = 0;
|
|
|
|
result = gfc_get_constant_expr (BT_INTEGER, k, &s->where);
|
|
|
|
len = s->value.character.length;
|
|
lenset = set->value.character.length;
|
|
|
|
if (len == 0)
|
|
{
|
|
mpz_set_ui (result->value.integer, 0);
|
|
return result;
|
|
}
|
|
|
|
if (back == 0)
|
|
{
|
|
if (lenset == 0)
|
|
{
|
|
mpz_set_ui (result->value.integer, 1);
|
|
return result;
|
|
}
|
|
|
|
index = wide_strspn (s->value.character.string,
|
|
set->value.character.string) + 1;
|
|
if (index > len)
|
|
index = 0;
|
|
|
|
}
|
|
else
|
|
{
|
|
if (lenset == 0)
|
|
{
|
|
mpz_set_ui (result->value.integer, len);
|
|
return result;
|
|
}
|
|
for (index = len; index > 0; index --)
|
|
{
|
|
for (i = 0; i < lenset; i++)
|
|
{
|
|
if (s->value.character.string[index - 1]
|
|
== set->value.character.string[i])
|
|
break;
|
|
}
|
|
if (i == lenset)
|
|
break;
|
|
}
|
|
}
|
|
|
|
mpz_set_ui (result->value.integer, index);
|
|
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;
|
|
|
|
switch (x->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
|
|
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
|
|
return range_check (result, "XOR");
|
|
|
|
case BT_LOGICAL:
|
|
return gfc_get_logical_expr (kind, &x->where,
|
|
(x->value.logical && !y->value.logical)
|
|
|| (!x->value.logical && y->value.logical));
|
|
|
|
default:
|
|
gcc_unreachable ();
|
|
}
|
|
}
|
|
|
|
|
|
/****************** Constant simplification *****************/
|
|
|
|
/* Master function to convert one constant to another. While this is
|
|
used as a simplification function, it requires the destination type
|
|
and kind information which is supplied by a special case in
|
|
do_simplify(). */
|
|
|
|
gfc_expr *
|
|
gfc_convert_constant (gfc_expr *e, bt type, int kind)
|
|
{
|
|
gfc_expr *result, *(*f) (gfc_expr *, int);
|
|
gfc_constructor *c, *t;
|
|
|
|
switch (e->ts.type)
|
|
{
|
|
case BT_INTEGER:
|
|
switch (type)
|
|
{
|
|
case BT_INTEGER:
|
|
f = gfc_int2int;
|
|
break;
|
|
case BT_REAL:
|
|
f = gfc_int2real;
|
|
break;
|
|
case BT_COMPLEX:
|
|
f = gfc_int2complex;
|
|
break;
|
|
case BT_LOGICAL:
|
|
f = gfc_int2log;
|
|
break;
|
|
default:
|
|
goto oops;
|
|
}
|
|
break;
|
|
|
|
case BT_REAL:
|
|
switch (type)
|
|
{
|
|
case BT_INTEGER:
|
|
f = gfc_real2int;
|
|
break;
|
|
case BT_REAL:
|
|
f = gfc_real2real;
|
|
break;
|
|
case BT_COMPLEX:
|
|
f = gfc_real2complex;
|
|
break;
|
|
default:
|
|
goto oops;
|
|
}
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
switch (type)
|
|
{
|
|
case BT_INTEGER:
|
|
f = gfc_complex2int;
|
|
break;
|
|
case BT_REAL:
|
|
f = gfc_complex2real;
|
|
break;
|
|
case BT_COMPLEX:
|
|
f = gfc_complex2complex;
|
|
break;
|
|
|
|
default:
|
|
goto oops;
|
|
}
|
|
break;
|
|
|
|
case BT_LOGICAL:
|
|
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;
|
|
|
|
case BT_CHARACTER:
|
|
switch (type)
|
|
{
|
|
case BT_INTEGER:
|
|
f = gfc_character2int;
|
|
break;
|
|
|
|
case BT_REAL:
|
|
f = gfc_character2real;
|
|
break;
|
|
|
|
case BT_COMPLEX:
|
|
f = gfc_character2complex;
|
|
break;
|
|
|
|
case BT_CHARACTER:
|
|
f = gfc_character2character;
|
|
break;
|
|
|
|
case BT_LOGICAL:
|
|
f = gfc_character2logical;
|
|
break;
|
|
|
|
default:
|
|
goto oops;
|
|
}
|
|
break;
|
|
|
|
default:
|
|
oops:
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
result = NULL;
|
|
|
|
switch (e->expr_type)
|
|
{
|
|
case EXPR_CONSTANT:
|
|
result = f (e, kind);
|
|
if (result == NULL)
|
|
return &gfc_bad_expr;
|
|
break;
|
|
|
|
case EXPR_ARRAY:
|
|
if (!gfc_is_constant_expr (e))
|
|
break;
|
|
|
|
result = gfc_get_array_expr (type, kind, &e->where);
|
|
result->shape = gfc_copy_shape (e->shape, e->rank);
|
|
result->rank = e->rank;
|
|
|
|
for (c = gfc_constructor_first (e->value.constructor);
|
|
c; c = gfc_constructor_next (c))
|
|
{
|
|
gfc_expr *tmp;
|
|
if (c->iterator == NULL)
|
|
{
|
|
if (c->expr->expr_type == EXPR_ARRAY)
|
|
tmp = gfc_convert_constant (c->expr, type, kind);
|
|
else if (c->expr->expr_type == EXPR_OP)
|
|
{
|
|
if (!gfc_simplify_expr (c->expr, 1))
|
|
return &gfc_bad_expr;
|
|
tmp = f (c->expr, kind);
|
|
}
|
|
else
|
|
tmp = f (c->expr, kind);
|
|
}
|
|
else
|
|
tmp = gfc_convert_constant (c->expr, type, kind);
|
|
|
|
if (tmp == NULL || tmp == &gfc_bad_expr)
|
|
{
|
|
gfc_free_expr (result);
|
|
return NULL;
|
|
}
|
|
|
|
t = gfc_constructor_append_expr (&result->value.constructor,
|
|
tmp, &c->where);
|
|
if (c->iterator)
|
|
t->iterator = gfc_copy_iterator (c->iterator);
|
|
}
|
|
|
|
break;
|
|
|
|
default:
|
|
break;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
|
|
|
|
/* Function for converting character constants. */
|
|
gfc_expr *
|
|
gfc_convert_char_constant (gfc_expr *e, bt type ATTRIBUTE_UNUSED, int kind)
|
|
{
|
|
gfc_expr *result;
|
|
int i;
|
|
|
|
if (!gfc_is_constant_expr (e))
|
|
return NULL;
|
|
|
|
if (e->expr_type == EXPR_CONSTANT)
|
|
{
|
|
/* Simple case of a scalar. */
|
|
result = gfc_get_constant_expr (BT_CHARACTER, kind, &e->where);
|
|
if (result == NULL)
|
|
return &gfc_bad_expr;
|
|
|
|
result->value.character.length = e->value.character.length;
|
|
result->value.character.string
|
|
= gfc_get_wide_string (e->value.character.length + 1);
|
|
memcpy (result->value.character.string, e->value.character.string,
|
|
(e->value.character.length + 1) * sizeof (gfc_char_t));
|
|
|
|
/* Check we only have values representable in the destination kind. */
|
|
for (i = 0; i < result->value.character.length; i++)
|
|
if (!gfc_check_character_range (result->value.character.string[i],
|
|
kind))
|
|
{
|
|
gfc_error ("Character %qs in string at %L cannot be converted "
|
|
"into character kind %d",
|
|
gfc_print_wide_char (result->value.character.string[i]),
|
|
&e->where, kind);
|
|
gfc_free_expr (result);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
return result;
|
|
}
|
|
else if (e->expr_type == EXPR_ARRAY)
|
|
{
|
|
/* For an array constructor, we convert each constructor element. */
|
|
gfc_constructor *c;
|
|
|
|
result = gfc_get_array_expr (type, kind, &e->where);
|
|
result->shape = gfc_copy_shape (e->shape, e->rank);
|
|
result->rank = e->rank;
|
|
result->ts.u.cl = e->ts.u.cl;
|
|
|
|
for (c = gfc_constructor_first (e->value.constructor);
|
|
c; c = gfc_constructor_next (c))
|
|
{
|
|
gfc_expr *tmp = gfc_convert_char_constant (c->expr, type, kind);
|
|
if (tmp == &gfc_bad_expr)
|
|
{
|
|
gfc_free_expr (result);
|
|
return &gfc_bad_expr;
|
|
}
|
|
|
|
if (tmp == NULL)
|
|
{
|
|
gfc_free_expr (result);
|
|
return NULL;
|
|
}
|
|
|
|
gfc_constructor_append_expr (&result->value.constructor,
|
|
tmp, &c->where);
|
|
}
|
|
|
|
return result;
|
|
}
|
|
else
|
|
return NULL;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_compiler_options (void)
|
|
{
|
|
char *str;
|
|
gfc_expr *result;
|
|
|
|
str = gfc_get_option_string ();
|
|
result = gfc_get_character_expr (gfc_default_character_kind,
|
|
&gfc_current_locus, str, strlen (str));
|
|
free (str);
|
|
return result;
|
|
}
|
|
|
|
|
|
gfc_expr *
|
|
gfc_simplify_compiler_version (void)
|
|
{
|
|
char *buffer;
|
|
size_t len;
|
|
|
|
len = strlen ("GCC version ") + strlen (version_string);
|
|
buffer = XALLOCAVEC (char, len + 1);
|
|
snprintf (buffer, len + 1, "GCC version %s", version_string);
|
|
return gfc_get_character_expr (gfc_default_character_kind,
|
|
&gfc_current_locus, buffer, len);
|
|
}
|
|
|
|
/* Simplification routines for intrinsics of IEEE modules. */
|
|
|
|
gfc_expr *
|
|
simplify_ieee_selected_real_kind (gfc_expr *expr)
|
|
{
|
|
gfc_actual_arglist *arg;
|
|
gfc_expr *p = NULL, *q = NULL, *rdx = NULL;
|
|
|
|
arg = expr->value.function.actual;
|
|
p = arg->expr;
|
|
if (arg->next)
|
|
{
|
|
q = arg->next->expr;
|
|
if (arg->next->next)
|
|
rdx = arg->next->next->expr;
|
|
}
|
|
|
|
/* Currently, if IEEE is supported and this module is built, it means
|
|
all our floating-point types conform to IEEE. Hence, we simply handle
|
|
IEEE_SELECTED_REAL_KIND like SELECTED_REAL_KIND. */
|
|
return gfc_simplify_selected_real_kind (p, q, rdx);
|
|
}
|
|
|
|
gfc_expr *
|
|
simplify_ieee_support (gfc_expr *expr)
|
|
{
|
|
/* We consider that if the IEEE modules are loaded, we have full support
|
|
for flags, halting and rounding, which are the three functions
|
|
(IEEE_SUPPORT_{FLAG,HALTING,ROUNDING}) allowed in constant
|
|
expressions. One day, we will need libgfortran to detect support and
|
|
communicate it back to us, allowing for partial support. */
|
|
|
|
return gfc_get_logical_expr (gfc_default_logical_kind, &expr->where,
|
|
true);
|
|
}
|
|
|
|
bool
|
|
matches_ieee_function_name (gfc_symbol *sym, const char *name)
|
|
{
|
|
int n = strlen(name);
|
|
|
|
if (!strncmp(sym->name, name, n))
|
|
return true;
|
|
|
|
/* If a generic was used and renamed, we need more work to find out.
|
|
Compare the specific name. */
|
|
if (sym->generic && !strncmp(sym->generic->sym->name, name, n))
|
|
return true;
|
|
|
|
return false;
|
|
}
|
|
|
|
gfc_expr *
|
|
gfc_simplify_ieee_functions (gfc_expr *expr)
|
|
{
|
|
gfc_symbol* sym = expr->symtree->n.sym;
|
|
|
|
if (matches_ieee_function_name(sym, "ieee_selected_real_kind"))
|
|
return simplify_ieee_selected_real_kind (expr);
|
|
else if (matches_ieee_function_name(sym, "ieee_support_flag")
|
|
|| matches_ieee_function_name(sym, "ieee_support_halting")
|
|
|| matches_ieee_function_name(sym, "ieee_support_rounding"))
|
|
return simplify_ieee_support (expr);
|
|
else
|
|
return NULL;
|
|
}
|