/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc

Bug Summary

File:	build/gcc/fortran/simplify.cc
Warning:	line 5332, column 4 The expression is an uninitialized value. The computed value will also be garbage

Annotated Source Code

Press '?' to see keyboard shortcuts

Show analyzer invocation

clang -cc1 -cc1 -triple x86_64-suse-linux -analyze -disable-free -clear-ast-before-backend -disable-llvm-verifier -discard-value-names -main-file-name simplify.cc -analyzer-checker=core -analyzer-checker=apiModeling -analyzer-checker=unix -analyzer-checker=deadcode -analyzer-checker=cplusplus -analyzer-checker=security.insecureAPI.UncheckedReturn -analyzer-checker=security.insecureAPI.getpw -analyzer-checker=security.insecureAPI.gets -analyzer-checker=security.insecureAPI.mktemp -analyzer-checker=security.insecureAPI.mkstemp -analyzer-checker=security.insecureAPI.vfork -analyzer-checker=nullability.NullPassedToNonnull -analyzer-checker=nullability.NullReturnedFromNonnull -analyzer-output plist -w -setup-static-analyzer -analyzer-config-compatibility-mode=true -mrelocation-model static -mframe-pointer=none -fmath-errno -ffp-contract=on -fno-rounding-math -mconstructor-aliases -funwind-tables=2 -target-cpu x86-64 -tune-cpu generic -debugger-tuning=gdb -fcoverage-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -resource-dir /usr/lib64/clang/15.0.7 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../include/c++/13/backward -internal-isystem /usr/lib64/clang/15.0.7/include -internal-isystem /usr/local/include -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/13/../../../../x86_64-suse-linux/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir=/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/gcc -ferror-limit 19 -fno-rtti -fgnuc-version=4.2.1 -vectorize-loops -vectorize-slp -analyzer-output=plist-html -analyzer-config silence-checkers=core.NullDereference -faddrsig -D__GCC_HAVE_DWARF2_CFI_ASM=1 -o /buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2023-03-27-141847-20772-1/report-ocCgmK.plist -x c++ /buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc

1/* Simplify intrinsic functions at compile-time.
 Copyright (C) 2000-2023 Free Software Foundation, Inc.
 Contributed by Andy Vaught & Katherine Holcomb

5This file is part of GCC.

7GCC is free software; you can redistribute it and/or modify it under
8the terms of the GNU General Public License as published by the Free
9Software Foundation; either version 3, or (at your option) any later
10version.

12GCC is distributed in the hope that it will be useful, but WITHOUT ANY
13WARRANTY; without even the implied warranty of MERCHANTABILITY or
14FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
15for more details.

17You should have received a copy of the GNU General Public License
18along with GCC; see the file COPYING3.  If not see
19<http://www.gnu.org/licenses/>.  */

21#include "config.h"
22#include "system.h"
23#include "coretypes.h"
24#include "tm.h"		/* For BITS_PER_UNIT.  */
25#include "gfortran.h"
26#include "arith.h"
27#include "intrinsic.h"
28#include "match.h"
29#include "target-memory.h"
30#include "constructor.h"
31#include "version.h"	/* For version_string.  */

33/* Prototypes.  */

35static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false);

37gfc_expr gfc_bad_expr;

39static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);


42/* 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.  */

74/* Range checks an expression node.  If all goes well, returns the
 node, otherwise returns &gfc_bad_expr and frees the node.  */

77static gfc_expr *
78range_check (gfc_expr *result, const char *name)
79{
if (result == NULL__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;
113}


116/* A helper function that gets an optional and possibly missing
 kind parameter.  Returns the kind, -1 if something went wrong.  */

119static int
120get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
121{
int kind;

if (k == NULL__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;
142}


145/* 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.  */

150static void
151convert_mpz_to_unsigned (mpz_t x, int bitsize)
152{
mpz_t mask;

if (mpz_sgn (x)((x)->_mp_size < 0 ? -1 : (x)->_mp_size > 0) < 0)
  {
    /* Confirm that no bits above the signed range are unset if we
are doing range checking.  */
    if (flag_range_checkglobal_options.x_flag_range_check != 0)
gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan0 (x, bitsize-1) == (9223372036854775807L
 *2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 160, __FUNCTION__), 0 : 0));

    mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
    mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
    mpz_sub_ui__gmpz_sub_ui (mask, mask, 1);

    mpz_and__gmpz_and (x, x, mask);

    mpz_clear__gmpz_clear (mask);
  }
else
  {
    /* Confirm that no bits above the signed range are set if we
are doing range checking.  */
    if (flag_range_checkglobal_options.x_flag_range_check != 0)
gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize-1) == (9223372036854775807L
 *2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 175, __FUNCTION__), 0 : 0));
  }
177}


180/* 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.  */

185void
186gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
187{
mpz_t mask;

/* Confirm that no bits above the unsigned range are set if we are
   doing range checking.  */
if (flag_range_checkglobal_options.x_flag_range_check != 0)
  gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX)((void)(!(__gmpz_scan1 (x, bitsize) == (9223372036854775807L *
2UL+1UL)) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 193, __FUNCTION__), 0 : 0));

if (mpz_tstbit__gmpz_tstbit (x, bitsize - 1) == 1)
  {
    mpz_init_set_ui__gmpz_init_set_ui (mask, 1);
    mpz_mul_2exp__gmpz_mul_2exp (mask, mask, bitsize);
    mpz_sub_ui__gmpz_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__gmpz_com (x, x);
    mpz_add_ui__gmpz_add_ui (x, x, 1);
    mpz_and__gmpz_and (x, x, mask);

    mpz_neg__gmpz_neg (x, x);

    mpz_clear__gmpz_clear (mask);
  }
213}


216/* Test that the expression is a constant array, simplifying if
 we are dealing with a parameter array.  */

219static bool
220is_constant_array_expr (gfc_expr *e)
221{
gfc_constructor *c;
bool array_OK = true;
mpz_t size;

if (e == NULL__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;

/* A non-zero-sized constant array shall have a non-empty constructor.  */
if (e->rank > 0 && e->shape != NULL__null && e->value.constructor == NULL__null)
  {
    mpz_init_set_ui__gmpz_init_set_ui (size, 1);
    for (int j = 0; j < e->rank; j++)
mpz_mul__gmpz_mul (size, size, e->shape[j]);
    bool not_size0 = (mpz_cmp_si (size, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(size)->_mp_size < 0 ? -1 : (size)->_mp_size > 0)
 : __gmpz_cmp_ui (size,(static_cast<unsigned long> (0))
)) : __gmpz_cmp_si (size,0)) != 0);
    mpz_clear__gmpz_clear (size);
    if (not_size0)
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__null && e->rank == 1)
  {
    if (!gfc_array_size(e, &size))
return false;
    e->shape = gfc_get_shape (1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
    mpz_init_set__gmpz_init_set (e->shape[0], size);
    mpz_clear__gmpz_clear (size);
  }

return array_OK;
285}

287/* Test for a size zero array.  */
288bool
289gfc_is_size_zero_array (gfc_expr *array)
290{

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__null)
  {
    for (int i = 0; i < array->rank; i++)
if (mpz_cmp_si (array->shape[i], 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(array->shape[i])->_mp_size < 0 ? -1 : (array->shape
[i])->_mp_size > 0) : __gmpz_cmp_ui (array->shape[i]
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (array
->shape[i],0)) <= 0)
 return true;

    return false;
  }

if (array->expr_type == EXPR_ARRAY)
  return array->value.constructor == NULL__null;

return false;
310}


313/* Initialize a transformational result expression with a given value.  */

315static void
316init_result_expr (gfc_expr *e, int init, gfc_expr *array)
317{
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_INTlong 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(-2147483647 -1))
     mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
   else if (init == INT_MAX2147483647)
     mpz_set__gmpz_set (e->value.integer, gfc_integer_kinds[i].huge);
   else
     mpz_set_si__gmpz_set_si (e->value.integer, init);
   break;

 case BT_REAL:
   if (init == INT_MIN(-2147483647 -1))
     {
mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4
(e->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
mpfr_neg (e->value.real, e->value.real, GFC_RND_MODEMPFR_RNDN);
     }
   else if (init == INT_MAX2147483647)
     mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4
(e->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
   else
     mpfr_set_si (e->value.real, init, GFC_RND_MODEMPFR_RNDN);
   break;

 case BT_COMPLEX:
   mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
   break;

 case BT_CHARACTER:
   if (init == INT_MIN(-2147483647 -1))
     {
gfc_expr *len = gfc_simplify_len (array, NULL__null);
gfc_extract_hwi (len, &length);
string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
gfc_wide_memset (string, 0, length);
     }
   else if (init == INT_MAX2147483647)
     {
gfc_expr *len = gfc_simplify_len (array, NULL__null);
gfc_extract_hwi (len, &length);
string = gfc_get_wide_string (length + 1)((gfc_char_t *) xcalloc ((length + 1), sizeof (gfc_char_t)));
gfc_wide_memset (string, 255, length);
     }
   else
     {
length = 0;
string = gfc_get_wide_string (1)((gfc_char_t *) xcalloc ((1), sizeof (gfc_char_t)));
     }

   string[length] = '\0';
   e->value.character.length = length;
   e->value.character.string = string;
   break;

 default:
   gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 391, __FUNCTION__));
}
  }
else
  gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 395, __FUNCTION__));
396}


399/* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
 if conj_a is true, the matrix_a is complex conjugated.  */

402static gfc_expr *
403compute_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)
406{
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__null, false);
else
  result = gfc_get_int_expr (1, NULL__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()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 443, __FUNCTION__));
}

    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;
454}


457/* Build a result expression for transformational intrinsics,
 depending on DIM.  */

460static gfc_expr *
461transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
	 int kind, locus* where)
463{
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__gmpz_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__null);
  }

return result;
488}


491typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);

493/* 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.  */

499static gfc_expr *
500gfc_count (gfc_expr *op1, gfc_expr *op2)
501{
gfc_expr *result;

gcc_assert (op1->ts.type == BT_INTEGER)((void)(!(op1->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 504, __FUNCTION__), 0 : 0));
gcc_assert (op2->ts.type == BT_LOGICAL)((void)(!(op2->ts.type == BT_LOGICAL) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 505, __FUNCTION__), 0 : 0));
gcc_assert (op2->value.logical)((void)(!(op2->value.logical) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 506, __FUNCTION__), 0 : 0));

result = gfc_copy_expr (op1);
mpz_add_ui__gmpz_add_ui (result->value.integer, result->value.integer, 1);

gfc_free_expr (op1);
gfc_free_expr (op2);
return result;
514}


517/* 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().  */

525static gfc_expr *
526simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
		   transformational_op op)
528{
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__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;
563}

565/* 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.  */

574static gfc_expr *
575simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
		  gfc_expr *mask, transformational_op op,
		  transformational_op post_op)
578{
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_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
    sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15],
    tmpstride[GFC_MAX_DIMENSIONS15];

/* 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__gmpz_get_ui (size);
mpz_clear__gmpz_clear (size);

arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*)));

array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL__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__null;

 mask_ctor = gfc_constructor_next (mask_ctor);
}
  }

/* Same for the result expression.  */
gfc_array_size (result, &size);
resultsize = mpz_get_ui__gmpz_get_ui (size);
mpz_clear__gmpz_clear (size);

resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*)));
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__gmpz_get_si (array->shape[i-1]);
    if (i == dim_index)
{
 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]);
 dim_stride = tmpstride[i];
 continue;
}

    extent[n] = mpz_get_si__gmpz_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;
710}


713static gfc_expr *
714simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
	 int init_val, transformational_op op)
716{
gfc_expr *result;
bool size_zero;

size_zero = gfc_is_size_zero_array (array);

if (!(is_constant_array_expr (array) || size_zero)
    || array->shape == NULL__null
    || !gfc_is_constant_expr (dim))
  return NULL__null;

if (mask
    && !is_constant_array_expr (mask)
    && mask->expr_type != EXPR_CONSTANT)
  return NULL__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__null);
742}


745/********************** Simplification functions *****************************/

747gfc_expr *
748gfc_simplify_abs (gfc_expr *e)
749{
gfc_expr *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

switch (e->ts.type)
  {
    case BT_INTEGER:
result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
mpz_abs__gmpz_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)mpfr_set4(result->value.real,e->value.real,MPFR_RNDN,1);
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_MODEMPFR_RNDN);
return range_check (result, "CABS");

    default:
gfc_internal_error ("gfc_simplify_abs(): Bad type");
  }
776}


779static gfc_expr *
780simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
781{
gfc_expr *result;
int kind;
bool too_large = false;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_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_surprisingglobal_options.x_warn_surprising && mpz_cmp_si (e->value.integer, 127)(__builtin_constant_p ((127) >= 0) && (127) >= 0
 ? (__builtin_constant_p ((static_cast<unsigned long> (
127))) && ((static_cast<unsigned long> (127))) ==
? ((e->value.integer)->_mp_size < 0 ? -1 : (e->
value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value
.integer,(static_cast<unsigned long> (127)))) : __gmpz_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)(__builtin_constant_p ((255) >= 0) && (255) >= 0
 ? (__builtin_constant_p ((static_cast<unsigned long> (
255))) && ((static_cast<unsigned long> (255))) ==
? ((e->value.integer)->_mp_size < 0 ? -1 : (e->
value.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value
.integer,(static_cast<unsigned long> (255)))) : __gmpz_cmp_si
 (e->value.integer,255)) > 0)
  too_large = true;
else if (kind == 4)
  {
    mpz_t t;
    mpz_init_set_ui__gmpz_init_set_ui (t, 2);
    mpz_pow_ui__gmpz_pow_ui (t, t, 32);
    mpz_sub_ui__gmpz_sub_ui (t, t, 1);
    if (mpz_cmp__gmpz_cmp (e->value.integer, t) > 0)
too_large = true;
    mpz_clear__gmpz_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__null, 1);
result->value.character.string[0] = mpz_get_ui__gmpz_get_ui (e->value.integer);

return result;
829}



833/* We use the processor's collating sequence, because all
 systems that gfortran currently works on are ASCII.  */

836gfc_expr *
837gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
838{
return simplify_achar_char (e, k, "ACHAR", true);
840}


843gfc_expr *
844gfc_simplify_acos (gfc_expr *x)
845{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

switch (x->ts.type)
  {
    case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
   || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 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_MODEMPFR_RNDN);
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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_acos(): Bad type");
  }

return range_check (result, "ACOS");
875}

