/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c

Bug Summary

File:	build/gcc/fortran/simplify.c
Warning:	line 5258, 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-unknown-linux-gnu -analyze -disable-free -disable-llvm-verifier -discard-value-names -main-file-name simplify.c -analyzer-store=region -analyzer-opt-analyze-nested-blocks -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 -fno-rounding-math -mconstructor-aliases -munwind-tables -target-cpu x86-64 -fno-split-dwarf-inlining -debugger-tuning=gdb -resource-dir /usr/lib64/clang/11.0.0 -D IN_GCC_FRONTEND -D IN_GCC -D HAVE_CONFIG_H -I . -I fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcpp/include -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libcody -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libdecnumber/bid -I ../libdecnumber -I /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/../libbacktrace -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10 -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/x86_64-suse-linux -internal-isystem /usr/bin/../lib64/gcc/x86_64-suse-linux/10/../../../../include/c++/10/backward -internal-isystem /usr/local/include -internal-isystem /usr/lib64/clang/11.0.0/include -internal-externc-isystem /include -internal-externc-isystem /usr/include -O2 -Wno-narrowing -Wwrite-strings -Wno-error=format-diag -Wno-long-long -Wno-variadic-macros -Wno-overlength-strings -fdeprecated-macro -fdebug-compilation-dir /home/marxin/BIG/buildbot/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 -o /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/objdir/clang-static-analyzer/2021-01-16-135054-17580-1/report-YNtGs6.plist -x c++ /home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c

1/* Simplify intrinsic functions at compile-time.
 Copyright (C) 2000-2021 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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 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;

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

275/* Test for a size zero array.  */
276bool
277gfc_is_size_zero_array (gfc_expr *array)
278{

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


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

303static void
304init_result_expr (gfc_expr *e, int init, gfc_expr *array)
305{
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)mpfr_set4(e->value.real,gfc_real_kinds[i].huge,MPFR_RNDN,(
(gfc_real_kinds[i].huge)->_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)mpfr_set4(e->value.real,gfc_real_kinds[i].huge,MPFR_RNDN,(
(gfc_real_kinds[i].huge)->_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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 379, __FUNCTION__));
}
  }
else
  gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 383, __FUNCTION__));
384}


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

390static gfc_expr *
391compute_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)
394{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 431, __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;
442}


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

448static gfc_expr *
449transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
	 int kind, locus* where)
451{
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;
476}


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

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

487static gfc_expr *
488gfc_count (gfc_expr *op1, gfc_expr *op2)
489{
gfc_expr *result;

gcc_assert (op1->ts.type == BT_INTEGER)((void)(!(op1->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 492, __FUNCTION__), 0 : 0));
gcc_assert (op2->ts.type == BT_LOGICAL)((void)(!(op2->ts.type == BT_LOGICAL) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 493, __FUNCTION__), 0 : 0));
gcc_assert (op2->value.logical)((void)(!(op2->value.logical) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 494, __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;
502}


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

513static gfc_expr *
514simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
		   transformational_op op)
516{
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;
551}

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

562static gfc_expr *
563simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
		  gfc_expr *mask, transformational_op op,
		  transformational_op post_op)
566{
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;
698}


701static gfc_expr *
702simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
	 int init_val, transformational_op op)
704{
gfc_expr *result;
bool size_zero;

size_zero = gfc_is_size_zero_array (array);

if (!(is_constant_array_expr (array) || size_zero)
    || !gfc_is_constant_expr (dim))
  return NULL__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);
729}


732/********************** Simplification functions *****************************/

734gfc_expr *
735gfc_simplify_abs (gfc_expr *e)
736{
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");
  }
763}


766static gfc_expr *
767simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
768{
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;
816}



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

823gfc_expr *
824gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
825{
return simplify_achar_char (e, k, "ACHAR", true);
827}


830gfc_expr *
831gfc_simplify_acos (gfc_expr *x)
832{
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");
862}

864gfc_expr *
865gfc_simplify_acosh (gfc_expr *x)
866{
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");
896}

898gfc_expr *
899gfc_simplify_adjustl (gfc_expr *e)
900{
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;
923}


926gfc_expr *
927gfc_simplify_adjustr (gfc_expr *e)
928{
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;
954}


957gfc_expr *
958gfc_simplify_aimag (gfc_expr *e)
959{
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)mpfr_set4(result->value.real,((e->value.complex)->im
),MPFR_RNDN,((((e->value.complex)->im))->_mpfr_sign)
);

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


972gfc_expr *
973gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
974{
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");
993}


996gfc_expr *
997gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
998{
return simplify_transformation (mask, dim, NULL__null, true, gfc_and);
1000}


1003gfc_expr *
1004gfc_simplify_dint (gfc_expr *e)
1005{
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");
1019}


1022gfc_expr *
1023gfc_simplify_dreal (gfc_expr *e)
1024{
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");
1034}


1037gfc_expr *
1038gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
1039{
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");
1054}


1057gfc_expr *
1058gfc_simplify_and (gfc_expr *x, gfc_expr *y)
1059{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1080, __FUNCTION__));
  }
1082}