877gfc_expr *
878gfc_simplify_acosh (gfc_expr *x)
879{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

switch (x->ts.type)
  {
    case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) < 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_MODEMPFR_RNDN);
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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
  }

return range_check (result, "ACOSH");
909}

911gfc_expr *
912gfc_simplify_adjustl (gfc_expr *e)
913{
gfc_expr *result;
int count, i, len;
gfc_char_t ch;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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__null, len);
for (i = 0; i < len - count; ++i)
  result->value.character.string[i] = e->value.character.string[count + i];

return result;
936}


939gfc_expr *
940gfc_simplify_adjustr (gfc_expr *e)
941{
gfc_expr *result;
int count, i, len;
gfc_char_t ch;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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__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;
967}


970gfc_expr *
971gfc_simplify_aimag (gfc_expr *e)
972{
gfc_expr *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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)__extension__ ({ mpfr_srcptr _p = (((e->value.complex)->
im)); mpfr_set4(result->value.real,_p,MPFR_RNDN,((_p)->
_mpfr_sign)); });

return range_check (result, "AIMAG");
982}


985gfc_expr *
986gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
987{
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__null;

rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
);

result = gfc_real2real (rtrunc, kind);

gfc_free_expr (rtrunc);

return range_check (result, "AINT");
1006}


1009gfc_expr *
1010gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
1011{
return simplify_transformation (mask, dim, NULL__null, true, gfc_and);
1013}


1016gfc_expr *
1017gfc_simplify_dint (gfc_expr *e)
1018{
gfc_expr *rtrunc, *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
);

result = gfc_real2real (rtrunc, gfc_default_double_kind);

gfc_free_expr (rtrunc);

return range_check (result, "DINT");
1032}


1035gfc_expr *
1036gfc_simplify_dreal (gfc_expr *e)
1037{
gfc_expr *result = NULL__null;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
mpc_real (result->value.real, e->value.complex, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "DREAL");
1047}


1050gfc_expr *
1051gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
1052{
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__null;

result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA
);

return range_check (result, "ANINT");
1067}


1070gfc_expr *
1071gfc_simplify_and (gfc_expr *x, gfc_expr *y)
1072{
gfc_expr *result;
int kind;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__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__gmpz_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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 1093, __FUNCTION__));
  }
1095}


1098gfc_expr *
1099gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1100{
return simplify_transformation (mask, dim, NULL__null, false, gfc_or);
1102}


1105gfc_expr *
1106gfc_simplify_dnint (gfc_expr *e)
1107{
gfc_expr *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
mpfr_round (result->value.real, e->value.real)mpfr_rint((result->value.real), (e->value.real), MPFR_RNDNA
);

return range_check (result, "DNINT");
1117}


1120gfc_expr *
1121gfc_simplify_asin (gfc_expr *x)
1122{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

switch (x->ts.type)
  {
    case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
   || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 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_MODEMPFR_RNDN);
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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_asin(): Bad type");
  }

return range_check (result, "ASIN");
1152}


1155/* Convert radians to degrees, i.e., x * 180 / pi.  */

1157static void
1158rad2deg (mpfr_t x)
1159{
mpfr_t tmp;

mpfr_init (tmp);
mpfr_const_pi (tmp, GFC_RND_MODEMPFR_RNDN);
mpfr_mul_ui (x, x, 180, GFC_RND_MODEMPFR_RNDN);
mpfr_div (x, x, tmp, GFC_RND_MODEMPFR_RNDN);
mpfr_clear (tmp);
1167}


1170/* Simplify ACOSD(X) where the returned value has units of degree.  */

1172gfc_expr *
1173gfc_simplify_acosd (gfc_expr *x)
1174{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
    || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 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_MODEMPFR_RNDN);
rad2deg (result->value.real);

return range_check (result, "ACOSD");
1193}


1196/* Simplify asind (x) where the returned value has units of degree. */

1198gfc_expr *
1199gfc_simplify_asind (gfc_expr *x)
1200{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) > 0
    || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) < 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_MODEMPFR_RNDN);
rad2deg (result->value.real);

return range_check (result, "ASIND");
1219}


1222/* Simplify atand (x) where the returned value has units of degree. */

1224gfc_expr *
1225gfc_simplify_atand (gfc_expr *x)
1226{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_atan (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);
rad2deg (result->value.real);

return range_check (result, "ATAND");
1237}


1240gfc_expr *
1241gfc_simplify_asinh (gfc_expr *x)
1242{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
  }

return range_check (result, "ASINH");
1265}


1268gfc_expr *
1269gfc_simplify_atan (gfc_expr *x)
1270{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_atan(): Bad type");
  }

return range_check (result, "ATAN");
1293}


1296gfc_expr *
1297gfc_simplify_atanh (gfc_expr *x)
1298{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

switch (x->ts.type)
  {
    case BT_REAL:
if (mpfr_cmp_si (x->value.real, 1)mpfr_cmp_si_2exp((x->value.real),(1),0) >= 0
   || mpfr_cmp_si (x->value.real, -1)mpfr_cmp_si_2exp((x->value.real),(-1),0) <= 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_MODEMPFR_RNDN);
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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
  }

return range_check (result, "ATANH");
1328}


1331gfc_expr *
1332gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1333{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (mpfr_zero_p (y->value.real)(((mpfr_srcptr) (0 ? (y->value.real) : (mpfr_srcptr) (y->
value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) && mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
  {
    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_MODEMPFR_RNDN);

return range_check (result, "ATAN2");
1350}


1353gfc_expr *
1354gfc_simplify_bessel_j0 (gfc_expr *x)
1355{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "BESSEL_J0");
1365}


1368gfc_expr *
1369gfc_simplify_bessel_j1 (gfc_expr *x)
1370{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "BESSEL_J1");
1380}


1383gfc_expr *
1384gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1385{
gfc_expr *result;
long n;

if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
  return NULL__null;

n = mpz_get_si__gmpz_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_MODEMPFR_RNDN);

return range_check (result, "BESSEL_JN");
1397}


1400/* Simplify transformational form of JN and YN.  */

1402static gfc_expr *
1403gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
	bool jn)
1405{
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__null;

n1 = mpz_get_si__gmpz_get_si (order1->value.integer);
n2 = mpz_get_si__gmpz_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_t *) xcalloc (((1)), sizeof (mpz_t))));
mpz_init_set_ui__gmpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0)((n2-n1+1) > (0) ? (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)mpfr_cmp_ui_2exp((x->value.real),(0.0),0) == 0)
  {
    if (!jn && flag_range_checkglobal_options.x_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_MODEMPFR_RNDN);
 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_MODEMPFR_RNDN);
 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_MODEMPFR_RNDN);
else
  mpfr_yn (last1, n1, x->value.real, GFC_RND_MODEMPFR_RNDN);

e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (e->value.real, last1, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (last1); mpfr_set4(e->value
.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
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_MODEMPFR_RNDN);
else
  mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODEMPFR_RNDN);

e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_set (e->value.real, last2, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (last2); mpfr_set4(e->value
.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
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_MODEMPFR_RNDN);

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_checkglobal_options.x_flag_range_check && mpfr_inf_p (last2)(((mpfr_srcptr) (0 ? (last2) : (mpfr_srcptr) (last2)))->_mpfr_exp
 == (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
{
 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_MODEMPFR_RNDN);
    mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODEMPFR_RNDN);
    mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODEMPFR_RNDN);

    if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
{
 /* Range_check frees "e" in that case.  */
 e = NULL__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)__extension__ ({ mpfr_srcptr _p = (last2); mpfr_set4(last1,_p
,MPFR_RNDN,((_p)->_mpfr_sign)); });
    mpfr_set (last2, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4
(last2,_p,MPFR_RNDN,((_p)->_mpfr_sign)); });
  }

mpfr_clear (last1);
mpfr_clear (last2);
mpfr_clear (x2rev);
return result;

1572error:
mpfr_clear (last1);
mpfr_clear (last2);
mpfr_clear (x2rev);
gfc_free_expr (e);
gfc_free_expr (result);
return &gfc_bad_expr;
1579}


1582gfc_expr *
1583gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1584{
return gfc_simplify_bessel_n2 (order1, order2, x, true);
1586}


1589gfc_expr *
1590gfc_simplify_bessel_y0 (gfc_expr *x)
1591{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "BESSEL_Y0");
1601}


1604gfc_expr *
1605gfc_simplify_bessel_y1 (gfc_expr *x)
1606{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "BESSEL_Y1");
1616}


1619gfc_expr *
1620gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1621{
gfc_expr *result;
long n;

if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
  return NULL__null;

n = mpz_get_si__gmpz_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_MODEMPFR_RNDN);

return range_check (result, "BESSEL_YN");
1633}


1636gfc_expr *
1637gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1638{
return gfc_simplify_bessel_n2 (order1, order2, x, false);
1640}


1643gfc_expr *
1644gfc_simplify_bit_size (gfc_expr *e)
1645{
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);
1649}


1652gfc_expr *
1653gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1654{
int b;

if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (!gfc_check_bitfcn (e, bit))
  return &gfc_bad_expr;

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__gmpz_tstbit (e->value.integer, b));
1668}


1671static int
1672compare_bitwise (gfc_expr *i, gfc_expr *j)
1673{
mpz_t x, y;
int k, res;

gcc_assert (i->ts.type == BT_INTEGER)((void)(!(i->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 1677, __FUNCTION__), 0 : 0));
gcc_assert (j->ts.type == BT_INTEGER)((void)(!(j->ts.type == BT_INTEGER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 1678, __FUNCTION__), 0 : 0));

mpz_init_set__gmpz_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__gmpz_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__gmpz_cmp (x, y);
mpz_clear__gmpz_clear (x);
mpz_clear__gmpz_clear (y);
return res;
1692}


1695gfc_expr *
1696gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1697{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
	       compare_bitwise (i, j) >= 0);
1703}


1706gfc_expr *
1707gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1708{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
	       compare_bitwise (i, j) > 0);
1714}


1717gfc_expr *
1718gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1719{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
	       compare_bitwise (i, j) <= 0);
1725}


1728gfc_expr *
1729gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1730{
if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
	       compare_bitwise (i, j) < 0);
1736}


1739gfc_expr *
1740gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1741{
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__null;

ceil = gfc_copy_expr (e);
mpfr_ceil (ceil->value.real, e->value.real)mpfr_rint((ceil->value.real), (e->value.real), MPFR_RNDU
);

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");
1761}


1764gfc_expr *
1765gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1766{
return simplify_achar_char (e, k, "CHAR", false);
1768}


1771/* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX.  */

1773static gfc_expr *
1774simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1775{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT
    || (y != NULL__null && y->expr_type != EXPR_CONSTANT))
  return NULL__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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    case BT_REAL:
mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
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)((result->value.complex)->im),
    y->value.integer, GFC_RND_MODEMPFR_RNDN);
break;

    case BT_REAL:
mpfr_set (mpc_imagref (result->value.complex),__extension__ ({ mpfr_srcptr _p = (y->value.real); mpfr_set4
(((result->value.complex)->im),_p,MPFR_RNDN,((_p)->_mpfr_sign
)); })
  y->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (y->value.real); mpfr_set4
(((result->value.complex)->im),_p,MPFR_RNDN,((_p)->_mpfr_sign
)); });
break;

    default:
gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
  }

return range_check (result, name);
1822}


1825gfc_expr *
1826gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1827{
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);
1835}


1838gfc_expr *
1839gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1840{
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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 1852, __FUNCTION__));

return simplify_cmplx ("COMPLEX", x, y, kind);
1855}


1858gfc_expr *
1859gfc_simplify_conjg (gfc_expr *e)
1860{
gfc_expr *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_copy_expr (e);
mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));

return range_check (result, "CONJG");
1870}


1873/* Simplify atan2d (x) where the unit is degree.  */

1875gfc_expr *
1876gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1877{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (mpfr_zero_p (y->value.real)(((mpfr_srcptr) (0 ? (y->value.real) : (mpfr_srcptr) (y->
value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) && mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
  {
    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_MODEMPFR_RNDN);
rad2deg (result->value.real);

return range_check (result, "ATAN2D");
1895}


1898gfc_expr *
1899gfc_simplify_cos (gfc_expr *x)
1900{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_cos(): Bad type");
  }

return range_check (result, "COS");
1924}


1927static void
1928deg2rad (mpfr_t x)
1929{
mpfr_t d2r;

mpfr_init (d2r);
mpfr_const_pi (d2r, GFC_RND_MODEMPFR_RNDN);
mpfr_div_ui (d2r, d2r, 180, GFC_RND_MODEMPFR_RNDN);
mpfr_mul (x, x, d2r, GFC_RND_MODEMPFR_RNDN);
mpfr_clear (d2r);
1937}


1940/* Simplification routines for SIND, COSD, TAND.  */
1941#include "trigd_fe.inc"


1944/* Simplify COSD(X) where X has the unit of degree.  */

1946gfc_expr *
1947gfc_simplify_cosd (gfc_expr *x)
1948{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);
simplify_cosd (result->value.real);

return range_check (result, "COSD");
1959}


1962/* Simplify SIND(X) where X has the unit of degree.  */

1964gfc_expr *
1965gfc_simplify_sind (gfc_expr *x)
1966{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);
simplify_sind (result->value.real);

return range_check (result, "SIND");
1977}


1980/* Simplify TAND(X) where X has the unit of degree.  */

1982gfc_expr *
1983gfc_simplify_tand (gfc_expr *x)
1984{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);
simplify_tand (result->value.real);

return range_check (result, "TAND");
1995}