1085gfc_expr *
1086gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
1087{
return simplify_transformation (mask, dim, NULL__null, false, gfc_or);
1089}


1092gfc_expr *
1093gfc_simplify_dnint (gfc_expr *e)
1094{
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");
1104}


1107gfc_expr *
1108gfc_simplify_asin (gfc_expr *x)
1109{
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");
1139}


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

1144static void
1145rad2deg (mpfr_t x)
1146{
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);
1154}


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

1159gfc_expr *
1160gfc_simplify_acosd (gfc_expr *x)
1161{
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");
1180}


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

1185gfc_expr *
1186gfc_simplify_asind (gfc_expr *x)
1187{
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");
1206}


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

1211gfc_expr *
1212gfc_simplify_atand (gfc_expr *x)
1213{
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");
1224}


1227gfc_expr *
1228gfc_simplify_asinh (gfc_expr *x)
1229{
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");
1252}


1255gfc_expr *
1256gfc_simplify_atan (gfc_expr *x)
1257{
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");
1280}


1283gfc_expr *
1284gfc_simplify_atanh (gfc_expr *x)
1285{
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");
1315}


1318gfc_expr *
1319gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
1320{
gfc_expr *result;

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

if (mpfr_zero_p (y->value.real)((y->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) && mpfr_zero_p (x->value.real)((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");
1337}


1340gfc_expr *
1341gfc_simplify_bessel_j0 (gfc_expr *x)
1342{
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");
1352}


1355gfc_expr *
1356gfc_simplify_bessel_j1 (gfc_expr *x)
1357{
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");
1367}


1370gfc_expr *
1371gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
1372{
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");
1384}


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

1389static gfc_expr *
1390gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
	bool jn)
1392{
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)mpfr_set4(e->value.real,last1,MPFR_RNDN,((last1)->_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)mpfr_set4(e->value.real,last2,MPFR_RNDN,((last2)->_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)((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)mpfr_set4(last1,last2,MPFR_RNDN,((last2)->_mpfr_sign));
    mpfr_set (last2, e->value.real, GFC_RND_MODE)mpfr_set4(last2,e->value.real,MPFR_RNDN,((e->value.real
)->_mpfr_sign));
  }

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

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


1569gfc_expr *
1570gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1571{
return gfc_simplify_bessel_n2 (order1, order2, x, true);
1573}


1576gfc_expr *
1577gfc_simplify_bessel_y0 (gfc_expr *x)
1578{
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");
1588}


1591gfc_expr *
1592gfc_simplify_bessel_y1 (gfc_expr *x)
1593{
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");
1603}


1606gfc_expr *
1607gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
1608{
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");
1620}


1623gfc_expr *
1624gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
1625{
return gfc_simplify_bessel_n2 (order1, order2, x, false);
1627}


1630gfc_expr *
1631gfc_simplify_bit_size (gfc_expr *e)
1632{
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);
1636}


1639gfc_expr *
1640gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
1641{
int b;

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

if (gfc_extract_int (bit, &b) || b < 0)
  return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);

return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
	       mpz_tstbit__gmpz_tstbit (e->value.integer, b));
1652}


1655static int
1656compare_bitwise (gfc_expr *i, gfc_expr *j)
1657{
mpz_t x, y;
int k, res;

gcc_assert (i->ts.type == BT_INTEGER)((void)(!(i->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1661, __FUNCTION__), 0 : 0));
gcc_assert (j->ts.type == BT_INTEGER)((void)(!(j->ts.type == BT_INTEGER) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1662, __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;
1676}


1679gfc_expr *
1680gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
1681{
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);
1687}


1690gfc_expr *
1691gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
1692{
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);
1698}


1701gfc_expr *
1702gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
1703{
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);
1709}


1712gfc_expr *
1713gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
1714{
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);
1720}


1723gfc_expr *
1724gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
1725{
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");
1745}


1748gfc_expr *
1749gfc_simplify_char (gfc_expr *e, gfc_expr *k)
1750{
return simplify_achar_char (e, k, "CHAR", false);
1752}


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

1757static gfc_expr *
1758simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
1759{
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),mpfr_set4(((result->value.complex)->im),y->value.real
,MPFR_RNDN,((y->value.real)->_mpfr_sign))
  y->value.real, GFC_RND_MODE)mpfr_set4(((result->value.complex)->im),y->value.real
,MPFR_RNDN,((y->value.real)->_mpfr_sign));
break;

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

return range_check (result, name);
1806}


1809gfc_expr *
1810gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
1811{
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);
1819}


1822gfc_expr *
1823gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
1824{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 1836, __FUNCTION__));

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


1842gfc_expr *
1843gfc_simplify_conjg (gfc_expr *e)
1844{
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");
1854}


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