1998/* Simplify COTAND(X) where X has the unit of degree.  */

2000gfc_expr *
2001gfc_simplify_cotand (gfc_expr *x)
2002{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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)__extension__ ({ mpfr_srcptr _p = (x->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);
mpfr_add_ui (result->value.real, result->value.real, 90, GFC_RND_MODEMPFR_RNDN);
simplify_tand (result->value.real);
mpfr_neg (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "COTAND");
2019}


2022gfc_expr *
2023gfc_simplify_cosh (gfc_expr *x)
2024{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 2043, __FUNCTION__));
  }

return range_check (result, "COSH");
2047}


2050gfc_expr *
2051gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2052{
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__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__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__null);
2079}

2081/* 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.  */

2086gfc_expr *
2087gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2088{
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_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
  hs_ex[GFC_MAX_DIMENSIONS15 + 1],
  hstride[GFC_MAX_DIMENSIONS15], sstride[GFC_MAX_DIMENSIONS15],
  a_extent[GFC_MAX_DIMENSIONS15], a_stride[GFC_MAX_DIMENSIONS15],
  h_extent[GFC_MAX_DIMENSIONS15],
  ss_ex[GFC_MAX_DIMENSIONS15 + 1];
ssize_t rsoffset;
int d, n;
bool continue_loop;
gfc_expr **src, **dest;

if (!is_constant_array_expr (array))
  return NULL__null;

if (shift->rank > 0)
  gfc_simplify_expr (shift, 1);

if (!gfc_is_constant_expr (shift))
  return NULL__null;

/* Make dim zero-based.  */
if (dim)
  {
    if (!gfc_is_constant_expr (dim))
return NULL__null;
    which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
  }
else
  which = 0;

if (array->shape == NULL__null)
  return NULL__null;

gfc_array_size (array, &size);
arraysize = mpz_get_ui__gmpz_get_ui (size);
mpz_clear__gmpz_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)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
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)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));

sstride[0] = 0;
extent[0] = 1;
count[0] = 0;

for (d=0; d < array->rank; d++)
  {
    a_extent[d] = mpz_get_si__gmpz_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__gmpz_get_ui (size);
    mpz_clear__gmpz_clear (size);
    shiftvec = XCNEWVEC (ssize_t, shiftsize)((ssize_t *) xcalloc ((shiftsize), sizeof (ssize_t)));
    shift_ctor = gfc_constructor_first (shift->value.constructor);
    for (d = 0; d < shift->rank; d++)
{
 h_extent[d] = mpz_get_si__gmpz_get_si (shift->shape[d]);
 hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
}
  }
else
  shiftvec = NULL__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__gmpz_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__gmpz_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__null);
  }
return result;
2293}


2296gfc_expr *
2297gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2298{
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2300}


2303gfc_expr *
2304gfc_simplify_dble (gfc_expr *e)
2305{
gfc_expr *result = NULL__null;
int tmp1, tmp2;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
   warnings.  */
tmp1 = warn_conversionglobal_options.x_warn_conversion;
tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;

result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);

warn_conversionglobal_options.x_warn_conversion = tmp1;
warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;

if (result == &gfc_bad_expr)
  return &gfc_bad_expr;

return range_check (result, "DBLE");
2327}


2330gfc_expr *
2331gfc_simplify_digits (gfc_expr *x)
2332{
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 ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 2349, __FUNCTION__));
  }

return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, digits);
2353}


2356gfc_expr *
2357gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2358{
gfc_expr *result;
int kind;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__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__gmpz_cmp (x->value.integer, y->value.integer) > 0)
 mpz_sub__gmpz_sub (result->value.integer, x->value.integer, y->value.integer);
else
 mpz_set_ui__gmpz_set_ui (result->value.integer, 0);

break;

    case BT_REAL:
if (mpfr_cmp (x->value.real, y->value.real)mpfr_cmp3(x->value.real, y->value.real, 1) > 0)
 mpfr_sub (result->value.real, x->value.real, y->value.real,
    GFC_RND_MODEMPFR_RNDN);
else
 mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN);

break;

    default:
gfc_internal_error ("gfc_simplify_dim(): Bad type");
  }

return range_check (result, "DIM");
2392}


2395gfc_expr*
2396gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2397{
/* 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__gmpz_get_si (vector_a->shape[0]) == 0)
  {
    if (vector_a->ts.type == BT_LOGICAL)
return gfc_get_logical_expr (gfc_default_logical_kind, NULL__null, false);
    else
return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, 0);
  }

if (!is_constant_array_expr (vector_a)
    || !is_constant_array_expr (vector_b))
  return NULL__null;

return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
2413}


2416gfc_expr *
2417gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2418{
gfc_expr *a1, *a2, *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);

gfc_free_expr (a2);
gfc_free_expr (a1);

return range_check (result, "DPROD");
2434}


2437static gfc_expr *
2438simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
      bool right)
2440{
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__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__gmpz_set_ui (result->value.integer, 0);

for (i = 0; i < shift; i++)
  if (mpz_tstbit__gmpz_tstbit (arg2->value.integer, size - shift + i))
    mpz_setbit__gmpz_setbit (result->value.integer, i);

for (i = 0; i < size - shift; i++)
  if (mpz_tstbit__gmpz_tstbit (arg1->value.integer, i))
    mpz_setbit__gmpz_setbit (result->value.integer, shift + i);

/* Convert to a signed value.  */
gfc_convert_mpz_to_signed (result->value.integer, size);

return result;
2472}


2475gfc_expr *
2476gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2477{
return simplify_dshift (arg1, arg2, shiftarg, true);
2479}


2482gfc_expr *
2483gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2484{
return simplify_dshift (arg1, arg2, shiftarg, false);
2486}


2489gfc_expr *
2490gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   gfc_expr *dim)
2492{
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_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
  sstride[GFC_MAX_DIMENSIONS15], a_extent[GFC_MAX_DIMENSIONS15],
  a_stride[GFC_MAX_DIMENSIONS15], ss_ex[GFC_MAX_DIMENSIONS15 + 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__null;

if (shift->rank > 0)
  gfc_simplify_expr (shift, 1);

if (!gfc_is_constant_expr (shift))
  return NULL__null;

if (boundary)
  {
    if (boundary->rank > 0)
gfc_simplify_expr (boundary, 1);

    if (!gfc_is_constant_expr (boundary))
 return NULL__null;
  }

if (dim)
  {
    if (!gfc_is_constant_expr (dim))
return NULL__null;
    which = mpz_get_si__gmpz_get_si (dim->value.integer) - 1;
  }
else
  which = 0;

s_len = 0;
if (boundary == NULL__null)
  {
    temp_boundary = true;
    switch (array->ts.type)
{

case BT_INTEGER:
 bnd = gfc_get_int_expr (array->ts.kind, NULL__null, 0);
 break;

case BT_LOGICAL:
 bnd = gfc_get_logical_expr (array->ts.kind, NULL__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_MODEMPFR_RNDN);
 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_MODEMPFR_RNDN);
 break;

case BT_CHARACTER:
 s_len = mpz_get_ui__gmpz_get_ui (array->ts.u.cl->length->value.integer);
 bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL__null, s_len);
 break;

default:
 gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 2570, __FUNCTION__));

}
  }
else
  {
    temp_boundary = false;
    bnd = boundary;
  }

gfc_array_size (array, &size);
arraysize = mpz_get_ui__gmpz_get_ui (size);
mpz_clear__gmpz_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__null)
  goto final;

arrayvec = XCNEWVEC (gfc_expr *, arraysize)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));
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)((gfc_expr * *) xcalloc ((arraysize), sizeof (gfc_expr *)));

extent[0] = 1;
count[0] = 0;

for (d=0; d < array->rank; d++)
  {
    a_extent[d] = mpz_get_si__gmpz_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__null;
    shift_val = mpz_get_si__gmpz_get_si (shift->value.integer);
  }

if (bnd->rank > 0)
  bnd_ctor = gfc_constructor_first (bnd->value.constructor);
else
  bnd_ctor = NULL__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__gmpz_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__null);
  }

final:
if (temp_boundary)
  gfc_free_expr (bnd);

return result;
2756}

2758gfc_expr *
2759gfc_simplify_erf (gfc_expr *x)
2760{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erf (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "ERF");
2770}


2773gfc_expr *
2774gfc_simplify_erfc (gfc_expr *x)
2775{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "ERFC");
2785}


2788/* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */

2790#define MAX_ITER 200
2791#define ARG_LIMIT 12

2793/* 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.  */
2799static void
2800fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2801{
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)__extension__ ({ mpfr_srcptr _p = (arg); mpfr_set4(a,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_sqr (b, a, GFC_RND_MODEMPFR_RNDN);
mpfr_exp (b, b, GFC_RND_MODEMPFR_RNDN);
mpfr_erfc (a, a, GFC_RND_MODEMPFR_RNDN);
mpfr_mul (a, a, b, GFC_RND_MODEMPFR_RNDN);

mpfr_set (res, a, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (a); mpfr_set4(res,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_set_default_prec (prec);

mpfr_clear (a);
mpfr_clear (b);
2822}

2824/* 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.  */
2834static void
2835asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2836{
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__gmpz_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)__extension__ ({ mpfr_srcptr _p = (arg); mpfr_set4(x,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_set_ui (sum, 1, GFC_RND_MODEMPFR_RNDN);
mpz_set_ui__gmpz_set_ui (num, 1);

mpfr_set (u, x, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (x); mpfr_set4(u,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_sqr (u, u, GFC_RND_MODEMPFR_RNDN);
mpfr_mul_ui (u, u, 2, GFC_RND_MODEMPFR_RNDN);
mpfr_pow_si (u, u, -1, GFC_RND_MODEMPFR_RNDN);

for (i = 1; i < MAX_ITER; i++)
{
  mpfr_set (oldsum, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(oldsum,_p,
MPFR_RNDN,((_p)->_mpfr_sign)); });

  mpz_mul_ui__gmpz_mul_ui (num, num, 2 * i - 1);
  mpz_neg__gmpz_neg (num, num);

  mpfr_set (w, u, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (u); mpfr_set4(w,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
  mpfr_pow_ui (w, w, i, GFC_RND_MODEMPFR_RNDN);

  mpfr_set_z (v, num, GFC_RND_MODEMPFR_RNDN);
  mpfr_mul (v, v, w, GFC_RND_MODEMPFR_RNDN);

  mpfr_add (sum, sum, v, GFC_RND_MODEMPFR_RNDN);

  mpfr_set (sumtrunc, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(sumtrunc,_p
,MPFR_RNDN,((_p)->_mpfr_sign)); });
  if (mpfr_cmp (sumtrunc, oldsum)mpfr_cmp3(sumtrunc, oldsum, 1) == 0)
    break;
}

/* We should have converged by now; otherwise, ARG_LIMIT is probably
   set too low.  */
gcc_assert (i < MAX_ITER)((void)(!(i < MAX_ITER) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 2888, __FUNCTION__), 0 : 0));

/* Divide by x * sqrt(Pi).  */
mpfr_const_pi (u, GFC_RND_MODEMPFR_RNDN);
mpfr_sqrt (u, u, GFC_RND_MODEMPFR_RNDN);
mpfr_mul (u, u, x, GFC_RND_MODEMPFR_RNDN);
mpfr_div (sum, sum, u, GFC_RND_MODEMPFR_RNDN);

mpfr_set (res, sum, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (sum); mpfr_set4(res,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_set_default_prec (prec);

mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL__null);
mpz_clear__gmpz_clear (num);
2901}


2904gfc_expr *
2905gfc_simplify_erfc_scaled (gfc_expr *x)
2906{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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");
2919}

2921#undef MAX_ITER
2922#undef ARG_LIMIT


2925gfc_expr *
2926gfc_simplify_epsilon (gfc_expr *e)
2927{
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)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].epsilon)
; mpfr_set4(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign
)); });

return range_check (result, "EPSILON");
2937}


2940gfc_expr *
2941gfc_simplify_exp (gfc_expr *x)
2942{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
break;

    case BT_COMPLEX:
gfc_set_model_kind (x->ts.kind);
mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
break;

    default:
gfc_internal_error ("in gfc_simplify_exp(): Bad type");
  }

return range_check (result, "EXP");
2966}


2969gfc_expr *
2970gfc_simplify_exponent (gfc_expr *x)
2971{
long int val;
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) || mpfr_nan_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
  {
    int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
    mpz_set__gmpz_set (result->value.integer, gfc_integer_kinds[i].huge);
    return result;
  }

/* EXPONENT(+/- 0.0) = 0  */
if (mpfr_zero_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
  {
    mpz_set_ui__gmpz_set_ui (result->value.integer, 0);
    return result;
  }

gfc_set_model (x->value.real);

val = (long int) mpfr_get_exp (x->value.real)(0 ? (((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (
x->value.real)))->_mpfr_exp) : (((mpfr_srcptr) (0 ? (x->
value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp
));
mpz_set_si__gmpz_set_si (result->value.integer, val);

return range_check (result, "EXPONENT");
3002}


3005gfc_expr *
3006gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
		       gfc_expr *kind)
3008{
if (flag_coarrayglobal_options.x_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_coarrayglobal_options.x_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__null;
3033}


3036gfc_expr *
3037gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3038{
if (flag_coarrayglobal_options.x_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_coarrayglobal_options.x_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__null;
3057}


3060gfc_expr *
3061gfc_simplify_float (gfc_expr *a)
3062{
gfc_expr *result;

if (a->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_int2real (a, gfc_default_real_kind);

return range_check (result, "FLOAT");
3071}


3074static bool
3075is_last_ref_vtab (gfc_expr *e)
3076{
gfc_ref *ref;
gfc_component *comp = NULL__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;
3094}


3097gfc_expr *
3098gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3099{
/* Avoid simplification of resolved symbols.  */
if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
  return NULL__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)(a != __null && a->ts.type == BT_CLASS && a
->ts.u.derived->components && a->ts.u.derived
->components->ts.u.derived && a->ts.u.derived
->components->ts.u.derived->attr.unlimited_polymorphic
) || UNLIMITED_POLY (mold)(mold != __null && mold->ts.type == BT_CLASS &&
 mold->ts.u.derived->components && mold->ts.
u.derived->components->ts.u.derived && mold->
ts.u.derived->components->ts.u.derived->attr.unlimited_polymorphic
))
  return NULL__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__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__null;
3144}


3147gfc_expr *
3148gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3149{
/* Avoid simplification of resolved symbols.  */
if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
  return NULL__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__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
	       gfc_compare_derived_types (a->ts.u.derived,
					  b->ts.u.derived));
3168}


3171gfc_expr *
3172gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3173{
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__null;

mpfr_init2 (floor, mpfr_get_prec (e->value.real)(0 ? (((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) (
e->value.real)))->_mpfr_prec) : (((mpfr_srcptr) (0 ? (e
->value.real) : (mpfr_srcptr) (e->value.real)))->_mpfr_prec
)));
mpfr_floor (floor, e->value.real)mpfr_rint((floor), (e->value.real), MPFR_RNDD);

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");
3194}


3197gfc_expr *
3198gfc_simplify_fraction (gfc_expr *x)
3199{
gfc_expr *result;
mpfr_exp_t e;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);

/* FRACTION(inf) = NaN.  */
if (mpfr_inf_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
  {
    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_MODEMPFR_RNDN);

return range_check (result, "FRACTION");
3219}


3222gfc_expr *
3223gfc_simplify_gamma (gfc_expr *x)
3224{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODEMPFR_RNDN);

return range_check (result, "GAMMA");
3234}


3237gfc_expr *
3238gfc_simplify_huge (gfc_expr *e)
3239{
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__gmpz_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)__extension__ ({ mpfr_srcptr _p = (gfc_real_kinds[i].huge); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);
break;

    default:
gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3257, __FUNCTION__));
  }