1859gfc_expr *
1860gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
1861{
gfc_expr *result;

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

if (mpfr_zero_p (y->value.real)((y->value.real)->_mpfr_exp == (0 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) && mpfr_zero_p (x->value.real)((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");
1879}


1882gfc_expr *
1883gfc_simplify_cos (gfc_expr *x)
1884{
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");
1908}


1911static void
1912deg2rad (mpfr_t x)
1913{
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);
1921}


1924/* Simplification routines for SIND, COSD, TAND.  */
1925#include "trigd_fe.inc"


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

1930gfc_expr *
1931gfc_simplify_cosd (gfc_expr *x)
1932{
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)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign));
simplify_cosd (result->value.real);

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


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

1948gfc_expr *
1949gfc_simplify_sind (gfc_expr *x)
1950{
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)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign));
simplify_sind (result->value.real);

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


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

1966gfc_expr *
1967gfc_simplify_tand (gfc_expr *x)
1968{
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)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_mpfr_sign));
simplify_tand (result->value.real);

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


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

1984gfc_expr *
1985gfc_simplify_cotand (gfc_expr *x)
1986{
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)mpfr_set4(result->value.real,x->value.real,MPFR_RNDN,((
x->value.real)->_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");
2003}


2006gfc_expr *
2007gfc_simplify_cosh (gfc_expr *x)
2008{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2027, __FUNCTION__));
  }

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


2034gfc_expr *
2035gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
2036{
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);
2063}

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

2070gfc_expr *
2071gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
2072{
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;

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

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


2276gfc_expr *
2277gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
2278{
return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
2280}


2283gfc_expr *
2284gfc_simplify_dble (gfc_expr *e)
2285{
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");
2307}


2310gfc_expr *
2311gfc_simplify_digits (gfc_expr *x)
2312{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2329, __FUNCTION__));
  }

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


2336gfc_expr *
2337gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
2338{
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");
2372}


2375gfc_expr*
2376gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
2377{
/* 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);
2393}


2396gfc_expr *
2397gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
2398{
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");
2414}


2417static gfc_expr *
2418simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
      bool right)
2420{
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;
2452}


2455gfc_expr *
2456gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2457{
return simplify_dshift (arg1, arg2, shiftarg, true);
2459}


2462gfc_expr *
2463gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
2464{
return simplify_dshift (arg1, arg2, shiftarg, false);
2466}


2469gfc_expr *
2470gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
   gfc_expr *dim)
2472{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2550, __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;

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

2735gfc_expr *
2736gfc_simplify_erf (gfc_expr *x)
2737{
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");
2747}


2750gfc_expr *
2751gfc_simplify_erfc (gfc_expr *x)
2752{
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");
2762}


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

2767#define MAX_ITER 200
2768#define ARG_LIMIT 12

2770/* 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.  */
2776static void
2777fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
2778{
mpfr_prec_t prec;
mpfr_t a, b;

prec = mpfr_get_default_prec ();
mpfr_set_default_prec (10 * prec);

mpfr_init (a);
mpfr_init (b);

mpfr_set (a, arg, GFC_RND_MODE)mpfr_set4(a,arg,MPFR_RNDN,((arg)->_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)mpfr_set4(res,a,MPFR_RNDN,((a)->_mpfr_sign));
mpfr_set_default_prec (prec);

mpfr_clear (a);
mpfr_clear (b);
2799}

2801/* 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.  */
2811static void
2812asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
2813{
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)mpfr_set4(x,arg,MPFR_RNDN,((arg)->_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)mpfr_set4(u,x,MPFR_RNDN,((x)->_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)mpfr_set4(oldsum,sum,MPFR_RNDN,((sum)->_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)mpfr_set4(w,u,MPFR_RNDN,((u)->_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)mpfr_set4(sumtrunc,sum,MPFR_RNDN,((sum)->_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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 2865, __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)mpfr_set4(res,sum,MPFR_RNDN,((sum)->_mpfr_sign));
mpfr_set_default_prec (prec);

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


2881gfc_expr *
2882gfc_simplify_erfc_scaled (gfc_expr *x)
2883{
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");
2896}

2898#undef MAX_ITER
2899#undef ARG_LIMIT


2902gfc_expr *
2903gfc_simplify_epsilon (gfc_expr *e)
2904{
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)mpfr_set4(result->value.real,gfc_real_kinds[i].epsilon,MPFR_RNDN
,((gfc_real_kinds[i].epsilon)->_mpfr_sign));

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


2917gfc_expr *
2918gfc_simplify_exp (gfc_expr *x)
2919{
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");
2943}


2946gfc_expr *
2947gfc_simplify_exponent (gfc_expr *x)
2948{
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)((x->value.real)->_mpfr_exp == (2 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) || mpfr_nan_p (x->value.real)((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)((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 ? ((x->value.real)->_mpfr_exp) : ((x->value.real)
->_mpfr_exp));
mpz_set_si__gmpz_set_si (result->value.integer, val);

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


2982gfc_expr *
2983gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED__attribute__ ((__unused__)),
		       gfc_expr *kind)
2985{
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;
3010}


3013gfc_expr *
3014gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED__attribute__ ((__unused__)))
3015{
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;
3034}


3037gfc_expr *
3038gfc_simplify_float (gfc_expr *a)
3039{
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");
3048}


3051static bool
3052is_last_ref_vtab (gfc_expr *e)
3053{
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;
3071}


3074gfc_expr *
3075gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
3076{
/* 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;

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


3120gfc_expr *
3121gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
3122{
/* 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));
3141}


3144gfc_expr *
3145gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
3146{
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 ? ((e->value.real)->_mpfr_prec) : ((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");
3167}


3170gfc_expr *
3171gfc_simplify_fraction (gfc_expr *x)
3172{
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)((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");
3192}


3195gfc_expr *
3196gfc_simplify_gamma (gfc_expr *x)
3197{
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");
3207}


3210gfc_expr *
3211gfc_simplify_huge (gfc_expr *e)
3212{
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)mpfr_set4(result->value.real,gfc_real_kinds[i].huge,MPFR_RNDN
,((gfc_real_kinds[i].huge)->_mpfr_sign));
break;

    default:
gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3230, __FUNCTION__));
  }

return result;
3234}


3237gfc_expr *
3238gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
3239{
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");
3248}


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

3254gfc_expr *
3255gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
3256{
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");
3284}


3287static gfc_expr *
3288do_bit_and (gfc_expr *result, gfc_expr *e)
3289{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3290, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3292, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3292, __FUNCTION__), 0 : 0));

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


3299gfc_expr *
3300gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3301{
return simplify_transformation (array, dim, mask, -1, do_bit_and);
3303}


3306static gfc_expr *
3307do_bit_ior (gfc_expr *result, gfc_expr *e)
3308{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3309, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3311, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3311, __FUNCTION__), 0 : 0));

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


3318gfc_expr *
3319gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3320{
return simplify_transformation (array, dim, mask, 0, do_bit_ior);
3322}


3325gfc_expr *
3326gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
3327{
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");
3337}


3340gfc_expr *
3341gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
3342{
gfc_expr *result;
int k, pos;

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

gfc_extract_int (y, &pos);

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

result = gfc_copy_expr (x);

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

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

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

return result;
3364}


3367gfc_expr *
3368gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
3369{
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;

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


3425gfc_expr *
3426gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
3427{
gfc_expr *result;
int k, pos;

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

gfc_extract_int (y, &pos);

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

result = gfc_copy_expr (x);

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

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

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

return result;
3449}


3452gfc_expr *
3453gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
3454{
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");
3477}


3480gfc_expr *
3481gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
3482{
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");
3492}


3495gfc_expr *
3496gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
3497{
gfc_expr *result;
int back, len, lensub;
int i, j, k, count, index = 0, start;

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

if (b != NULL__null && b->value.logical != 0)
  back = 1;
else
  back = 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 (back == 0)
  {
    if (lensub == 0)
{
 mpz_set_si__gmpz_set_si (result->value.integer, 1);
 return result;
}
    else if (lensub == 1)
{
 for (i = 0; i < len; i++)
   {
     for (j = 0; j < lensub; j++)
{
  if (y->value.character.string[j]
      == x->value.character.string[i])
    {
      index = i + 1;
      goto done;
    }
}
   }
}
    else
{
 for (i = 0; i < len; i++)
   {
     for (j = 0; j < lensub; j++)
{
  if (y->value.character.string[j]
      == x->value.character.string[i])
    {
      start = i;
      count = 0;

      for (k = 0; k < lensub; k++)
	{
	  if (y->value.character.string[k]
	      == x->value.character.string[k + start])
	    count++;
	}

      if (count == lensub)
	{
	  index = start + 1;
	  goto done;
	}
    }
}
   }
}

  }
else
  {
    if (lensub == 0)
{
 mpz_set_si__gmpz_set_si (result->value.integer, len + 1);
 return result;
}
    else if (lensub == 1)
{
 for (i = 0; i < len; i++)
   {
     for (j = 0; j < lensub; j++)
{
  if (y->value.character.string[j]
      == x->value.character.string[len - i])
    {
      index = len - i + 1;
      goto done;
    }
}
   }
}
    else
{
 for (i = 0; i < len; i++)
   {
     for (j = 0; j < lensub; j++)
{
  if (y->value.character.string[j]
      == x->value.character.string[len - i])
    {
      start = len - i;
      if (start <= len - lensub)
	{
	  count = 0;
	  for (k = 0; k < lensub; k++)
	    if (y->value.character.string[k]
	        == x->value.character.string[k + start])
	      count++;

	  if (count == lensub)
	    {
	      index = start + 1;
	      goto done;
	    }
	}
      else
	{
	  continue;
	}
    }
}
   }
}
  }

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


3640static gfc_expr *
3641simplify_intconv (gfc_expr *e, int kind, const char *name)
3642{
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);
3673}


3676gfc_expr *
3677gfc_simplify_int (gfc_expr *e, gfc_expr *k)
3678{
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");
3686}

3688gfc_expr *
3689gfc_simplify_int2 (gfc_expr *e)
3690{
return simplify_intconv (e, 2, "INT2");
3692}


3695gfc_expr *
3696gfc_simplify_int8 (gfc_expr *e)
3697{
return simplify_intconv (e, 8, "INT8");
3699}


3702gfc_expr *
3703gfc_simplify_long (gfc_expr *e)
3704{
return simplify_intconv (e, 4, "LONG");
3706}


3709gfc_expr *
3710gfc_simplify_ifix (gfc_expr *e)
3711{
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");
3727}


3730gfc_expr *
3731gfc_simplify_idint (gfc_expr *e)
3732{
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");
3748}


3751gfc_expr *
3752gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
3753{
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");
3763}


3766static gfc_expr *
3767do_bit_xor (gfc_expr *result, gfc_expr *e)
3768{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3769, __FUNCTION__), 0 : 0));
gcc_assert (result->ts.type == BT_INTEGER((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3771, __FUNCTION__), 0 : 0))
     && result->expr_type == EXPR_CONSTANT)((void)(!(result->ts.type == BT_INTEGER && result->
expr_type == EXPR_CONSTANT) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 3771, __FUNCTION__), 0 : 0));

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


3778gfc_expr *
3779gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
3780{
return simplify_transformation (array, dim, mask, 0, do_bit_xor);
3782}


3785gfc_expr *
3786gfc_simplify_is_iostat_end (gfc_expr *x)
3787{
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);
3794}


3797gfc_expr *
3798gfc_simplify_is_iostat_eor (gfc_expr *x)
3799{
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);
3806}


3809gfc_expr *
3810gfc_simplify_isnan (gfc_expr *x)
3811{
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)((x->value.real)->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))));
3817}


3820/* 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.  */
3823static gfc_expr *
3824simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
bool arithmetic, int direction)
3826{
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;
3916}


3919gfc_expr *
3920gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
3921{
return simplify_shift (e, s, "ISHFT", false, 0);
3923}


3926gfc_expr *
3927gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
3928{
return simplify_shift (e, s, "LSHIFT", false, 1);
3930}


3933gfc_expr *
3934gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
3935{
return simplify_shift (e, s, "RSHIFT", true, -1);
3937}


3940gfc_expr *
3941gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
3942{
return simplify_shift (e, s, "SHIFTA", true, -1);
3944}


3947gfc_expr *
3948gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
3949{
return simplify_shift (e, s, "SHIFTL", false, 1);
3951}


3954gfc_expr *
3955gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
3956{
return simplify_shift (e, s, "SHIFTR", false, -1);
3958}


3961gfc_expr *
3962gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
3963{
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);
  }
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;
4059}


4062gfc_expr *
4063gfc_simplify_kind (gfc_expr *e)
4064{
return gfc_get_int_expr (gfc_default_integer_kind, NULL__null, e->ts.kind);
4066}


4069static gfc_expr *
4070simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
    gfc_array_spec *as, gfc_ref *ref, bool coarray)
4072{
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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4104, __FUNCTION__), 0 : 0));
gcc_assert (as)((void)(!(as) ? fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4105, __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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4136, __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)
{
 if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL__null))
   goto returnNull;
}
    else
mpz_set_si__gmpz_set_si (result->value.integer, (long int) 1);
  }

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

4181returnNull:
gfc_free_expr (result);
return NULL__null;
4184}