return result;
3261}


3264gfc_expr *
3265gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3266{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);
return range_check (result, "HYPOT");
3275}


3278/* We use the processor's collating sequence, because all
 systems that gfortran currently works on are ASCII.  */

3281gfc_expr *
3282gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3283{
gfc_expr *result;
gfc_char_t index;
int k;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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_surprisingglobal_options.x_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");
3311}


3314static gfc_expr *
3315do_bit_and (gfc_expr *result, gfc_expr *e)
3316{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
 == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3317, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3319, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3319, __FUNCTION__), 0 : 0));

mpz_and__gmpz_and (result->value.integer, result->value.integer, e->value.integer);
return result;
3323}


3326gfc_expr *
3327gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3328{
return simplify_transformation (array, dim, mask, -1, do_bit_and);
3330}


3333static gfc_expr *
3334do_bit_ior (gfc_expr *result, gfc_expr *e)
3335{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
 == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3336, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3338, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3338, __FUNCTION__), 0 : 0));

mpz_ior__gmpz_ior (result->value.integer, result->value.integer, e->value.integer);
return result;
3342}


3345gfc_expr *
3346gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3347{
return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3349}


3352gfc_expr *
3353gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3354{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_and__gmpz_and (result->value.integer, x->value.integer, y->value.integer);

return range_check (result, "IAND");
3364}


3367gfc_expr *
3368gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3369{
gfc_expr *result;
int k, pos;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (!gfc_check_bitfcn (x, y))
  return &gfc_bad_expr;

gfc_extract_int (y, &pos);

k = gfc_validate_kind (x->ts.type, x->ts.kind, false);

result = gfc_copy_expr (x);
/* Drop any separate memory representation of x to avoid potential
   inconsistencies in result.  */
if (result->representation.string)
  {
    free (result->representation.string);
    result->representation.string = NULL__null;
  }

convert_mpz_to_unsigned (result->value.integer,
	   gfc_integer_kinds[k].bit_size);

mpz_clrbit__gmpz_clrbit (result->value.integer, pos);

gfc_convert_mpz_to_signed (result->value.integer,
	 gfc_integer_kinds[k].bit_size);

return result;
3401}


3404gfc_expr *
3405gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3406{
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__null;

if (!gfc_check_ibits (x, y, z))
  return &gfc_bad_expr;

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)((int *) xcalloc ((bitsize), sizeof (int)));

for (i = 0; i < bitsize; i++)
  bits[i] = 0;

for (i = 0; i < len; i++)
  bits[i] = mpz_tstbit__gmpz_tstbit (x->value.integer, i + pos);

for (i = 0; i < bitsize; i++)
  {
    if (bits[i] == 0)
mpz_clrbit__gmpz_clrbit (result->value.integer, i);
    else if (bits[i] == 1)
mpz_setbit__gmpz_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;
3462}


3465gfc_expr *
3466gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3467{
gfc_expr *result;
int k, pos;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (!gfc_check_bitfcn (x, y))
  return &gfc_bad_expr;

gfc_extract_int (y, &pos);

k = gfc_validate_kind (x->ts.type, x->ts.kind, false);

result = gfc_copy_expr (x);
/* Drop any separate memory representation of x to avoid potential
   inconsistencies in result.  */
if (result->representation.string)
  {
    free (result->representation.string);
    result->representation.string = NULL__null;
  }

convert_mpz_to_unsigned (result->value.integer,
	   gfc_integer_kinds[k].bit_size);

mpz_setbit__gmpz_setbit (result->value.integer, pos);

gfc_convert_mpz_to_signed (result->value.integer,
	 gfc_integer_kinds[k].bit_size);

return result;
3499}


3502gfc_expr *
3503gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3504{
gfc_expr *result;
gfc_char_t index;
int k;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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");
3527}


3530gfc_expr *
3531gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3532{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_xor__gmpz_xor (result->value.integer, x->value.integer, y->value.integer);

return range_check (result, "IEOR");
3542}


3545gfc_expr *
3546gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3547{
gfc_expr *result;
bool back;
HOST_WIDE_INTlong len, lensub, start, last, i, index = 0;
int k, delta;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
    || ( b != NULL__null && b->expr_type !=  EXPR_CONSTANT))
  return NULL__null;

back = (b != NULL__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__gmpz_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;
}
  }

3611done:
mpz_set_si__gmpz_set_si (result->value.integer, index);
return range_check (result, "INDEX");
3614}


3617static gfc_expr *
3618simplify_intconv (gfc_expr *e, int kind, const char *name)
3619{
gfc_expr *result = NULL__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__null;
    result = gfc_copy_expr (e);
    return result;
  }

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

/* For explicit conversion, turn off -Wconversion and -Wconversion-extra
   warnings.  */
tmp1 = warn_conversionglobal_options.x_warn_conversion;
tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;

result = gfc_convert_constant (e, BT_INTEGER, kind);

warn_conversionglobal_options.x_warn_conversion = tmp1;
warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;

if (result == &gfc_bad_expr)
  return &gfc_bad_expr;

return range_check (result, name);
3650}


3653gfc_expr *
3654gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3655{
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");
3663}

3665gfc_expr *
3666gfc_simplify_int2 (gfc_expr *e)
3667{
return simplify_intconv (e, 2, "INT2");
3669}


3672gfc_expr *
3673gfc_simplify_int8 (gfc_expr *e)
3674{
return simplify_intconv (e, 8, "INT8");
3676}


3679gfc_expr *
3680gfc_simplify_long (gfc_expr *e)
3681{
return simplify_intconv (e, 4, "LONG");
3683}


3686gfc_expr *
3687gfc_simplify_ifix (gfc_expr *e)
3688{
gfc_expr *rtrunc, *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
);

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");
3704}


3707gfc_expr *
3708gfc_simplify_idint (gfc_expr *e)
3709{
gfc_expr *rtrunc, *result;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__null;

rtrunc = gfc_copy_expr (e);
mpfr_trunc (rtrunc->value.real, e->value.real)mpfr_rint((rtrunc->value.real), (e->value.real), MPFR_RNDZ
);

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");
3725}


3728gfc_expr *
3729gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3730{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer);

return range_check (result, "IOR");
3740}


3743static gfc_expr *
3744do_bit_xor (gfc_expr *result, gfc_expr *e)
3745{
gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_INTEGER && e->expr_type
 == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3746, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3748, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 3748, __FUNCTION__), 0 : 0));

mpz_xor__gmpz_xor (result->value.integer, result->value.integer, e->value.integer);
return result;
3752}


3755gfc_expr *
3756gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3757{
return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3759}


3762gfc_expr *
3763gfc_simplify_is_iostat_end (gfc_expr *x)
3764{
if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
	       mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_END))) && ((static_cast<unsigned long
> (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size
 < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (x->value.integer,(static_cast<unsigned long> (LIBERROR_END
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END))
			   LIBERROR_END)(__builtin_constant_p ((LIBERROR_END) >= 0) && (LIBERROR_END
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_END))) && ((static_cast<unsigned long
> (LIBERROR_END))) == 0 ? ((x->value.integer)->_mp_size
 < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (x->value.integer,(static_cast<unsigned long> (LIBERROR_END
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_END)) == 0);
3771}


3774gfc_expr *
3775gfc_simplify_is_iostat_eor (gfc_expr *x)
3776{
if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
	       mpz_cmp_si (x->value.integer,(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_EOR))) && ((static_cast<unsigned long
> (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size
 < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR))
			   LIBERROR_EOR)(__builtin_constant_p ((LIBERROR_EOR) >= 0) && (LIBERROR_EOR
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (LIBERROR_EOR))) && ((static_cast<unsigned long
> (LIBERROR_EOR))) == 0 ? ((x->value.integer)->_mp_size
 < 0 ? -1 : (x->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (x->value.integer,(static_cast<unsigned long> (LIBERROR_EOR
)))) : __gmpz_cmp_si (x->value.integer,LIBERROR_EOR)) == 0);
3783}


3786gfc_expr *
3787gfc_simplify_isnan (gfc_expr *x)
3788{
if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
	       mpfr_nan_p (x->value.real)(((mpfr_srcptr) (0 ? (x->value.real) : (mpfr_srcptr) (x->
value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))));
3794}


3797/* 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.  */
3800static gfc_expr *
3801simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
bool arithmetic, int direction)
3803{
gfc_expr *result;
int ashift, *bits, i, k, bitsize, shift;

if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
  return NULL__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__gmpz_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)((int *) xcalloc ((bitsize), sizeof (int)));

for (i = 0; i < bitsize; i++)
  bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);

if (shift > 0)
  {
    /* Left shift.  */
    for (i = 0; i < shift; i++)
mpz_clrbit__gmpz_clrbit (result->value.integer, i);

    for (i = 0; i < bitsize - shift; i++)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
}
  }
else
  {
    /* Right shift.  */
    if (arithmetic && bits[bitsize - 1])
for (i = bitsize - 1; i >= bitsize - ashift; i--)
 mpz_setbit__gmpz_setbit (result->value.integer, i);
    else
for (i = bitsize - 1; i >= bitsize - ashift; i--)
 mpz_clrbit__gmpz_clrbit (result->value.integer, i);

    for (i = bitsize - 1; i >= ashift; i--)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i - ashift);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i - ashift);
}
  }

gfc_convert_mpz_to_signed (result->value.integer, bitsize);
free (bits);

return result;
3893}


3896gfc_expr *
3897gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3898{
return simplify_shift (e, s, "ISHFT", false, 0);
3900}


3903gfc_expr *
3904gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3905{
return simplify_shift (e, s, "LSHIFT", false, 1);
3907}


3910gfc_expr *
3911gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3912{
return simplify_shift (e, s, "RSHIFT", true, -1);
3914}


3917gfc_expr *
3918gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3919{
return simplify_shift (e, s, "SHIFTA", true, -1);
3921}


3924gfc_expr *
3925gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3926{
return simplify_shift (e, s, "SHIFTL", false, 1);
3928}


3931gfc_expr *
3932gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3933{
return simplify_shift (e, s, "SHIFTR", false, -1);
3935}


3938gfc_expr *
3939gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3940{
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__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__null)
  {
    if (sz->expr_type != EXPR_CONSTANT)
return NULL__null;

    gfc_extract_int (sz, &ssize);

    if (ssize > isize || ssize <= 0)
return &gfc_bad_expr;
  }
else
  ssize = isize;

if (shift >= 0)
  ashift = shift;
else
  ashift = -shift;

if (ashift > ssize)
  {
    if (sz == NULL__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__gmpz_set (result->value.integer, e->value.integer);

if (shift == 0)
  return result;

convert_mpz_to_unsigned (result->value.integer, isize);

bits = XCNEWVEC (int, ssize)((int *) xcalloc ((ssize), sizeof (int)));

for (i = 0; i < ssize; i++)
  bits[i] = mpz_tstbit__gmpz_tstbit (e->value.integer, i);

delta = ssize - ashift;

if (shift > 0)
  {
    for (i = 0; i < delta; i++)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
}

    for (i = delta; i < ssize; i++)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i - delta);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i - delta);
}
  }
else
  {
    for (i = 0; i < ashift; i++)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i + delta);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i + delta);
}

    for (i = ashift; i < ssize; i++)
{
 if (bits[i] == 0)
   mpz_clrbit__gmpz_clrbit (result->value.integer, i + shift);
 else
   mpz_setbit__gmpz_setbit (result->value.integer, i + shift);
}
  }

gfc_convert_mpz_to_signed (result->value.integer, isize);

free (bits);
return result;
4039}


4042gfc_expr *
4043gfc_simplify_kind (gfc_expr *e)
4044{
return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, e->ts.kind);
4046}


4049static gfc_expr *
4050simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
    gfc_array_spec *as, gfc_ref *ref, bool coarray)
4052{
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__gmpz_set_si (dim->value.integer, d);

 result = simplify_size (array, dim, k);
 gfc_free_expr (dim);
 if (!result)
   goto returnNull;
}
    else
mpz_set_si__gmpz_set_si (result->value.integer, 1);

    goto done;
  }

/* Otherwise, we have a variable expression.  */
gcc_assert (array->expr_type == EXPR_VARIABLE)((void)(!(array->expr_type == EXPR_VARIABLE) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4084, __FUNCTION__), 0 : 0));
gcc_assert (as)((void)(!(as) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4085, __FUNCTION__), 0 : 0));

if (!gfc_resolve_array_spec (as, 0))
  return NULL__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_coarrayglobal_options.x_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)((void)(!(l != __null) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4116, __FUNCTION__), 0 : 0));

    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)(__builtin_constant_p ((empty_bound) >= 0) && (empty_bound
) >= 0 ? (__builtin_constant_p ((static_cast<unsigned long
> (empty_bound))) && ((static_cast<unsigned long
> (empty_bound))) == 0 ? ((declared_bound->value.integer
)->_mp_size < 0 ? -1 : (declared_bound->value.integer
)->_mp_size > 0) : __gmpz_cmp_ui (declared_bound->value
.integer,(static_cast<unsigned long> (empty_bound)))) :
 __gmpz_cmp_si (declared_bound->value.integer,empty_bound)
) == 0)
   mpz_set_si__gmpz_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__gmpz_cmp (l->value.integer, u->value.integer) > 0)
   mpz_set_si__gmpz_set_si (result->value.integer, empty_bound);
 else
   mpz_set__gmpz_set (result->value.integer, declared_bound->value.integer);
}
    else
mpz_set__gmpz_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__null))
   goto returnNull;
}
    else
mpz_set_si__gmpz_set_si (result->value.integer, (long int) 1);
  }

4168done:
return range_check (result, upper ? "UBOUND" : "LBOUND");

4171returnNull:
gfc_free_expr (result);
return NULL__null;
4174}


4177static gfc_expr *
4178simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4179{
gfc_ref *ref;
gfc_array_spec *as;
ar_type type = AR_UNKNOWN;
int d;

if (array->ts.type == BT_CLASS)
  return NULL__null;

if (array->expr_type != EXPR_VARIABLE)
  {
    as = NULL__null;
    ref = NULL__null;
    goto done;
  }

/* Do not attempt to resolve if error has already been issued.  */
if (array->symtree->n.sym->error)
  return NULL__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__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__null;

   case AR_SECTION:
     as = ref->u.ar.as;
     goto done;
   }

 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4226, __FUNCTION__));

case REF_COMPONENT:
 as = ref->u.c.component->as;
 continue;

case REF_SUBSTRING:
case REF_INQUIRY:
 continue;
}
  }

gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4238, __FUNCTION__));

done:

if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
    || (as->type == AS_ASSUMED_SHAPE && upper)))
  return NULL__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__null;

gcc_assert (!as((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4256, __FUNCTION__), 0 : 0))
     || (as->type != AS_DEFERRED((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4256, __FUNCTION__), 0 : 0))
  && array->expr_type == EXPR_VARIABLE((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4256, __FUNCTION__), 0 : 0))
  && !gfc_expr_attr (array).allocatable((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4256, __FUNCTION__), 0 : 0))
  && !gfc_expr_attr (array).pointer))((void)(!(!as || (as->type != AS_DEFERRED && array
->expr_type == EXPR_VARIABLE && !gfc_expr_attr (array
).allocatable && !gfc_expr_attr (array).pointer)) ? fancy_abort
 ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4256, __FUNCTION__), 0 : 0));

if (dim == NULL__null)
  {
    /* Multi-dimensional bounds.  */
    gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
    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__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_t *) xcalloc (((1)), sizeof (mpz_t))));
    mpz_init_set_ui__gmpz_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__null;

    d = mpz_get_si__gmpz_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__null;

    return simplify_bound_dim (array, kind, d, upper, as, ref, false);
  }
4333}


4336static gfc_expr *
4337simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4338{
gfc_ref *ref;
gfc_array_spec *as;
int d;

if (array->expr_type != EXPR_VARIABLE)
  return NULL__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)((void)(!(as == ref->u.ar.as) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4360, __FUNCTION__), 0 : 0));
  goto done;
}
     as = NULL__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__null;

   case AR_SECTION:
     as = ref->u.ar.as;
     goto done;
   }

 gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4379, __FUNCTION__));

case REF_COMPONENT:
 as = ref->u.c.component->as;
 continue;

case REF_SUBSTRING:
case REF_INQUIRY:
 continue;
}
  }

if (!as)
  gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4392, __FUNCTION__));

done:

if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
  return NULL__null;

if (dim == NULL__null)
  {
    /* Multi-dimensional cobounds.  */
    gfc_expr *bounds[GFC_MAX_DIMENSIONS15];
    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__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_t *) xcalloc (((1)), sizeof (mpz_t))));
    mpz_init_set_ui__gmpz_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__null;

    d = mpz_get_si__gmpz_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);
  }
4463}


4466gfc_expr *
4467gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4468{
return simplify_bound (array, dim, kind, 0);
4470}


4473gfc_expr *
4474gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4475{
return simplify_cobound (array, dim, kind, 0);
4477}

4479gfc_expr *
4480gfc_simplify_leadz (gfc_expr *e)
4481{
unsigned long lz, bs;
int i;

if (e->expr_type != EXPR_CONSTANT)
  return NULL__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)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e->
value.integer,0)) == 0)
  lz = bs;
else if (mpz_cmp_si (e->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(e->value.integer)->_mp_size < 0 ? -1 : (e->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (e->value.integer
,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (e->
value.integer,0)) < 0)
  lz = 0;
else
  lz = bs - mpz_sizeinbase__gmpz_sizeinbase (e->value.integer, 2);

return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
4498}


4501/* Check for constant length of a substring.  */

4503static bool
4504substring_has_constant_len (gfc_expr *e)
4505{
gfc_ref *ref;
HOST_WIDE_INTlong 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;
4541}


4544gfc_expr *
4545gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4546{
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__gmpz_set_si (result->value.integer, e->value.character.length);
    return range_check (result, "LEN");
  }
else if (e->ts.u.cl != NULL__null && e->ts.u.cl->length != NULL__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__gmpz_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)(e->symtree->n.sym->assoc->target->symtree->
n.sym != __null && e->symtree->n.sym->assoc->
target->symtree->n.sym->ts.type == BT_CLASS &&
 e->symtree->n.sym->assoc->target->symtree->
n.sym->ts.u.derived->components && e->symtree
->n.sym->assoc->target->symtree->n.sym->ts.
u.derived->components->ts.u.derived && e->symtree
->n.sym->assoc->target->symtree->n.sym->ts.
u.derived->components->ts.u.derived->attr.unlimited_polymorphic
))

  /* 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__null;
4582}


4585gfc_expr *
4586gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4587{
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__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");
4607}

4609gfc_expr *
4610gfc_simplify_lgamma (gfc_expr *x)
4611{
gfc_expr *result;
int sg;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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_MODEMPFR_RNDN);

return range_check (result, "LGAMMA");
4622}


4625gfc_expr *
4626gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4627{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
	       gfc_compare_string (a, b) >= 0);
4633}


4636gfc_expr *
4637gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4638{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
	       gfc_compare_string (a, b) > 0);
4644}


4647gfc_expr *
4648gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4649{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
	       gfc_compare_string (a, b) <= 0);
4655}


4658gfc_expr *
4659gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4660{
if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
  return NULL__null;

return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
	       gfc_compare_string (a, b) < 0);
4666}


4669gfc_expr *
4670gfc_simplify_log (gfc_expr *x)
4671{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__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)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (x->
value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
 () : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign)
) <= 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_MODEMPFR_RNDN);
    break;

  case BT_COMPLEX:
    if (mpfr_zero_p (mpc_realref (x->value.complex))(((mpfr_srcptr) (0 ? (((x->value.complex)->re)) : (mpfr_srcptr
) (((x->value.complex)->re))))->_mpfr_exp == (0 - ((
mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1))))
 && mpfr_zero_p (mpc_imagref (x->value.complex))(((mpfr_srcptr) (0 ? (((x->value.complex)->im)) : (mpfr_srcptr
) (((x->value.complex)->im))))->_mpfr_exp == (0 - ((
mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
{
 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(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
    break;

  default:
    gfc_internal_error ("gfc_simplify_log: bad type");
  }

return range_check (result, "LOG");
4712}


4715gfc_expr *
4716gfc_simplify_log10 (gfc_expr *x)
4717{
gfc_expr *result;

if (x->expr_type != EXPR_CONSTANT)
  return NULL__null;

if (mpfr_sgn (x->value.real)((x->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (x->
value.real) : (mpfr_srcptr) (x->value.real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
 () : (mpfr_void) 0), 0 : ((x->value.real)->_mpfr_sign)
) <= 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_MODEMPFR_RNDN);

return range_check (result, "LOG10");
4734}


4737gfc_expr *
4738gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4739{
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__null;

return gfc_get_logical_expr (kind, &e->where, e->value.logical);
4750}


4753gfc_expr*
4754gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4755{
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__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__gmpz_get_si (matrix_b->shape[1]);
    stride_a = 1;
    stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);

    result->rank = 1;
    result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
    mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_columns);
  }
else if (matrix_a->rank == 2 && matrix_b->rank == 1)
  {
    result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
    result_columns = 1;
    stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
    stride_b = 1;

    result->rank = 1;
    result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
    mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
  }
else if (matrix_a->rank == 2 && matrix_b->rank == 2)
  {
    result_rows = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
    result_columns = mpz_get_si__gmpz_get_si (matrix_b->shape[1]);
    stride_a = mpz_get_si__gmpz_get_si (matrix_a->shape[0]);
    stride_b = mpz_get_si__gmpz_get_si (matrix_b->shape[0]);

    result->rank = 2;
    result->shape = gfc_get_shape (result->rank)(((mpz_t *) xcalloc (((result->rank)), sizeof (mpz_t))));
    mpz_init_set_si__gmpz_init_set_si (result->shape[0], result_rows);
    mpz_init_set_si__gmpz_init_set_si (result->shape[1], result_columns);
  }
else
  gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4817, __FUNCTION__));

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__null);

 offset_a += 1;
      }

    offset_b += stride_b;
  }

return result;
4838}


4841gfc_expr *
4842gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4843{
gfc_expr *result;
int kind, arg, k;

if (i->expr_type != EXPR_CONSTANT)
  return NULL__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)((void)(!(!fail) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4856, __FUNCTION__), 0 : 0));

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__gmpz_set_ui (result->value.integer, 1);
mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer, arg);
mpz_sub_ui__gmpz_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;
4871}


4874gfc_expr *
4875gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4876{
gfc_expr *result;
int kind, arg, k;
mpz_t z;

if (i->expr_type != EXPR_CONSTANT)
  return NULL__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)((void)(!(!fail) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 4890, __FUNCTION__), 0 : 0));

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__gmpz_init_set_ui (z, 1);
mpz_mul_2exp__gmpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
mpz_mul_2exp__gmpz_mul_2exp (result->value.integer, result->value.integer,
gfc_integer_kinds[k].bit_size - arg);
mpz_sub__gmpz_sub (result->value.integer, z, result->value.integer);
mpz_clear__gmpz_clear (z);

gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);

return result;
4909}


4912gfc_expr *
4913gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4914{
gfc_expr * result;
gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;

if (mask->expr_type == EXPR_CONSTANT)
  {
    /* The standard requires evaluation of all function arguments.
Simplify only when the other dropped argument (FSOURCE or TSOURCE)
is a constant expression.  */
    if (mask->value.logical)
{
 if (!gfc_is_constant_expr (fsource))
   return NULL__null;
 result = gfc_copy_expr (tsource);
}
    else
{
 if (!gfc_is_constant_expr (tsource))
   return NULL__null;
 result = gfc_copy_expr (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__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__null);
    else
gfc_constructor_append_expr (&result->value.constructor,
		     gfc_copy_expr (fsource_ctor->expr),
		     NULL__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)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t))));
gfc_array_size (result, &result->shape[0]);

return result;
4976}


4979gfc_expr *
4980gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4981{
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__null;

result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);

/* Convert all argument to unsigned.  */
mpz_init_set__gmpz_init_set (arg1, i->value.integer);
mpz_init_set__gmpz_init_set (arg2, j->value.integer);
mpz_init_set__gmpz_init_set (mask, mask_expr->value.integer);

/* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
mpz_and__gmpz_and (arg1, arg1, mask);
mpz_com__gmpz_com (mask, mask);
mpz_and__gmpz_and (arg2, arg2, mask);
mpz_ior__gmpz_ior (result->value.integer, arg1, arg2);

mpz_clear__gmpz_clear (arg1);
mpz_clear__gmpz_clear (arg2);
mpz_clear__gmpz_clear (mask);

return result;
5007}


5010/* Selects between current value and extremum for simplify_min_max
 and simplify_minval_maxval.  */
5012static int
5013min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
5014{
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__gmpz_cmp (arg->value.integer,
       extremum->value.integer) * sign;
if (ret > 0)
 mpz_set__gmpz_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)(((mpfr_srcptr) (0 ? (extremum->value.real) : (mpfr_srcptr
) (extremum->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1)))))
 {
   ret = 1;
   mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg->value.real); mpfr_set4
(extremum->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign));
 });
 }
else if (mpfr_nan_p (arg->value.real)(((mpfr_srcptr) (0 ? (arg->value.real) : (mpfr_srcptr) (arg
->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))))
 ret = -1;
else
 {
   ret = mpfr_cmp (arg->value.real, extremum->value.real)mpfr_cmp3(arg->value.real, extremum->value.real, 1) * sign;
   if (ret > 0)
     mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (arg->value.real); mpfr_set4
(extremum->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign));
 });
 }
break;

    case BT_CHARACTER:
5047#define LENGTH(x) ((x)->value.character.length)
5048#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)((gfc_char_t *) xcalloc ((LENGTH(arg) + 1), sizeof (gfc_char_t
)));
   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)((gfc_char_t *) xcalloc ((LENGTH(extremum) + 1), sizeof (gfc_char_t
)));
   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  */
 }
5073#undef LENGTH
5074#undef STRING
break;

    default:
gfc_internal_error ("simplify_min_max(): Bad type in arglist");
  }
if (back_val && ret == 0)
  ret = 1;