4187static gfc_expr *
4188simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4189{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4236, __FUNCTION__));

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

case REF_SUBSTRING:
case REF_INQUIRY:
 continue;
}
  }

gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4248, __FUNCTION__));

done:

if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
    || (as->type == AS_ASSUMED_SHAPE && upper)))
  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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4260, __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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4260, __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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4260, __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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4260, __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
 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4260, __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.c).  */
 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);
  }
4337}


4340static gfc_expr *
4341simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
4342{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4364, __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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4383, __FUNCTION__));

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

case REF_SUBSTRING:
case REF_INQUIRY:
 continue;
}
  }

if (!as)
  gcc_unreachable ()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4396, __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);
  }
4467}


4470gfc_expr *
4471gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4472{
return simplify_bound (array, dim, kind, 0);
4474}


4477gfc_expr *
4478gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
4479{
return simplify_cobound (array, dim, kind, 0);
4481}

4483gfc_expr *
4484gfc_simplify_leadz (gfc_expr *e)
4485{
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);
4502}


4505gfc_expr *
4506gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
4507{
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)
  {
    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;
4542}


4545gfc_expr *
4546gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
4547{
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");
4567}

4569gfc_expr *
4570gfc_simplify_lgamma (gfc_expr *x)
4571{
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");
4582}


4585gfc_expr *
4586gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
4587{
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);
4593}


4596gfc_expr *
4597gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
4598{
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);
4604}


4607gfc_expr *
4608gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
4609{
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);
4615}


4618gfc_expr *
4619gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
4620{
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);
4626}


4629gfc_expr *
4630gfc_simplify_log (gfc_expr *x)
4631{
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))) ? (((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))((((x->value.complex)->re))->_mpfr_exp == (0 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))))
 && mpfr_zero_p (mpc_imagref (x->value.complex))((((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");
4672}


4675gfc_expr *
4676gfc_simplify_log10 (gfc_expr *x)
4677{
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))) ? (((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");
4694}


4697gfc_expr *
4698gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
4699{
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);
4710}


4713gfc_expr*
4714gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
4715{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4777, __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;
4798}


4801gfc_expr *
4802gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
4803{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4816, __FUNCTION__), 0 : 0));

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


4831gfc_expr *
4832gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
4833{
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 ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 4847, __FUNCTION__), 0 : 0));

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