return ret;
5084}


5087/* 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().  */

5094static gfc_expr *
5095simplify_min_max (gfc_expr *expr, int sign)
5096{
int tmp1, tmp2;
gfc_actual_arglist *arg, *last, *extremum;
gfc_expr *tmp, *ret;
const char *fname;

last = NULL__null;
extremum = NULL__null;

arg = expr->value.function.actual;

for (; arg; last = arg, arg = arg->next)
  {
    if (arg->expr->expr_type != EXPR_CONSTANT)
continue;

    if (extremum == NULL__null)
{
 extremum = arg;
 continue;
}

    min_max_choose (arg->expr, extremum->expr, sign);

    /* Delete the extra constant argument.  */
    last->next = arg->next;

    arg->next = NULL__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__null)
  return NULL__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_kind4)
    && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
  {
    /* Explicit conversion, turn off -Wconversion and -Wconversion-extra
warnings.  */
    tmp1 = warn_conversionglobal_options.x_warn_conversion;
    tmp2 = warn_conversion_extraglobal_options.x_warn_conversion_extra;
    warn_conversionglobal_options.x_warn_conversion = warn_conversion_extraglobal_options.x_warn_conversion_extra = 0;

    ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind4);

    warn_conversionglobal_options.x_warn_conversion = tmp1;
    warn_conversion_extraglobal_options.x_warn_conversion_extra = tmp2;
  }
else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind4)
  && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
  {
    ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind4);
  }
else
  ret = gfc_copy_expr (tmp);

return ret;

5163}


5166gfc_expr *
5167gfc_simplify_min (gfc_expr *e)
5168{
return simplify_min_max (e, -1);
5170}


5173gfc_expr *
5174gfc_simplify_max (gfc_expr *e)
5175{
return simplify_min_max (e, 1);
5177}

5179/* Helper function for gfc_simplify_minval.  */

5181static gfc_expr *
5182gfc_min (gfc_expr *op1, gfc_expr *op2)
5183{
min_max_choose (op1, op2, -1);
gfc_free_expr (op1);
return op2;
5187}

5189/* Simplify minval for constant arrays.  */

5191gfc_expr *
5192gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5193{
return simplify_transformation (array, dim, mask, INT_MAX2147483647, gfc_min);
5195}

5197/* Helper function for gfc_simplify_maxval.  */

5199static gfc_expr *
5200gfc_max (gfc_expr *op1, gfc_expr *op2)
5201{
min_max_choose (op1, op2, 1);
gfc_free_expr (op1);
return op2;
5205}


5208/* Simplify maxval for constant arrays.  */

5210gfc_expr *
5211gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5212{
return simplify_transformation (array, dim, mask, INT_MIN(-2147483647 -1), gfc_max);
5214}


5217/* Transform minloc or maxloc of an array, according to MASK,
 to the scalar result.  This code is mostly identical to
 simplify_transformation_to_scalar.  */

5221static gfc_expr *
5222simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
	      gfc_expr *extremum, int sign, bool back_val)
5224{
gfc_expr *a, *m;
gfc_constructor *array_ctor, *mask_ctor;
mpz_t count;

mpz_set_si__gmpz_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__null;

mpz_init_set_si__gmpz_init_set_si (count, 0);
while (array_ctor)
  {
    mpz_add_ui__gmpz_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__gmpz_set (result->value.integer, count);
  }
mpz_clear__gmpz_clear (count);
gfc_free_expr (extremum);
return result;
5264}

5266/* Simplify minloc / maxloc in the absence of a dim argument.  */

5268static gfc_expr *
5269simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
	  gfc_expr *array, gfc_expr *mask, int sign,
	  bool back_val)
5272{
ssize_t res[GFC_MAX_DIMENSIONS15];
int i, n;
gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15],
  sstride[GFC_MAX_DIMENSIONS15];
gfc_expr *a, *m;
bool continue_loop;
bool ma;

for (i = 0; i<array->rank; i++)
15
←
Assuming 'i' is >= field 'rank'→
  res[i] = -1;

/* Shortcut for constant .FALSE. MASK.  */
if (mask

15.1	'mask' is non-null

5287 && mask->expr_type == EXPR_CONSTANT

←

Assuming field 'expr_type' is not equal to EXPR_CONSTANT

→

5288 && !mask->value.logical) 5289 goto finish; 5290 5291 if (array->shape == NULL__null)

←

Assuming field 'shape' is not equal to NULL

→

←

Taking false branch

→

5292 goto finish; 5293 5294 for (i = 0; i

18.1	'i' is >= field 'rank'

< array->rank; i++)

←

Loop condition is false. Execution continues on line 5303

→

5295 { 5296 count[i] = 0; 5297 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5298 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]); 5299 if (extent[i] <= 0) 5300 goto finish; 5301 } 5302 5303 continue_loop = true; 5304 array_ctor = gfc_constructor_first (array->value.constructor); 5305 if (mask

19.1	'mask' is non-null

&& mask->rank > 0)

←

Assuming field 'rank' is <= 0

→

←

Taking false branch

→

5306 mask_ctor = gfc_constructor_first (mask->value.constructor); 5307 else 5308 mask_ctor = NULL__null; 5309 5310 /* Loop over the array elements (and mask), keeping track of 5311 the indices to return. */ 5312 while (continue_loop)

←

Loop condition is true. Entering loop body

→

5313 { 5314 do 5315 { 5316 a = array_ctor->expr; 5317 if (mask_ctor

22.1	'mask_ctor' is null

)

←

Taking false branch

→

5318 { 5319 m = mask_ctor->expr; 5320 ma = m->value.logical; 5321 mask_ctor = gfc_constructor_next (mask_ctor); 5322 } 5323 else 5324 ma = true; 5325 5326 if (ma

23.1	'ma' is true

&& min_max_choose (a, extremum, sign, back_val) > 0)

←

Assuming the condition is false

→

←

Taking false branch

→

5327 { 5328 for (i = 0; i<array->rank; i++) 5329 res[i] = count[i]; 5330 } 5331 array_ctor = gfc_constructor_next (array_ctor); 5332 count[0] ++;

←

The expression is an uninitialized value. The computed value will also be garbage

5333 } while (count[0] != extent[0]); 5334 n = 0; 5335 do 5336 { 5337 /* When we get to the end of a dimension, reset it and increment 5338 the next dimension. */ 5339 count[n] = 0; 5340 n++; 5341 if (n >= array->rank) 5342 { 5343 continue_loop = false; 5344 break; 5345 } 5346 else 5347 count[n] ++; 5348 } while (count[n] == extent[n]); 5349 } 5350 5351 finish: 5352 gfc_free_expr (extremum); 5353 result_ctor = gfc_constructor_first (result->value.constructor); 5354 for (i = 0; i<array->rank; i++) 5355 { 5356 gfc_expr *r_expr; 5357 r_expr = result_ctor->expr; 5358 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1); 5359 result_ctor = gfc_constructor_next (result_ctor); 5360 } 5361 return result; 5362} 5363 5364/* Helper function for gfc_simplify_minmaxloc - build an array 5365 expression with n elements. */ 5366 5367static gfc_expr * 5368new_array (bt type, int kind, int n, locus *where) 5369{ 5370 gfc_expr *result; 5371 int i; 5372 5373 result = gfc_get_array_expr (type, kind, where); 5374 result->rank = 1; 5375 result->shape = gfc_get_shape(1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 5376 mpz_init_set_si__gmpz_init_set_si (result->shape[0], n); 5377 for (i = 0; i < n; i++) 5378 { 5379 gfc_constructor_append_expr (&result->value.constructor, 5380 gfc_get_constant_expr (type, kind, where), 5381 NULL__null); 5382 } 5383 5384 return result; 5385} 5386 5387/* Simplify minloc and maxloc. This code is mostly identical to 5388 simplify_transformation_to_array. */ 5389 5390static gfc_expr * 5391simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, 5392 gfc_expr *dim, gfc_expr *mask, 5393 gfc_expr *extremum, int sign, bool back_val) 5394{ 5395 mpz_t size; 5396 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5397 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5398 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5399 5400 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5401 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15], 5402 tmpstride[GFC_MAX_DIMENSIONS15]; 5403 5404 /* Shortcut for constant .FALSE. MASK. */ 5405 if (mask 5406 && mask->expr_type == EXPR_CONSTANT 5407 && !mask->value.logical) 5408 return result; 5409 5410 /* Build an indexed table for array element expressions to minimize 5411 linked-list traversal. Masked elements are set to NULL. */ 5412 gfc_array_size (array, &size); 5413 arraysize = mpz_get_ui__gmpz_get_ui (size); 5414 mpz_clear__gmpz_clear (size); 5415 5416 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 5417 5418 array_ctor = gfc_constructor_first (array->value.constructor); 5419 mask_ctor = NULL__null; 5420 if (mask && mask->expr_type == EXPR_ARRAY) 5421 mask_ctor = gfc_constructor_first (mask->value.constructor); 5422 5423 for (i = 0; i < arraysize; ++i) 5424 { 5425 arrayvec[i] = array_ctor->expr; 5426 array_ctor = gfc_constructor_next (array_ctor); 5427 5428 if (mask_ctor) 5429 { 5430 if (!mask_ctor->expr->value.logical) 5431 arrayvec[i] = NULL__null; 5432 5433 mask_ctor = gfc_constructor_next (mask_ctor); 5434 } 5435 } 5436 5437 /* Same for the result expression. */ 5438 gfc_array_size (result, &size); 5439 resultsize = mpz_get_ui__gmpz_get_ui (size); 5440 mpz_clear__gmpz_clear (size); 5441 5442 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 5443 result_ctor = gfc_constructor_first (result->value.constructor); 5444 for (i = 0; i < resultsize; ++i) 5445 { 5446 resultvec[i] = result_ctor->expr; 5447 result_ctor = gfc_constructor_next (result_ctor); 5448 } 5449 5450 gfc_extract_int (dim, &dim_index); 5451 dim_index -= 1; /* zero-base index */ 5452 dim_extent = 0; 5453 dim_stride = 0; 5454 5455 for (i = 0, n = 0; i < array->rank; ++i) 5456 { 5457 count[i] = 0; 5458 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5459 if (i == dim_index) 5460 { 5461 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 5462 dim_stride = tmpstride[i]; 5463 continue; 5464 } 5465 5466 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 5467 sstride[n] = tmpstride[i]; 5468 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5469 n += 1; 5470 } 5471 5472 done = resultsize <= 0; 5473 base = arrayvec; 5474 dest = resultvec; 5475 while (!done) 5476 { 5477 gfc_expr *ex; 5478 ex = gfc_copy_expr (extremum); 5479 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5480 { 5481 if (*src && min_max_choose (*src, ex, sign, back_val) > 0) 5482 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1); 5483 } 5484 5485 count[0]++; 5486 base += sstride[0]; 5487 dest += dstride[0]; 5488 gfc_free_expr (ex); 5489 5490 n = 0; 5491 while (!done && count[n] == extent[n]) 5492 { 5493 count[n] = 0; 5494 base -= sstride[n] * extent[n]; 5495 dest -= dstride[n] * extent[n]; 5496 5497 n++; 5498 if (n < result->rank) 5499 { 5500 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5501 times, we'd warn for the last iteration, because the 5502 array index will have already been incremented to the 5503 array sizes, and we can't tell that this must make 5504 the test against result->rank false, because ranks 5505 must not exceed GFC_MAX_DIMENSIONS. */ 5506 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5507 count[n]++; 5508 base += sstride[n]; 5509 dest += dstride[n]; 5510 GCC_DIAGNOSTIC_POP 5511 } 5512 else 5513 done = true; 5514 } 5515 } 5516 5517 /* Place updated expression in result constructor. */ 5518 result_ctor = gfc_constructor_first (result->value.constructor); 5519 for (i = 0; i < resultsize; ++i) 5520 { 5521 result_ctor->expr = resultvec[i]; 5522 result_ctor = gfc_constructor_next (result_ctor); 5523 } 5524 5525 free (arrayvec); 5526 free (resultvec); 5527 free (extremum); 5528 return result; 5529} 5530 5531/* Simplify minloc and maxloc for constant arrays. */ 5532 5533static gfc_expr * 5534gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 5535 gfc_expr *kind, gfc_expr *back, int sign) 5536{ 5537 gfc_expr *result; 5538 gfc_expr *extremum; 5539 int ikind; 5540 int init_val; 5541 bool back_val = false; 5542 5543 if (!is_constant_array_expr (array)

←

Assuming the condition is false

→

5544 || !gfc_is_constant_expr (dim))

←

Assuming the condition is false

→

5545 return NULL__null; 5546 5547 if (mask

←

Assuming 'mask' is non-null

→

5548 && !is_constant_array_expr (mask)

←

Assuming the condition is false

→

5549 && mask->expr_type != EXPR_CONSTANT) 5550 return NULL__null; 5551 5552 if (kind)

←

Assuming 'kind' is null

→

←

Taking false branch

→

5553 { 5554 if (gfc_extract_int (kind, &ikind, -1)) 5555 return NULL__null; 5556 } 5557 else 5558 ikind = gfc_default_integer_kind; 5559 5560 if (back)

←

Assuming 'back' is null

→

←

Taking false branch

→

5561 { 5562 if (back->expr_type != EXPR_CONSTANT) 5563 return NULL__null; 5564 5565 back_val = back->value.logical; 5566 } 5567 5568 if (sign

9.1	'sign' is >= 0

< 0)

←

Taking false branch

→

5569 init_val = INT_MAX2147483647; 5570 else if (sign

10.1	'sign' is > 0

> 0)

←

Taking true branch

→

5571 init_val = INT_MIN(-2147483647 -1); 5572 else 5573 gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 5573, __FUNCTION__)); 5574 5575 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); 5576 init_result_expr (extremum, init_val, array); 5577 5578 if (dim)

←

Assuming 'dim' is null

→

←

Taking false branch

→

5579 { 5580 result = transformational_result (array, dim, BT_INTEGER, 5581 ikind, &array->where); 5582 init_result_expr (result, 0, array); 5583 5584 if (array->rank == 1) 5585 return simplify_minmaxloc_to_scalar (result, array, mask, extremum, 5586 sign, back_val); 5587 else 5588 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, 5589 sign, back_val); 5590 } 5591 else 5592 { 5593 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5594 return simplify_minmaxloc_nodim (result, extremum, array, mask,

←

Calling 'simplify_minmaxloc_nodim'

→

5595 sign, back_val); 5596 } 5597} 5598 5599gfc_expr * 5600gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5601 gfc_expr *back) 5602{ 5603 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); 5604} 5605 5606gfc_expr * 5607gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5608 gfc_expr *back) 5609{ 5610 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);

Calling 'gfc_simplify_minmaxloc'

→

5611} 5612 5613/* Simplify findloc to scalar. Similar to 5614 simplify_minmaxloc_to_scalar. */ 5615 5616static gfc_expr * 5617simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5618 gfc_expr *mask, int back_val) 5619{ 5620 gfc_expr *a, *m; 5621 gfc_constructor *array_ctor, *mask_ctor; 5622 mpz_t count; 5623 5624 mpz_set_si__gmpz_set_si (result->value.integer, 0); 5625 5626 /* Shortcut for constant .FALSE. MASK. */ 5627 if (mask 5628 && mask->expr_type == EXPR_CONSTANT 5629 && !mask->value.logical) 5630 return result; 5631 5632 array_ctor = gfc_constructor_first (array->value.constructor); 5633 if (mask && mask->expr_type == EXPR_ARRAY) 5634 mask_ctor = gfc_constructor_first (mask->value.constructor); 5635 else 5636 mask_ctor = NULL__null; 5637 5638 mpz_init_set_si__gmpz_init_set_si (count, 0); 5639 while (array_ctor) 5640 { 5641 mpz_add_ui__gmpz_add_ui (count, count, 1); 5642 a = array_ctor->expr; 5643 array_ctor = gfc_constructor_next (array_ctor); 5644 /* A constant MASK equals .TRUE. here and can be ignored. */ 5645 if (mask_ctor) 5646 { 5647 m = mask_ctor->expr; 5648 mask_ctor = gfc_constructor_next (mask_ctor); 5649 if (!m->value.logical) 5650 continue; 5651 } 5652 if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5653 { 5654 /* We have a match. If BACK is true, continue so we find 5655 the last one. */ 5656 mpz_set__gmpz_set (result->value.integer, count); 5657 if (!back_val) 5658 break; 5659 } 5660 } 5661 mpz_clear__gmpz_clear (count); 5662 return result; 5663} 5664 5665/* Simplify findloc in the absence of a dim argument. Similar to 5666 simplify_minmaxloc_nodim. */ 5667 5668static gfc_expr * 5669simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array, 5670 gfc_expr *mask, bool back_val) 5671{ 5672 ssize_t res[GFC_MAX_DIMENSIONS15]; 5673 int i, n; 5674 gfc_constructor *result_ctor, *array_ctor, *mask_ctor; 5675 ssize_t count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5676 sstride[GFC_MAX_DIMENSIONS15]; 5677 gfc_expr *a, *m; 5678 bool continue_loop; 5679 bool ma; 5680 5681 for (i = 0; i < array->rank; i++) 5682 res[i] = -1; 5683 5684 /* Shortcut for constant .FALSE. MASK. */ 5685 if (mask 5686 && mask->expr_type == EXPR_CONSTANT 5687 && !mask->value.logical) 5688 goto finish; 5689 5690 for (i = 0; i < array->rank; i++) 5691 { 5692 count[i] = 0; 5693 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5694 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]); 5695 if (extent[i] <= 0) 5696 goto finish; 5697 } 5698 5699 continue_loop = true; 5700 array_ctor = gfc_constructor_first (array->value.constructor); 5701 if (mask && mask->rank > 0) 5702 mask_ctor = gfc_constructor_first (mask->value.constructor); 5703 else 5704 mask_ctor = NULL__null; 5705 5706 /* Loop over the array elements (and mask), keeping track of 5707 the indices to return. */ 5708 while (continue_loop) 5709 { 5710 do 5711 { 5712 a = array_ctor->expr; 5713 if (mask_ctor) 5714 { 5715 m = mask_ctor->expr; 5716 ma = m->value.logical; 5717 mask_ctor = gfc_constructor_next (mask_ctor); 5718 } 5719 else 5720 ma = true; 5721 5722 if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0) 5723 { 5724 for (i = 0; i < array->rank; i++) 5725 res[i] = count[i]; 5726 if (!back_val) 5727 goto finish; 5728 } 5729 array_ctor = gfc_constructor_next (array_ctor); 5730 count[0] ++; 5731 } while (count[0] != extent[0]); 5732 n = 0; 5733 do 5734 { 5735 /* When we get to the end of a dimension, reset it and increment 5736 the next dimension. */ 5737 count[n] = 0; 5738 n++; 5739 if (n >= array->rank) 5740 { 5741 continue_loop = false; 5742 break; 5743 } 5744 else 5745 count[n] ++; 5746 } while (count[n] == extent[n]); 5747 } 5748 5749finish: 5750 result_ctor = gfc_constructor_first (result->value.constructor); 5751 for (i = 0; i < array->rank; i++) 5752 { 5753 gfc_expr *r_expr; 5754 r_expr = result_ctor->expr; 5755 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1); 5756 result_ctor = gfc_constructor_next (result_ctor); 5757 } 5758 return result; 5759} 5760 5761 5762/* Simplify findloc to an array. Similar to 5763 simplify_minmaxloc_to_array. */ 5764 5765static gfc_expr * 5766simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value, 5767 gfc_expr *dim, gfc_expr *mask, bool back_val) 5768{ 5769 mpz_t size; 5770 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5771 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5772 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5773 5774 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5775 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15], 5776 tmpstride[GFC_MAX_DIMENSIONS15]; 5777 5778 /* Shortcut for constant .FALSE. MASK. */ 5779 if (mask 5780 && mask->expr_type == EXPR_CONSTANT 5781 && !mask->value.logical) 5782 return result; 5783 5784 /* Build an indexed table for array element expressions to minimize 5785 linked-list traversal. Masked elements are set to NULL. */ 5786 gfc_array_size (array, &size); 5787 arraysize = mpz_get_ui__gmpz_get_ui (size); 5788 mpz_clear__gmpz_clear (size); 5789 5790 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 5791 5792 array_ctor = gfc_constructor_first (array->value.constructor); 5793 mask_ctor = NULL__null; 5794 if (mask && mask->expr_type == EXPR_ARRAY) 5795 mask_ctor = gfc_constructor_first (mask->value.constructor); 5796 5797 for (i = 0; i < arraysize; ++i) 5798 { 5799 arrayvec[i] = array_ctor->expr; 5800 array_ctor = gfc_constructor_next (array_ctor); 5801 5802 if (mask_ctor) 5803 { 5804 if (!mask_ctor->expr->value.logical) 5805 arrayvec[i] = NULL__null; 5806 5807 mask_ctor = gfc_constructor_next (mask_ctor); 5808 } 5809 } 5810 5811 /* Same for the result expression. */ 5812 gfc_array_size (result, &size); 5813 resultsize = mpz_get_ui__gmpz_get_ui (size); 5814 mpz_clear__gmpz_clear (size); 5815 5816 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 5817 result_ctor = gfc_constructor_first (result->value.constructor); 5818 for (i = 0; i < resultsize; ++i) 5819 { 5820 resultvec[i] = result_ctor->expr; 5821 result_ctor = gfc_constructor_next (result_ctor); 5822 } 5823 5824 gfc_extract_int (dim, &dim_index); 5825 5826 dim_index -= 1; /* Zero-base index. */ 5827 dim_extent = 0; 5828 dim_stride = 0; 5829 5830 for (i = 0, n = 0; i < array->rank; ++i) 5831 { 5832 count[i] = 0; 5833 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5834 if (i == dim_index) 5835 { 5836 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 5837 dim_stride = tmpstride[i]; 5838 continue; 5839 } 5840 5841 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 5842 sstride[n] = tmpstride[i]; 5843 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5844 n += 1; 5845 } 5846 5847 done = resultsize <= 0; 5848 base = arrayvec; 5849 dest = resultvec; 5850 while (!done) 5851 { 5852 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5853 { 5854 if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0) 5855 { 5856 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1); 5857 if (!back_val) 5858 break; 5859 } 5860 } 5861 5862 count[0]++; 5863 base += sstride[0]; 5864 dest += dstride[0]; 5865 5866 n = 0; 5867 while (!done && count[n] == extent[n]) 5868 { 5869 count[n] = 0; 5870 base -= sstride[n] * extent[n]; 5871 dest -= dstride[n] * extent[n]; 5872 5873 n++; 5874 if (n < result->rank) 5875 { 5876 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5877 times, we'd warn for the last iteration, because the 5878 array index will have already been incremented to the 5879 array sizes, and we can't tell that this must make 5880 the test against result->rank false, because ranks 5881 must not exceed GFC_MAX_DIMENSIONS. */ 5882 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5883 count[n]++; 5884 base += sstride[n]; 5885 dest += dstride[n]; 5886 GCC_DIAGNOSTIC_POP 5887 } 5888 else 5889 done = true; 5890 } 5891 } 5892 5893 /* Place updated expression in result constructor. */ 5894 result_ctor = gfc_constructor_first (result->value.constructor); 5895 for (i = 0; i < resultsize; ++i) 5896 { 5897 result_ctor->expr = resultvec[i]; 5898 result_ctor = gfc_constructor_next (result_ctor); 5899 } 5900 5901 free (arrayvec); 5902 free (resultvec); 5903 return result; 5904} 5905 5906/* Simplify findloc. */ 5907 5908gfc_expr * 5909gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim, 5910 gfc_expr *mask, gfc_expr *kind, gfc_expr *back) 5911{ 5912 gfc_expr *result; 5913 int ikind; 5914 bool back_val = false; 5915 5916 if (!is_constant_array_expr (array) 5917 || array->shape == NULL__null 5918 || !gfc_is_constant_expr (dim)) 5919 return NULL__null; 5920 5921 if (! gfc_is_constant_expr (value)) 5922 return 0; 5923 5924 if (mask 5925 && !is_constant_array_expr (mask) 5926 && mask->expr_type != EXPR_CONSTANT) 5927 return NULL__null; 5928 5929 if (kind) 5930 { 5931 if (gfc_extract_int (kind, &ikind, -1)) 5932 return NULL__null; 5933 } 5934 else 5935 ikind = gfc_default_integer_kind; 5936 5937 if (back) 5938 { 5939 if (back->expr_type != EXPR_CONSTANT) 5940 return NULL__null; 5941 5942 back_val = back->value.logical; 5943 } 5944 5945 if (dim) 5946 { 5947 result = transformational_result (array, dim, BT_INTEGER, 5948 ikind, &array->where); 5949 init_result_expr (result, 0, array); 5950 5951 if (array->rank == 1) 5952 return simplify_findloc_to_scalar (result, array, value, mask, 5953 back_val); 5954 else 5955 return simplify_findloc_to_array (result, array, value, dim, mask, 5956 back_val); 5957 } 5958 else 5959 { 5960 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5961 return simplify_findloc_nodim (result, value, array, mask, back_val); 5962 } 5963 return NULL__null; 5964} 5965 5966gfc_expr * 5967gfc_simplify_maxexponent (gfc_expr *x) 5968{ 5969 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5970 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5971 gfc_real_kinds[i].max_exponent); 5972} 5973 5974 5975gfc_expr * 5976gfc_simplify_minexponent (gfc_expr *x) 5977{ 5978 int i = gfc_validate_kind (BT_REAL, x->ts.kind, false); 5979 return gfc_get_int_expr (gfc_default_integer_kind, &x->where, 5980 gfc_real_kinds[i].min_exponent); 5981} 5982 5983 5984gfc_expr * 5985gfc_simplify_mod (gfc_expr *a, gfc_expr *p) 5986{ 5987 gfc_expr *result; 5988 int kind; 5989 5990 /* First check p. */ 5991 if (p->expr_type != EXPR_CONSTANT) 5992 return NULL__null; 5993 5994 /* p shall not be 0. */ 5995 switch (p->ts.type) 5996 { 5997 case BT_INTEGER: 5998 if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value
.integer)->_mp_size < 0 ? -1 : (p->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0)) == 0) 5999 { 6000 gfc_error ("Argument %qs of MOD at %L shall not be zero", 6001 "P", &p->where); 6002 return &gfc_bad_expr; 6003 } 6004 break; 6005 case BT_REAL: 6006 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0) 6007 { 6008 gfc_error ("Argument %qs of MOD at %L shall not be zero", 6009 "P", &p->where); 6010 return &gfc_bad_expr; 6011 } 6012 break; 6013 default: 6014 gfc_internal_error ("gfc_simplify_mod(): Bad arguments"); 6015 } 6016 6017 if (a->expr_type != EXPR_CONSTANT) 6018 return NULL__null; 6019 6020 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 6021 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 6022 6023 if (a->ts.type == BT_INTEGER) 6024 mpz_tdiv_r__gmpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer); 6025 else 6026 { 6027 gfc_set_model_kind (kind); 6028 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6029 GFC_RND_MODEMPFR_RNDN); 6030 } 6031 6032 return range_check (result, "MOD"); 6033} 6034 6035 6036gfc_expr * 6037gfc_simplify_modulo (gfc_expr *a, gfc_expr *p) 6038{ 6039 gfc_expr *result; 6040 int kind; 6041 6042 /* First check p. */ 6043 if (p->expr_type != EXPR_CONSTANT) 6044 return NULL__null; 6045 6046 /* p shall not be 0. */ 6047 switch (p->ts.type) 6048 { 6049 case BT_INTEGER: 6050 if (mpz_cmp_ui (p->value.integer, 0)(__builtin_constant_p (0) && (0) == 0 ? ((p->value
.integer)->_mp_size < 0 ? -1 : (p->value.integer)->
_mp_size > 0) : __gmpz_cmp_ui (p->value.integer,0)) == 0) 6051 { 6052 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6053 "P", &p->where); 6054 return &gfc_bad_expr; 6055 } 6056 break; 6057 case BT_REAL: 6058 if (mpfr_cmp_ui (p->value.real, 0)mpfr_cmp_ui_2exp((p->value.real),(0),0) == 0) 6059 { 6060 gfc_error ("Argument %qs of MODULO at %L shall not be zero", 6061 "P", &p->where); 6062 return &gfc_bad_expr; 6063 } 6064 break; 6065 default: 6066 gfc_internal_error ("gfc_simplify_modulo(): Bad arguments"); 6067 } 6068 6069 if (a->expr_type != EXPR_CONSTANT) 6070 return NULL__null; 6071 6072 kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind; 6073 result = gfc_get_constant_expr (a->ts.type, kind, &a->where); 6074 6075 if (a->ts.type == BT_INTEGER) 6076 mpz_fdiv_r__gmpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer); 6077 else 6078 { 6079 gfc_set_model_kind (kind); 6080 mpfr_fmod (result->value.real, a->value.real, p->value.real, 6081 GFC_RND_MODEMPFR_RNDN); 6082 if (mpfr_cmp_ui (result->value.real, 0)mpfr_cmp_ui_2exp((result->value.real),(0),0) != 0) 6083 { 6084 if (mpfr_signbit (a->value.real)((0 ? (((((mpfr_srcptr) (0 ? (a->value.real) : (mpfr_srcptr
) (a->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) (
0 ? (a->value.real) : (mpfr_srcptr) (a->value.real))))->
_mpfr_sign))) < 0) != mpfr_signbit (p->value.real)((0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr
) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) (
0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))->
_mpfr_sign))) < 0)) 6085 mpfr_add (result->value.real, result->value.real, p->value.real, 6086 GFC_RND_MODEMPFR_RNDN); 6087 } 6088 else 6089 mpfr_copysign (result->value.real, result->value.real,mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,(0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr
) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) (
0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))->
_mpfr_sign)))) 6090 p->value.real, GFC_RND_MODE)mpfr_set4(result->value.real,result->value.real,MPFR_RNDN
,(0 ? (((((mpfr_srcptr) (0 ? (p->value.real) : (mpfr_srcptr
) (p->value.real))))->_mpfr_sign)) : (((((mpfr_srcptr) (
0 ? (p->value.real) : (mpfr_srcptr) (p->value.real))))->
_mpfr_sign)))); 6091 } 6092 6093 return range_check (result, "MODULO"); 6094} 6095 6096 6097gfc_expr * 6098gfc_simplify_nearest (gfc_expr *x, gfc_expr *s) 6099{ 6100 gfc_expr *result; 6101 mpfr_exp_t emin, emax; 6102 int kind; 6103 6104 if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT) 6105 return NULL__null; 6106 6107 result = gfc_copy_expr (x); 6108 6109 /* Save current values of emin and emax. */ 6110 emin = mpfr_get_emin (); 6111 emax = mpfr_get_emax (); 6112 6113 /* Set emin and emax for the current model number. */ 6114 kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0); 6115 mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent - 6116 mpfr_get_prec(result->value.real)(0 ? (((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr
) (result->value.real)))->_mpfr_prec) : (((mpfr_srcptr)
(0 ? (result->value.real) : (mpfr_srcptr) (result->value
.real)))->_mpfr_prec)) + 1); 6117 mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent); 6118 mpfr_check_range (result->value.real, 0, MPFR_RNDU); 6119 6120 if (mpfr_sgn (s->value.real)((s->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (s->
value.real) : (mpfr_srcptr) (s->value.real)))->_mpfr_exp
== (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
() : (mpfr_void) 0), 0 : ((s->value.real)->_mpfr_sign)
) > 0) 6121 { 6122 mpfr_nextabove (result->value.real); 6123 mpfr_subnormalize (result->value.real, 0, MPFR_RNDU); 6124 } 6125 else 6126 { 6127 mpfr_nextbelow (result->value.real); 6128 mpfr_subnormalize (result->value.real, 0, MPFR_RNDD); 6129 } 6130 6131 mpfr_set_emin (emin); 6132 mpfr_set_emax (emax); 6133 6134 /* Only NaN can occur. Do not use range check as it gives an 6135 error for denormal numbers. */ 6136 if (mpfr_nan_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) (
result->value.real)))->_mpfr_exp == (1 - ((mpfr_exp_t) (
((mpfr_uexp_t) -1) >> 1)))) && flag_range_checkglobal_options.x_flag_range_check) 6137 { 6138 gfc_error ("Result of NEAREST is NaN at %L", &result->where); 6139 gfc_free_expr (result); 6140 return &gfc_bad_expr; 6141 } 6142 6143 return result; 6144} 6145 6146 6147static gfc_expr * 6148simplify_nint (const char *name, gfc_expr *e, gfc_expr *k) 6149{ 6150 gfc_expr *itrunc, *result; 6151 int kind; 6152 6153 kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind); 6154 if (kind == -1) 6155 return &gfc_bad_expr; 6156 6157 if (e->expr_type != EXPR_CONSTANT) 6158 return NULL__null; 6159 6160 itrunc = gfc_copy_expr (e); 6161 mpfr_round (itrunc->value.real, e->value.real)mpfr_rint((itrunc->value.real), (e->value.real), MPFR_RNDNA
); 6162 6163 result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where); 6164 gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where); 6165 6166 gfc_free_expr (itrunc); 6167 6168 return range_check (result, name); 6169} 6170 6171 6172gfc_expr * 6173gfc_simplify_new_line (gfc_expr *e) 6174{ 6175 gfc_expr *result; 6176 6177 result = gfc_get_character_expr (e->ts.kind, &e->where, NULL__null, 1); 6178 result->value.character.string[0] = '\n'; 6179 6180 return result; 6181} 6182 6183 6184gfc_expr * 6185gfc_simplify_nint (gfc_expr *e, gfc_expr *k) 6186{ 6187 return simplify_nint ("NINT", e, k); 6188} 6189 6190 6191gfc_expr * 6192gfc_simplify_idnint (gfc_expr *e) 6193{ 6194 return simplify_nint ("IDNINT", e, NULL__null); 6195} 6196 6197static int norm2_scale; 6198 6199static gfc_expr * 6200norm2_add_squared (gfc_expr *result, gfc_expr *e) 6201{ 6202 mpfr_t tmp; 6203 6204 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6204, __FUNCTION__), 0 : 0)); 6205 gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6206, __FUNCTION__), 0 : 0)) 6206 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6206, __FUNCTION__), 0 : 0)); 6207 6208 gfc_set_model_kind (result->ts.kind); 6209 int index = gfc_validate_kind (BT_REAL, result->ts.kind, false); 6210 mpfr_exp_t exp; 6211 if (mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) (
result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))) 6212 { 6213 exp = mpfr_get_exp (result->value.real)(0 ? (((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr
) (result->value.real)))->_mpfr_exp) : (((mpfr_srcptr) (
0 ? (result->value.real) : (mpfr_srcptr) (result->value
.real)))->_mpfr_exp)); 6214 /* If result is getting close to overflowing, scale down. */ 6215 if (exp >= gfc_real_kinds[index].max_exponent - 4 6216 && norm2_scale <= gfc_real_kinds[index].max_exponent - 2) 6217 { 6218 norm2_scale += 2; 6219 mpfr_div_ui (result->value.real, result->value.real, 16, 6220 GFC_RND_MODEMPFR_RNDN); 6221 } 6222 } 6223 6224 mpfr_init (tmp); 6225 if (mpfr_regular_p (e->value.real)(((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) (e->
value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1))))) 6226 { 6227 exp = mpfr_get_exp (e->value.real)(0 ? (((mpfr_srcptr) (0 ? (e->value.real) : (mpfr_srcptr) (
e->value.real)))->_mpfr_exp) : (((mpfr_srcptr) (0 ? (e->
value.real) : (mpfr_srcptr) (e->value.real)))->_mpfr_exp
)); 6228 /* If e**2 would overflow or close to overflowing, scale down. */ 6229 if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2) 6230 { 6231 int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4; 6232 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6233 mpfr_set_exp (tmp, new_scale - norm2_scale); 6234 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6235 mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6236 norm2_scale = new_scale; 6237 } 6238 } 6239 if (norm2_scale) 6240 { 6241 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6242 mpfr_set_exp (tmp, norm2_scale); 6243 mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6244 } 6245 else 6246 mpfr_set (tmp, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4
(tmp,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }); 6247 mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODEMPFR_RNDN); 6248 mpfr_add (result->value.real, result->value.real, tmp, 6249 GFC_RND_MODEMPFR_RNDN); 6250 mpfr_clear (tmp); 6251 6252 return result; 6253} 6254 6255 6256static gfc_expr * 6257norm2_do_sqrt (gfc_expr *result, gfc_expr *e) 6258{ 6259 gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT)((void)(!(e->ts.type == BT_REAL && e->expr_type
== EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6259, __FUNCTION__), 0 : 0)); 6260 gcc_assert (result->ts.type == BT_REAL((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6261, __FUNCTION__), 0 : 0)) 6261 && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_REAL && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6261, __FUNCTION__), 0 : 0)); 6262 6263 if (result != e) 6264 mpfr_set (result->value.real, e->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (e->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
); 6265 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN); 6266 if (norm2_scale && mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) (
result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))) 6267 { 6268 mpfr_t tmp; 6269 mpfr_init (tmp); 6270 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6271 mpfr_set_exp (tmp, norm2_scale); 6272 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6273 mpfr_clear (tmp); 6274 } 6275 norm2_scale = 0; 6276 6277 return result; 6278} 6279 6280 6281gfc_expr * 6282gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim) 6283{ 6284 gfc_expr *result; 6285 bool size_zero; 6286 6287 size_zero = gfc_is_size_zero_array (e); 6288 6289 if (!(is_constant_array_expr (e) || size_zero) 6290 || (dim != NULL__null && !gfc_is_constant_expr (dim))) 6291 return NULL__null; 6292 6293 result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where); 6294 init_result_expr (result, 0, NULL__null); 6295 6296 if (size_zero) 6297 return result; 6298 6299 norm2_scale = 0; 6300 if (!dim || e->rank == 1) 6301 { 6302 result = simplify_transformation_to_scalar (result, e, NULL__null, 6303 norm2_add_squared); 6304 mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODEMPFR_RNDN); 6305 if (norm2_scale && mpfr_regular_p (result->value.real)(((mpfr_srcptr) (0 ? (result->value.real) : (mpfr_srcptr) (
result->value.real)))->_mpfr_exp > (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))) 6306 { 6307 mpfr_t tmp; 6308 mpfr_init (tmp); 6309 mpfr_set_ui (tmp, 1, GFC_RND_MODEMPFR_RNDN); 6310 mpfr_set_exp (tmp, norm2_scale); 6311 mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODEMPFR_RNDN); 6312 mpfr_clear (tmp); 6313 } 6314 norm2_scale = 0; 6315 } 6316 else 6317 result = simplify_transformation_to_array (result, e, dim, NULL__null, 6318 norm2_add_squared, 6319 norm2_do_sqrt); 6320 6321 return result; 6322} 6323 6324 6325gfc_expr * 6326gfc_simplify_not (gfc_expr *e) 6327{ 6328 gfc_expr *result; 6329 6330 if (e->expr_type != EXPR_CONSTANT) 6331 return NULL__null; 6332 6333 result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where); 6334 mpz_com__gmpz_com (result->value.integer, e->value.integer); 6335 6336 return range_check (result, "NOT"); 6337} 6338 6339 6340gfc_expr * 6341gfc_simplify_null (gfc_expr *mold) 6342{ 6343 gfc_expr *result; 6344 6345 if (mold) 6346 { 6347 result = gfc_copy_expr (mold); 6348 result->expr_type = EXPR_NULL; 6349 } 6350 else 6351 result = gfc_get_null_expr (NULL__null); 6352 6353 return result; 6354} 6355 6356 6357gfc_expr * 6358gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED__attribute__ ((__unused__)), gfc_expr *failed) 6359{ 6360 gfc_expr *result; 6361 6362 if (flag_coarrayglobal_options.x_flag_coarray == GFC_FCOARRAY_NONE) 6363 { 6364 gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable"); 6365 return &gfc_bad_expr; 6366 } 6367 6368 if (flag_coarrayglobal_options.x_flag_coarray != GFC_FCOARRAY_SINGLE) 6369 return NULL__null; 6370 6371 if (failed && failed->expr_type != EXPR_CONSTANT) 6372 return NULL__null; 6373 6374 /* FIXME: gfc_current_locus is wrong. */ 6375 result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind, 6376 &gfc_current_locus); 6377 6378 if (failed && failed->value.logical != 0) 6379 mpz_set_si__gmpz_set_si (result->value.integer, 0); 6380 else 6381 mpz_set_si__gmpz_set_si (result->value.integer, 1); 6382 6383 return result; 6384} 6385 6386 6387gfc_expr * 6388gfc_simplify_or (gfc_expr *x, gfc_expr *y) 6389{ 6390 gfc_expr *result; 6391 int kind; 6392 6393 if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT) 6394 return NULL__null; 6395 6396 kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind; 6397 6398 switch (x->ts.type) 6399 { 6400 case BT_INTEGER: 6401 result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where); 6402 mpz_ior__gmpz_ior (result->value.integer, x->value.integer, y->value.integer); 6403 return range_check (result, "OR"); 6404 6405 case BT_LOGICAL: 6406 return gfc_get_logical_expr (kind, &x->where, 6407 x->value.logical || y->value.logical); 6408 default: 6409 gcc_unreachable()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.cc"
, 6409, __FUNCTION__)); 6410 } 6411} 6412 6413 6414gfc_expr * 6415gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector) 6416{ 6417 gfc_expr *result; 6418 gfc_constructor *array_ctor, *mask_ctor, *vector_ctor; 6419 6420