4866gfc_expr *
4867gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
4868{
gfc_expr * result;
gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;

if (mask->expr_type == EXPR_CONSTANT)
  {
    result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
    /* Parenthesis is needed to get lower bounds of 1.  */
    result = gfc_get_parentheses (result);
    gfc_simplify_expr (result, 1);
    return result;
  }

if (!mask->rank || !is_constant_array_expr (mask)
    || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
  return NULL__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;
4915}


4918gfc_expr *
4919gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
4920{
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;
4946}


4949/* Selects between current value and extremum for simplify_min_max
 and simplify_minval_maxval.  */
4951static int
4952min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
4953{
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)((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)mpfr_set4(extremum->value.real,arg->value.real,MPFR_RNDN
,((arg->value.real)->_mpfr_sign));
 }
else if (mpfr_nan_p (arg->value.real)((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)mpfr_set4(extremum->value.real,arg->value.real,MPFR_RNDN
,((arg->value.real)->_mpfr_sign));
 }
break;

    case BT_CHARACTER:
4986#define LENGTH(x) ((x)->value.character.length)
4987#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  */
 }
5012#undef LENGTH
5013#undef STRING
break;

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

return ret;
5023}


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

5033static gfc_expr *
5034simplify_min_max (gfc_expr *expr, int sign)
5035{
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))
  {
    ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind4);
  }
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;

5092}


5095gfc_expr *
5096gfc_simplify_min (gfc_expr *e)
5097{
return simplify_min_max (e, -1);
5099}


5102gfc_expr *
5103gfc_simplify_max (gfc_expr *e)
5104{
return simplify_min_max (e, 1);
5106}

5108/* Helper function for gfc_simplify_minval.  */

5110static gfc_expr *
5111gfc_min (gfc_expr *op1, gfc_expr *op2)
5112{
min_max_choose (op1, op2, -1);
gfc_free_expr (op1);
return op2;
5116}

5118/* Simplify minval for constant arrays.  */

5120gfc_expr *
5121gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5122{
return simplify_transformation (array, dim, mask, INT_MAX2147483647, gfc_min);
5124}

5126/* Helper function for gfc_simplify_maxval.  */

5128static gfc_expr *
5129gfc_max (gfc_expr *op1, gfc_expr *op2)
5130{
min_max_choose (op1, op2, 1);
gfc_free_expr (op1);
return op2;
5134}


5137/* Simplify maxval for constant arrays.  */

5139gfc_expr *
5140gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
5141{
return simplify_transformation (array, dim, mask, INT_MIN(-2147483647 -1), gfc_max);
5143}


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

5150static gfc_expr *
5151simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
	      gfc_expr *extremum, int sign, bool back_val)
5153{
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;
5193}

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

5197static gfc_expr *
5198simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
	  gfc_expr *array, gfc_expr *mask, int sign,
	  bool back_val)
5201{
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++)
16
←
Assuming 'i' is >= field 'rank'→
17
←
Loop condition is false. Execution continues on line 5215→
  res[i] = -1;

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

17.1	'mask' is non-null

5216 && mask->expr_type == EXPR_CONSTANT

←

Assuming field 'expr_type' is not equal to EXPR_CONSTANT

→

5217 && !mask->value.logical) 5218 goto finish; 5219 5220 for (i = 0; i

18.1	'i' is >= field 'rank'

< array->rank; i++)

←

Loop condition is false. Execution continues on line 5229

→

5221 { 5222 count[i] = 0; 5223 sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5224 extent[i] = mpz_get_si__gmpz_get_si (array->shape[i]); 5225 if (extent[i] <= 0) 5226 goto finish; 5227 } 5228 5229 continue_loop = true; 5230 array_ctor = gfc_constructor_first (array->value.constructor); 5231 if (mask

19.1	'mask' is non-null

&& mask->rank > 0)

←

Assuming field 'rank' is <= 0

→

←

Taking false branch

→

5232 mask_ctor = gfc_constructor_first (mask->value.constructor); 5233 else 5234 mask_ctor = NULL__null; 5235 5236 /* Loop over the array elements (and mask), keeping track of 5237 the indices to return. */ 5238 while (continue_loop)

←

Loop condition is true. Entering loop body

→

5239 { 5240 do 5241 { 5242 a = array_ctor->expr; 5243 if (mask_ctor

22.1	'mask_ctor' is null

)

←

Taking false branch

→

5244 { 5245 m = mask_ctor->expr; 5246 ma = m->value.logical; 5247 mask_ctor = gfc_constructor_next (mask_ctor); 5248 } 5249 else 5250 ma = true; 5251 5252 if (ma

23.1	'ma' is true

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

←

Assuming the condition is false

→

←

Taking false branch

→

5253 { 5254 for (i = 0; i<array->rank; i++) 5255 res[i] = count[i]; 5256 } 5257 array_ctor = gfc_constructor_next (array_ctor); 5258 count[0] ++;

←

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

5259 } while (count[0] != extent[0]); 5260 n = 0; 5261 do 5262 { 5263 /* When we get to the end of a dimension, reset it and increment 5264 the next dimension. */ 5265 count[n] = 0; 5266 n++; 5267 if (n >= array->rank) 5268 { 5269 continue_loop = false; 5270 break; 5271 } 5272 else 5273 count[n] ++; 5274 } while (count[n] == extent[n]); 5275 } 5276 5277 finish: 5278 gfc_free_expr (extremum); 5279 result_ctor = gfc_constructor_first (result->value.constructor); 5280 for (i = 0; i<array->rank; i++) 5281 { 5282 gfc_expr *r_expr; 5283 r_expr = result_ctor->expr; 5284 mpz_set_si__gmpz_set_si (r_expr->value.integer, res[i] + 1); 5285 result_ctor = gfc_constructor_next (result_ctor); 5286 } 5287 return result; 5288} 5289 5290/* Helper function for gfc_simplify_minmaxloc - build an array 5291 expression with n elements. */ 5292 5293static gfc_expr * 5294new_array (bt type, int kind, int n, locus *where) 5295{ 5296 gfc_expr *result; 5297 int i; 5298 5299 result = gfc_get_array_expr (type, kind, where); 5300 result->rank = 1; 5301 result->shape = gfc_get_shape(1)(((mpz_t *) xcalloc (((1)), sizeof (mpz_t)))); 5302 mpz_init_set_si__gmpz_init_set_si (result->shape[0], n); 5303 for (i = 0; i < n; i++) 5304 { 5305 gfc_constructor_append_expr (&result->value.constructor, 5306 gfc_get_constant_expr (type, kind, where), 5307 NULL__null); 5308 } 5309 5310 return result; 5311} 5312 5313/* Simplify minloc and maxloc. This code is mostly identical to 5314 simplify_transformation_to_array. */ 5315 5316static gfc_expr * 5317simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array, 5318 gfc_expr *dim, gfc_expr *mask, 5319 gfc_expr *extremum, int sign, bool back_val) 5320{ 5321 mpz_t size; 5322 int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride; 5323 gfc_expr **arrayvec, **resultvec, **base, **src, **dest; 5324 gfc_constructor *array_ctor, *mask_ctor, *result_ctor; 5325 5326 int count[GFC_MAX_DIMENSIONS15], extent[GFC_MAX_DIMENSIONS15], 5327 sstride[GFC_MAX_DIMENSIONS15], dstride[GFC_MAX_DIMENSIONS15], 5328 tmpstride[GFC_MAX_DIMENSIONS15]; 5329 5330 /* Shortcut for constant .FALSE. MASK. */ 5331 if (mask 5332 && mask->expr_type == EXPR_CONSTANT 5333 && !mask->value.logical) 5334 return result; 5335 5336 /* Build an indexed table for array element expressions to minimize 5337 linked-list traversal. Masked elements are set to NULL. */ 5338 gfc_array_size (array, &size); 5339 arraysize = mpz_get_ui__gmpz_get_ui (size); 5340 mpz_clear__gmpz_clear (size); 5341 5342 arrayvec = XCNEWVEC (gfc_expr*, arraysize)((gfc_expr* *) xcalloc ((arraysize), sizeof (gfc_expr*))); 5343 5344 array_ctor = gfc_constructor_first (array->value.constructor); 5345 mask_ctor = NULL__null; 5346 if (mask && mask->expr_type == EXPR_ARRAY) 5347 mask_ctor = gfc_constructor_first (mask->value.constructor); 5348 5349 for (i = 0; i < arraysize; ++i) 5350 { 5351 arrayvec[i] = array_ctor->expr; 5352 array_ctor = gfc_constructor_next (array_ctor); 5353 5354 if (mask_ctor) 5355 { 5356 if (!mask_ctor->expr->value.logical) 5357 arrayvec[i] = NULL__null; 5358 5359 mask_ctor = gfc_constructor_next (mask_ctor); 5360 } 5361 } 5362 5363 /* Same for the result expression. */ 5364 gfc_array_size (result, &size); 5365 resultsize = mpz_get_ui__gmpz_get_ui (size); 5366 mpz_clear__gmpz_clear (size); 5367 5368 resultvec = XCNEWVEC (gfc_expr*, resultsize)((gfc_expr* *) xcalloc ((resultsize), sizeof (gfc_expr*))); 5369 result_ctor = gfc_constructor_first (result->value.constructor); 5370 for (i = 0; i < resultsize; ++i) 5371 { 5372 resultvec[i] = result_ctor->expr; 5373 result_ctor = gfc_constructor_next (result_ctor); 5374 } 5375 5376 gfc_extract_int (dim, &dim_index); 5377 dim_index -= 1; /* zero-base index */ 5378 dim_extent = 0; 5379 dim_stride = 0; 5380 5381 for (i = 0, n = 0; i < array->rank; ++i) 5382 { 5383 count[i] = 0; 5384 tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si__gmpz_get_si (array->shape[i-1]); 5385 if (i == dim_index) 5386 { 5387 dim_extent = mpz_get_si__gmpz_get_si (array->shape[i]); 5388 dim_stride = tmpstride[i]; 5389 continue; 5390 } 5391 5392 extent[n] = mpz_get_si__gmpz_get_si (array->shape[i]); 5393 sstride[n] = tmpstride[i]; 5394 dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1]; 5395 n += 1; 5396 } 5397 5398 done = resultsize <= 0; 5399 base = arrayvec; 5400 dest = resultvec; 5401 while (!done) 5402 { 5403 gfc_expr *ex; 5404 ex = gfc_copy_expr (extremum); 5405 for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n) 5406 { 5407 if (*src && min_max_choose (*src, ex, sign, back_val) > 0) 5408 mpz_set_si__gmpz_set_si ((*dest)->value.integer, n + 1); 5409 } 5410 5411 count[0]++; 5412 base += sstride[0]; 5413 dest += dstride[0]; 5414 gfc_free_expr (ex); 5415 5416 n = 0; 5417 while (!done && count[n] == extent[n]) 5418 { 5419 count[n] = 0; 5420 base -= sstride[n] * extent[n]; 5421 dest -= dstride[n] * extent[n]; 5422 5423 n++; 5424 if (n < result->rank) 5425 { 5426 /* If the nested loop is unrolled GFC_MAX_DIMENSIONS 5427 times, we'd warn for the last iteration, because the 5428 array index will have already been incremented to the 5429 array sizes, and we can't tell that this must make 5430 the test against result->rank false, because ranks 5431 must not exceed GFC_MAX_DIMENSIONS. */ 5432 GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds) 5433 count[n]++; 5434 base += sstride[n]; 5435 dest += dstride[n]; 5436 GCC_DIAGNOSTIC_POP 5437 } 5438 else 5439 done = true; 5440 } 5441 } 5442 5443 /* Place updated expression in result constructor. */ 5444 result_ctor = gfc_constructor_first (result->value.constructor); 5445 for (i = 0; i < resultsize; ++i) 5446 { 5447 result_ctor->expr = resultvec[i]; 5448 result_ctor = gfc_constructor_next (result_ctor); 5449 } 5450 5451 free (arrayvec); 5452 free (resultvec); 5453 free (extremum); 5454 return result; 5455} 5456 5457/* Simplify minloc and maxloc for constant arrays. */ 5458 5459static gfc_expr * 5460gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, 5461 gfc_expr *kind, gfc_expr *back, int sign) 5462{ 5463 gfc_expr *result; 5464 gfc_expr *extremum; 5465 int ikind; 5466 int init_val; 5467 bool back_val = false; 5468 5469 if (!is_constant_array_expr (array)

←

Assuming the condition is false

→

←

Taking false branch

→

5470 || !gfc_is_constant_expr (dim))

←

Assuming the condition is false

→

5471 return NULL__null; 5472 5473 if (mask

←

Assuming 'mask' is non-null

→

5474 && !is_constant_array_expr (mask)

←

Assuming the condition is false

→

5475 && mask->expr_type != EXPR_CONSTANT) 5476 return NULL__null; 5477 5478 if (kind)

←

Assuming 'kind' is null

→

←

Taking false branch

→

5479 { 5480 if (gfc_extract_int (kind, &ikind, -1)) 5481 return NULL__null; 5482 } 5483 else 5484 ikind = gfc_default_integer_kind; 5485 5486 if (back)

←

Assuming 'back' is null

→

←

Taking false branch

→

5487 { 5488 if (back->expr_type != EXPR_CONSTANT) 5489 return NULL__null; 5490 5491 back_val = back->value.logical; 5492 } 5493 5494 if (sign

10.1	'sign' is >= 0

< 0)

←

Taking false branch

→

5495 init_val = INT_MAX2147483647; 5496 else if (sign

11.1	'sign' is > 0

> 0)

←

Taking true branch

→

5497 init_val = INT_MIN(-2147483647 -1); 5498 else 5499 gcc_unreachable()(fancy_abort ("/home/marxin/BIG/buildbot/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/simplify.c"
, 5499, __FUNCTION__)); 5500 5501 extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where); 5502 init_result_expr (extremum, init_val, array); 5503 5504 if (dim)

←

Assuming 'dim' is null

→

←

Taking false branch

→

5505 { 5506 result = transformational_result (array, dim, BT_INTEGER, 5507 ikind, &array->where); 5508 init_result_expr (result, 0, array); 5509 5510 if (array->rank == 1) 5511 return simplify_minmaxloc_to_scalar (result, array, mask, extremum, 5512 sign, back_val); 5513 else 5514 return simplify_minmaxloc_to_array (result, array, dim, mask, extremum, 5515 sign, back_val); 5516 } 5517 else 5518 { 5519 result = new_array (BT_INTEGER, ikind, array->rank, &array->where); 5520 return simplify_minmaxloc_nodim (result, extremum, array, mask,

←

Calling 'simplify_minmaxloc_nodim'

→

5521 sign, back_val); 5522 } 5523} 5524 5525gfc_expr * 5526gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5527 gfc_expr *back) 5528{ 5529 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1); 5530} 5531 5532gfc_expr * 5533gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind, 5534 gfc_expr *back) 5535{ 5536 return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);

Calling 'gfc_simplify_minmaxloc'

→

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