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

Bug Summary

File:	build/gcc/fortran/arith.cc
Warning:	line 1749, column 3 Undefined or garbage value returned to caller
Annotated Source Code

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

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/* Since target arithmetic must be done on the host, there has to
 be some way of evaluating arithmetic expressions as the host
 would evaluate them.  We use the GNU MP library and the MPFR
 library to do arithmetic, and this file provides the interface.  */

26#include "config.h"
27#include "system.h"
28#include "coretypes.h"
29#include "options.h"
30#include "gfortran.h"
31#include "arith.h"
32#include "target-memory.h"
33#include "constructor.h"

35bool gfc_seen_div0;

37/* MPFR does not have a direct replacement for mpz_set_f() from GMP.
 It's easily implemented with a few calls though.  */

40void
41gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
42{
mpfr_exp_t e;

if (mpfr_inf_p (x)(((mpfr_srcptr) (0 ? (x) : (mpfr_srcptr) (x)))->_mpfr_exp ==
 (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) || mpfr_nan_p (x)(((mpfr_srcptr) (0 ? (x) : (mpfr_srcptr) (x)))->_mpfr_exp ==
 (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
  {
    gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
 "to INTEGER", where);
    mpz_set_ui__gmpz_set_ui (z, 0);
    return;
  }

e = mpfr_get_z_expmpfr_get_z_2exp (z, x);

if (e > 0)
  mpz_mul_2exp__gmpz_mul_2exp (z, z, e);
else
  mpz_tdiv_q_2exp__gmpz_tdiv_q_2exp (z, z, -e);
59}


62/* Set the model number precision by the requested KIND.  */

64void
65gfc_set_model_kind (int kind)
66{
int index = gfc_validate_kind (BT_REAL, kind, false);
int base2prec;

base2prec = gfc_real_kinds[index].digits;
if (gfc_real_kinds[index].radix != 2)
  base2prec *= gfc_real_kinds[index].radix / 2;
mpfr_set_default_prec (base2prec);
74}


77/* Set the model number precision from mpfr_t x.  */

79void
80gfc_set_model (mpfr_t x)
81{
mpfr_set_default_prec (mpfr_get_prec (x)(0 ? (((mpfr_srcptr) (0 ? (x) : (mpfr_srcptr) (x)))->_mpfr_prec
) : (((mpfr_srcptr) (0 ? (x) : (mpfr_srcptr) (x)))->_mpfr_prec
)));
83}


86/* Given an arithmetic error code, return a pointer to a string that
 explains the error.  */

89static const char *
90gfc_arith_error (arith code)
91{
const char *p;

switch (code)
  {
  case ARITH_OK:
    p = G_("Arithmetic OK at %L")"Arithmetic OK at %L";
    break;
  case ARITH_OVERFLOW:
    p = G_("Arithmetic overflow at %L")"Arithmetic overflow at %L";
    break;
  case ARITH_UNDERFLOW:
    p = G_("Arithmetic underflow at %L")"Arithmetic underflow at %L";
    break;
  case ARITH_NAN:
    p = G_("Arithmetic NaN at %L")"Arithmetic NaN at %L";
    break;
  case ARITH_DIV0:
    p = G_("Division by zero at %L")"Division by zero at %L";
    break;
  case ARITH_INCOMMENSURATE:
    p = G_("Array operands are incommensurate at %L")"Array operands are incommensurate at %L";
    break;
  case ARITH_ASYMMETRIC:
    p = G_("Integer outside symmetric range implied by Standard Fortran""Integer outside symmetric range implied by Standard Fortran"
 " at %L"
    " at %L")"Integer outside symmetric range implied by Standard Fortran"
 " at %L";
    break;
  case ARITH_WRONGCONCAT:
    p = G_("Illegal type in character concatenation at %L")"Illegal type in character concatenation at %L";
    break;
  case ARITH_INVALID_TYPE:
    p = G_("Invalid type in arithmetic operation at %L")"Invalid type in arithmetic operation at %L";
    break;

  default:
    gfc_internal_error ("gfc_arith_error(): Bad error code");
  }

return p;
130}


133/* Get things ready to do math.  */

135void
136gfc_arith_init_1 (void)
137{
gfc_integer_info *int_info;
gfc_real_info *real_info;
mpfr_t a, b;
int i;

mpfr_set_default_prec (128);
mpfr_init (a);

/* Convert the minimum and maximum values for each kind into their
   GNU MP representation.  */
for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
  {
    /* Huge  */
    mpz_init__gmpz_init (int_info->huge);
    mpz_set_ui__gmpz_set_ui (int_info->huge, int_info->radix);
    mpz_pow_ui__gmpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
    mpz_sub_ui__gmpz_sub_ui (int_info->huge, int_info->huge, 1);

    /* These are the numbers that are actually representable by the
target.  For bases other than two, this needs to be changed.  */
    if (int_info->radix != 2)
gfc_internal_error ("Fix min_int calculation");

    /* See PRs 13490 and 17912, related to integer ranges.
The pedantic_min_int exists for range checking when a program
is compiled with -pedantic, and reflects the belief that
Standard Fortran requires integers to be symmetrical, i.e.
every negative integer must have a representable positive
absolute value, and vice versa.  */

    mpz_init__gmpz_init (int_info->pedantic_min_int);
    mpz_neg__gmpz_neg (int_info->pedantic_min_int, int_info->huge);

    mpz_init__gmpz_init (int_info->min_int);
    mpz_sub_ui__gmpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);

    /* Range  */
    mpfr_set_z (a, int_info->huge, GFC_RND_MODEMPFR_RNDN);
    mpfr_log10 (a, a, GFC_RND_MODEMPFR_RNDN);
    mpfr_trunc (a, a)mpfr_rint((a), (a), MPFR_RNDZ);
    int_info->range = (int) mpfr_get_si (a, GFC_RND_MODEMPFR_RNDN);
  }

mpfr_clear (a);

for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
  {
    gfc_set_model_kind (real_info->kind);

    mpfr_init (a);
    mpfr_init (b);

    /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
    /* 1 - b**(-p)  */
    mpfr_init (real_info->huge);
    mpfr_set_ui (real_info->huge, 1, GFC_RND_MODEMPFR_RNDN);
    mpfr_set_ui (a, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODEMPFR_RNDN);
    mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODEMPFR_RNDN);

    /* b**(emax-1)  */
    mpfr_set_ui (a, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODEMPFR_RNDN);

    /* (1 - b**(-p)) * b**(emax-1)  */
    mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODEMPFR_RNDN);

    /* (1 - b**(-p)) * b**(emax-1) * b  */
    mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
   GFC_RND_MODEMPFR_RNDN);

    /* tiny(x) = b**(emin-1)  */
    mpfr_init (real_info->tiny);
    mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_pow_si (real_info->tiny, real_info->tiny,
   real_info->min_exponent - 1, GFC_RND_MODEMPFR_RNDN);

    /* subnormal (x) = b**(emin - digit)  */
    mpfr_init (real_info->subnormal);
    mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_pow_si (real_info->subnormal, real_info->subnormal,
   real_info->min_exponent - real_info->digits, GFC_RND_MODEMPFR_RNDN);

    /* epsilon(x) = b**(1-p)  */
    mpfr_init (real_info->epsilon);
    mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_pow_si (real_info->epsilon, real_info->epsilon,
   1 - real_info->digits, GFC_RND_MODEMPFR_RNDN);

    /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
    mpfr_log10 (a, real_info->huge, GFC_RND_MODEMPFR_RNDN);
    mpfr_log10 (b, real_info->tiny, GFC_RND_MODEMPFR_RNDN);
    mpfr_neg (b, b, GFC_RND_MODEMPFR_RNDN);

    /* a = min(a, b)  */
    mpfr_min (a, a, b, GFC_RND_MODEMPFR_RNDN);
    mpfr_trunc (a, a)mpfr_rint((a), (a), MPFR_RNDZ);
    real_info->range = (int) mpfr_get_si (a, GFC_RND_MODEMPFR_RNDN);

    /* precision(x) = int((p - 1) * log10(b)) + k  */
    mpfr_set_ui (a, real_info->radix, GFC_RND_MODEMPFR_RNDN);
    mpfr_log10 (a, a, GFC_RND_MODEMPFR_RNDN);
    mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODEMPFR_RNDN);
    mpfr_trunc (a, a)mpfr_rint((a), (a), MPFR_RNDZ);
    real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODEMPFR_RNDN);

    /* If the radix is an integral power of 10, add one to the precision.  */
    for (i = 10; i <= real_info->radix; i *= 10)
if (i == real_info->radix)
 real_info->precision++;

    mpfr_clears (a, b, NULL__null);
  }
251}


254/* Clean up, get rid of numeric constants.  */

256void
257gfc_arith_done_1 (void)
258{
gfc_integer_info *ip;
gfc_real_info *rp;

for (ip = gfc_integer_kinds; ip->kind; ip++)
  {
    mpz_clear__gmpz_clear (ip->min_int);
    mpz_clear__gmpz_clear (ip->pedantic_min_int);
    mpz_clear__gmpz_clear (ip->huge);
  }

for (rp = gfc_real_kinds; rp->kind; rp++)
  mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL__null);

mpfr_free_cache ();
273}


276/* Given a wide character value and a character kind, determine whether
 the character is representable for that kind.  */
278bool
279gfc_check_character_range (gfc_char_t c, int kind)
280{
/* As wide characters are stored as 32-bit values, they're all
   representable in UCS=4.  */
if (kind == 4)
  return true;

if (kind == 1)
  return c <= 255 ? true : false;

gcc_unreachable ()(fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/arith.cc"
, 289, __FUNCTION__));
290}


293/* Given an integer and a kind, make sure that the integer lies within
 the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
 ARITH_OVERFLOW.  */

297arith
298gfc_check_integer_range (mpz_t p, int kind)
299{
arith result;
int i;

i = gfc_validate_kind (BT_INTEGER, kind, false);
result = ARITH_OK;

if (pedanticglobal_options.x_pedantic)
  {
    if (mpz_cmp__gmpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
result = ARITH_ASYMMETRIC;
  }


if (flag_range_checkglobal_options.x_flag_range_check == 0)
  return result;

if (mpz_cmp__gmpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
    || mpz_cmp__gmpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
  result = ARITH_OVERFLOW;

return result;
321}


324/* Given a real and a kind, make sure that the real lies within the
 range of the kind.  Returns ARITH_OK, ARITH_OVERFLOW or
 ARITH_UNDERFLOW.  */

328static arith
329gfc_check_real_range (mpfr_t p, int kind)
330{
arith retval;
mpfr_t q;
int i;

i = gfc_validate_kind (BT_REAL, kind, false);

gfc_set_model (p);
mpfr_init (q);
mpfr_abs (q, p, GFC_RND_MODE)mpfr_set4(q,p,MPFR_RNDN,1);

retval = ARITH_OK;

if (mpfr_inf_p (p)(((mpfr_srcptr) (0 ? (p) : (mpfr_srcptr) (p)))->_mpfr_exp ==
 (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
  {
    if (flag_range_checkglobal_options.x_flag_range_check != 0)
retval = ARITH_OVERFLOW;
  }
else if (mpfr_nan_p (p)(((mpfr_srcptr) (0 ? (p) : (mpfr_srcptr) (p)))->_mpfr_exp ==
 (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))))
  {
    if (flag_range_checkglobal_options.x_flag_range_check != 0)
retval = ARITH_NAN;
  }
else if (mpfr_sgn (q)((q)->_mpfr_exp < (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1
) >> 1))) ? ((((mpfr_srcptr) (0 ? (q) : (mpfr_srcptr) (
q)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >>
 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((q)->
_mpfr_sign)) == 0)
  {
    mpfr_clear (q);
    return retval;
  }
else if (mpfr_cmp (q, gfc_real_kinds[i].huge)mpfr_cmp3(q, gfc_real_kinds[i].huge, 1) > 0)
  {
    if (flag_range_checkglobal_options.x_flag_range_check == 0)
mpfr_set_inf (p, mpfr_sgn (p)((p)->_mpfr_exp < (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1
) >> 1))) ? ((((mpfr_srcptr) (0 ? (p) : (mpfr_srcptr) (
p)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >>
 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((p)->
_mpfr_sign)));
    else
retval = ARITH_OVERFLOW;
  }
else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal)mpfr_cmp3(q, gfc_real_kinds[i].subnormal, 1) < 0)
  {
    if (flag_range_checkglobal_options.x_flag_range_check == 0)
{
 if (mpfr_sgn (p)((p)->_mpfr_exp < (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1
) >> 1))) ? ((((mpfr_srcptr) (0 ? (p) : (mpfr_srcptr) (
p)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >>
 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((p)->
_mpfr_sign)) < 0)
   {
     mpfr_set_ui (p, 0, GFC_RND_MODEMPFR_RNDN);
     mpfr_set_si (q, -1, GFC_RND_MODEMPFR_RNDN);
     mpfr_copysign (p, p, q, GFC_RND_MODE)mpfr_set4(p,p,MPFR_RNDN,(0 ? (((((mpfr_srcptr) (0 ? (q) : (mpfr_srcptr
) (q))))->_mpfr_sign)) : (((((mpfr_srcptr) (0 ? (q) : (mpfr_srcptr
) (q))))->_mpfr_sign))));
   }
 else
   mpfr_set_ui (p, 0, GFC_RND_MODEMPFR_RNDN);
}
    else
retval = ARITH_UNDERFLOW;
  }
else if (mpfr_cmp (q, gfc_real_kinds[i].tiny)mpfr_cmp3(q, gfc_real_kinds[i].tiny, 1) < 0)
  {
    mpfr_exp_t emin, emax;
    int en;

    /* Save current values of emin and emax.  */
    emin = mpfr_get_emin ();
    emax = mpfr_get_emax ();

    /* Set emin and emax for the current model number.  */
    en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
    mpfr_set_emin ((mpfr_exp_t) en);
    mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
    mpfr_check_range (q, 0, GFC_RND_MODEMPFR_RNDN);
    mpfr_subnormalize (q, 0, GFC_RND_MODEMPFR_RNDN);

    /* Reset emin and emax.  */
    mpfr_set_emin (emin);
    mpfr_set_emax (emax);

    /* Copy sign if needed.  */
    if (mpfr_sgn (p)((p)->_mpfr_exp < (2 - ((mpfr_exp_t) (((mpfr_uexp_t) -1
) >> 1))) ? ((((mpfr_srcptr) (0 ? (p) : (mpfr_srcptr) (
p)))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >>
 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0), 0 : ((p)->
_mpfr_sign)) < 0)
mpfr_neg (p, q, MPFR_RNDN);
    else
mpfr_set (p, q, MPFR_RNDN)__extension__ ({ mpfr_srcptr _p = (q); mpfr_set4(p,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
  }

mpfr_clear (q);

return retval;
411}


414/* Low-level arithmetic functions.  All of these subroutines assume
 that all operands are of the same type and return an operand of the
 same type.  The other thing about these subroutines is that they
 can fail in various ways -- overflow, underflow, division by zero,
 zero raised to the zero, etc.  */

420static arith
421gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
422{
gfc_expr *result;

if (op1->ts.type != BT_LOGICAL)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
result->value.logical = !op1->value.logical;
*resultp = result;

return ARITH_OK;
433}


436static arith
437gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
438{
gfc_expr *result;

if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
		  &op1->where);
result->value.logical = op1->value.logical && op2->value.logical;
*resultp = result;

return ARITH_OK;
450}


453static arith
454gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
455{
gfc_expr *result;

if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
		  &op1->where);
result->value.logical = op1->value.logical || op2->value.logical;
*resultp = result;

return ARITH_OK;
467}


470static arith
471gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
472{
gfc_expr *result;

if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
		  &op1->where);
result->value.logical = op1->value.logical == op2->value.logical;
*resultp = result;

return ARITH_OK;
484}


487static arith
488gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
489{
gfc_expr *result;

if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
		  &op1->where);
result->value.logical = op1->value.logical != op2->value.logical;
*resultp = result;

return ARITH_OK;
501}


504/* Make sure a constant numeric expression is within the range for
 its type and kind.  Note that there's also a gfc_check_range(),
 but that one deals with the intrinsic RANGE function.  */

508arith
509gfc_range_check (gfc_expr *e)
510{
arith rc;
arith rc2;

switch (e->ts.type)
  {
  case BT_INTEGER:
    rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
    break;

  case BT_REAL:
    rc = gfc_check_real_range (e->value.real, e->ts.kind);
    if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (e->value.real, 0, GFC_RND_MODEMPFR_RNDN);
    if (rc == ARITH_OVERFLOW)
mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real)((e->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (((
mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (e->
value.real) : (mpfr_srcptr) (e->value.real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
 () : (mpfr_void) 0), 0 : ((e->value.real)->_mpfr_sign)
));
    if (rc == ARITH_NAN)
mpfr_set_nan (e->value.real);
    break;

  case BT_COMPLEX:
    rc = gfc_check_real_range (mpc_realref (e->value.complex)((e->value.complex)->re), e->ts.kind);
    if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (mpc_realref (e->value.complex)((e->value.complex)->re), 0, GFC_RND_MODEMPFR_RNDN);
    if (rc == ARITH_OVERFLOW)
mpfr_set_inf (mpc_realref (e->value.complex)((e->value.complex)->re),
      mpfr_sgn (mpc_realref (e->value.complex))((((e->value.complex)->re))->_mpfr_exp < (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (
((e->value.complex)->re)) : (mpfr_srcptr) (((e->value
.complex)->re))))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0
), 0 : ((((e->value.complex)->re))->_mpfr_sign)));
    if (rc == ARITH_NAN)
mpfr_set_nan (mpc_realref (e->value.complex)((e->value.complex)->re));

    rc2 = gfc_check_real_range (mpc_imagref (e->value.complex)((e->value.complex)->im), e->ts.kind);
    if (rc == ARITH_UNDERFLOW)
mpfr_set_ui (mpc_imagref (e->value.complex)((e->value.complex)->im), 0, GFC_RND_MODEMPFR_RNDN);
    if (rc == ARITH_OVERFLOW)
mpfr_set_inf (mpc_imagref (e->value.complex)((e->value.complex)->im),
      mpfr_sgn (mpc_imagref (e->value.complex))((((e->value.complex)->im))->_mpfr_exp < (2 - ((mpfr_exp_t
) (((mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (
((e->value.complex)->im)) : (mpfr_srcptr) (((e->value
.complex)->im))))->_mpfr_exp == (1 - ((mpfr_exp_t) (((mpfr_uexp_t
) -1) >> 1)))) ? mpfr_set_erangeflag () : (mpfr_void) 0
), 0 : ((((e->value.complex)->im))->_mpfr_sign)));
    if (rc == ARITH_NAN)
mpfr_set_nan (mpc_imagref (e->value.complex)((e->value.complex)->im));

    if (rc == ARITH_OK)
rc = rc2;
    break;

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

return rc;
558}


561/* Several of the following routines use the same set of statements to
 check the validity of the result.  Encapsulate the checking here.  */

564static arith
565check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
566{
arith val = rc;

if (val == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
    val = ARITH_OK;
  }

if (val == ARITH_ASYMMETRIC)
  {
    gfc_warning (0, gfc_arith_error (val), &x->where);
    val = ARITH_OK;
  }

if (val == ARITH_OK || val == ARITH_OVERFLOW)
  *rp = r;
else
  gfc_free_expr (r);

return val;
588}


591/* It may seem silly to have a subroutine that actually computes the
 unary plus of a constant, but it prevents us from making exceptions
 in the code elsewhere.  Used for unary plus and parenthesized
 expressions.  */

596static arith
597gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
598{
*resultp = gfc_copy_expr (op1);
return ARITH_OK;
601}


604static arith
605gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
606{
gfc_expr *result;
arith rc;

result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op1->ts.type)
  {
  case BT_INTEGER:
    mpz_neg__gmpz_neg (result->value.integer, op1->value.integer);
    break;

  case BT_REAL:
    mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODEMPFR_RNDN);
    break;

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

  default:
    gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
  }

rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
633}


636static arith
637gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
638{
gfc_expr *result;
arith rc;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op1->ts.type)
  {
  case BT_INTEGER:
    mpz_add__gmpz_add (result->value.integer, op1->value.integer, op2->value.integer);
    break;

  case BT_REAL:
    mpfr_add (result->value.real, op1->value.real, op2->value.real,
      GFC_RND_MODEMPFR_RNDN);
    break;

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

  default:
    gfc_internal_error ("gfc_arith_plus(): Bad basic type");
  }

rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
670}


673static arith
674gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
675{
gfc_expr *result;
arith rc;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op1->ts.type)
  {
  case BT_INTEGER:
    mpz_sub__gmpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
    break;

  case BT_REAL:
    mpfr_sub (result->value.real, op1->value.real, op2->value.real,
GFC_RND_MODEMPFR_RNDN);
    break;

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

  default:
    gfc_internal_error ("gfc_arith_minus(): Bad basic type");
  }

rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
707}


710static arith
711gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
712{
gfc_expr *result;
arith rc;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op1->ts.type)
  {
  case BT_INTEGER:
    mpz_mul__gmpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
    break;

  case BT_REAL:
    mpfr_mul (result->value.real, op1->value.real, op2->value.real,
      GFC_RND_MODEMPFR_RNDN);
    break;

  case BT_COMPLEX:
    gfc_set_model (mpc_realref (op1->value.complex)((op1->value.complex)->re));
    mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
      GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
    break;

  default:
    gfc_internal_error ("gfc_arith_times(): Bad basic type");
  }

rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
745}


748static arith
749gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
750{
gfc_expr *result;
arith rc;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

rc = ARITH_OK;

result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op1->ts.type)
  {
  case BT_INTEGER:
    if (mpz_sgn (op2->value.integer)((op2->value.integer)->_mp_size < 0 ? -1 : (op2->
value.integer)->_mp_size > 0) == 0)
{
 rc = ARITH_DIV0;
 break;
}

    if (warn_integer_divisionglobal_options.x_warn_integer_division)
{
 mpz_t r;
 mpz_init__gmpz_init (r);
 mpz_tdiv_qr__gmpz_tdiv_qr (result->value.integer, r, op1->value.integer,
       op2->value.integer);

 if (mpz_cmp_si (r, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(r)->_mp_size < 0 ? -1 : (r)->_mp_size > 0) : __gmpz_cmp_ui
 (r,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (
r,0)) != 0)
   {
     char *p;
     p = mpz_get_str__gmpz_get_str (NULL__null, 10, result->value.integer);
     gfc_warning (OPT_Winteger_division, "Integer division "
	       "truncated to constant %qs at %L", p,
	       &op1->where);
     free (p);
   }
 mpz_clear__gmpz_clear (r);
}
    else
mpz_tdiv_q__gmpz_tdiv_q (result->value.integer, op1->value.integer,
    op2->value.integer);

    break;

  case BT_REAL:
    if (mpfr_sgn (op2->value.real)((op2->value.real)->_mpfr_exp < (2 - ((mpfr_exp_t) (
((mpfr_uexp_t) -1) >> 1))) ? ((((mpfr_srcptr) (0 ? (op2
->value.real) : (mpfr_srcptr) (op2->value.real)))->_mpfr_exp
 == (1 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1)))) ? mpfr_set_erangeflag
 () : (mpfr_void) 0), 0 : ((op2->value.real)->_mpfr_sign
)) == 0 && flag_range_checkglobal_options.x_flag_range_check == 1)
{
 rc = ARITH_DIV0;
 break;
}

    mpfr_div (result->value.real, op1->value.real, op2->value.real,
      GFC_RND_MODEMPFR_RNDN);
    break;

  case BT_COMPLEX:
    if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
 && flag_range_checkglobal_options.x_flag_range_check == 1)
{
 rc = ARITH_DIV0;
 break;
}

    gfc_set_model (mpc_realref (op1->value.complex)((op1->value.complex)->re));
    if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
    {
/* In Fortran, return (NaN + NaN I) for any zero divisor.  See
  PR 40318.  */
mpfr_set_nan (mpc_realref (result->value.complex)((result->value.complex)->re));
mpfr_set_nan (mpc_imagref (result->value.complex)((result->value.complex)->im));
    }
    else
mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
 GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
    break;

  default:
    gfc_internal_error ("gfc_arith_divide(): Bad basic type");
  }

if (rc == ARITH_OK)
  rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
834}

836/* Raise a number to a power.  */

838static arith
839arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
840{
int power_sign;
gfc_expr *result;
arith rc;

if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
  return ARITH_INVALID_TYPE;

/* The result type is derived from op1 and must be compatible with the
   result of the simplification.  Otherwise postpone simplification until
   after operand conversions usually done by gfc_type_convert_binary.  */
if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
    || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
  return ARITH_NOT_REDUCED;

rc = ARITH_OK;
result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);

switch (op2->ts.type)
  {
  case BT_INTEGER:
    power_sign = mpz_sgn (op2->value.integer)((op2->value.integer)->_mp_size < 0 ? -1 : (op2->
value.integer)->_mp_size > 0);

    if (power_sign == 0)
{
 /* Handle something to the zeroth power.  Since we're dealing
    with integral exponents, there is no ambiguity in the
    limiting procedure used to determine the value of 0**0.  */
 switch (op1->ts.type)
   {
   case BT_INTEGER:
     mpz_set_ui__gmpz_set_ui (result->value.integer, 1);
     break;

   case BT_REAL:
     mpfr_set_ui (result->value.real, 1, GFC_RND_MODEMPFR_RNDN);
     break;

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

   default:
     gfc_internal_error ("arith_power(): Bad base");
   }
}
    else
{
 switch (op1->ts.type)
   {
   case BT_INTEGER:
     {
/* First, we simplify the cases of op1 == 1, 0 or -1.  */
if (mpz_cmp_si (op1->value.integer, 1)(__builtin_constant_p ((1) >= 0) && (1) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (1)))
 && ((static_cast<unsigned long> (1))) == 0 ? (
(op1->value.integer)->_mp_size < 0 ? -1 : (op1->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (op1->value
.integer,(static_cast<unsigned long> (1)))) : __gmpz_cmp_si
 (op1->value.integer,1)) == 0)
  {
    /* 1**op2 == 1 */
    mpz_set_si__gmpz_set_si (result->value.integer, 1);
  }
else if (mpz_cmp_si (op1->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(op1->value.integer)->_mp_size < 0 ? -1 : (op1->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (op1->value
.integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
 (op1->value.integer,0)) == 0)
  {
    /* 0**op2 == 0, if op2 > 0
              0**op2 overflow, if op2 < 0 ; in that case, we
       set the result to 0 and return ARITH_DIV0.  */
    mpz_set_si__gmpz_set_si (result->value.integer, 0);
    if (mpz_cmp_si (op2->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(op2->value.integer)->_mp_size < 0 ? -1 : (op2->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (op2->value
.integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
 (op2->value.integer,0)) < 0)
      rc = ARITH_DIV0;
  }
else if (mpz_cmp_si (op1->value.integer, -1)(__builtin_constant_p ((-1) >= 0) && (-1) >= 0 ?
 (__builtin_constant_p ((static_cast<unsigned long> (-1
))) && ((static_cast<unsigned long> (-1))) == 0
 ? ((op1->value.integer)->_mp_size < 0 ? -1 : (op1->
value.integer)->_mp_size > 0) : __gmpz_cmp_ui (op1->
value.integer,(static_cast<unsigned long> (-1)))) : __gmpz_cmp_si
 (op1->value.integer,-1)) == 0)
  {
    /* (-1)**op2 == (-1)**(mod(op2,2)) */
    unsigned int odd = mpz_fdiv_ui__gmpz_fdiv_ui (op2->value.integer, 2);
    if (odd)
      mpz_set_si__gmpz_set_si (result->value.integer, -1);
    else
      mpz_set_si__gmpz_set_si (result->value.integer, 1);
  }
/* Then, we take care of op2 < 0.  */
else if (mpz_cmp_si (op2->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(op2->value.integer)->_mp_size < 0 ? -1 : (op2->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (op2->value
.integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
 (op2->value.integer,0)) < 0)
  {
    /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
    mpz_set_si__gmpz_set_si (result->value.integer, 0);
    if (warn_integer_divisionglobal_options.x_warn_integer_division)
      gfc_warning_now (OPT_Winteger_division, "Negative "
		       "exponent of integer has zero "
		       "result at %L", &result->where);
  }
else
  {
    /* We have abs(op1) > 1 and op2 > 1.
       If op2 > bit_size(op1), we'll have an out-of-range
       result.  */
    int k, power;

    k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
    power = gfc_integer_kinds[k].bit_size;
    if (mpz_cmp_si (op2->value.integer, power)(__builtin_constant_p ((power) >= 0) && (power) >=
? (__builtin_constant_p ((static_cast<unsigned long>
 (power))) && ((static_cast<unsigned long> (power
))) == 0 ? ((op2->value.integer)->_mp_size < 0 ? -1 :
 (op2->value.integer)->_mp_size > 0) : __gmpz_cmp_ui
 (op2->value.integer,(static_cast<unsigned long> (power
)))) : __gmpz_cmp_si (op2->value.integer,power)) < 0)
      {
	gfc_extract_int (op2, &power);
	mpz_pow_ui__gmpz_pow_ui (result->value.integer, op1->value.integer,
		    power);
	rc = gfc_range_check (result);
	if (rc == ARITH_OVERFLOW)
	  gfc_error_now ("Result of exponentiation at %L "
			 "exceeds the range of %s", &op1->where,
			 gfc_typename (&(op1->ts)));
      }
    else
      {
	/* Provide a nonsense value to propagate up. */
	mpz_set__gmpz_set (result->value.integer,
		 gfc_integer_kinds[k].huge);
	mpz_add_ui__gmpz_add_ui (result->value.integer,
		    result->value.integer, 1);
	rc = ARITH_OVERFLOW;
      }
  }
     }
     break;

   case BT_REAL:
     mpfr_pow_z (result->value.real, op1->value.real,
	  op2->value.integer, GFC_RND_MODEMPFR_RNDN);
     break;

   case BT_COMPLEX:
     mpc_pow_z (result->value.complex, op1->value.complex,
	 op2->value.integer, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
     break;

   default:
     break;
   }
}
    break;

  case BT_REAL:

    if (gfc_init_expr_flag)
{
 if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Noninteger "
	       "exponent in an initialization "
	       "expression at %L", &op2->where))
   {
     gfc_free_expr (result);
     return ARITH_PROHIBIT;
   }
}

    if (mpfr_cmp_si (op1->value.real, 0)mpfr_cmp_si_2exp((op1->value.real),(0),0) < 0)
{
 gfc_error ("Raising a negative REAL at %L to "
     "a REAL power is prohibited", &op1->where);
 gfc_free_expr (result);
 return ARITH_PROHIBIT;
}

mpfr_pow (result->value.real, op1->value.real, op2->value.real,
  GFC_RND_MODEMPFR_RNDN);
    break;

  case BT_COMPLEX:
    {
if (gfc_init_expr_flag)
 {
   if (!gfc_notify_std (GFC_STD_F2003(1<<4), "Noninteger "
		 "exponent in an initialization "
		 "expression at %L", &op2->where))
     {
gfc_free_expr (result);
return ARITH_PROHIBIT;
     }
 }

mpc_pow (result->value.complex, op1->value.complex,
 op2->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));
    }
    break;
  default:
    gfc_internal_error ("arith_power(): unknown type");
  }

if (rc == ARITH_OK)
  rc = gfc_range_check (result);

return check_result (rc, op1, result, resultp);
1025}


1028/* Concatenate two string constants.  */

1030static arith
1031gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1032{
gfc_expr *result;
size_t len;

/* By cleverly playing around with constructors, it is possible
   to get mismaching types here.  */
if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
    || op1->ts.kind != op2->ts.kind)
  return ARITH_WRONGCONCAT;

result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
		  &op1->where);

len = op1->value.character.length + op2->value.character.length;

result->value.character.string = gfc_get_wide_string (len + 1)((gfc_char_t *) xcalloc ((len + 1), sizeof (gfc_char_t)));
result->value.character.length = len;

memcpy (result->value.character.string, op1->value.character.string,
 op1->value.character.length * sizeof (gfc_char_t));

memcpy (&result->value.character.string[op1->value.character.length],
 op2->value.character.string,
 op2->value.character.length * sizeof (gfc_char_t));

result->value.character.string[len] = '\0';

*resultp = result;

return ARITH_OK;
1062}

1064/* Comparison between real values; returns 0 if (op1 .op. op2) is true.
 This function mimics mpfr_cmp but takes NaN into account.  */

1067static int
1068compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1069{
int rc;
switch (op)
  {
    case INTRINSIC_EQ:
rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
break;
    case INTRINSIC_GT:
rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
break;
    case INTRINSIC_GE:
rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
break;
    case INTRINSIC_LT:
rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
break;
    case INTRINSIC_LE:
rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
break;
    default:
gfc_internal_error ("compare_real(): Bad operator");
  }

return rc;
1093}

1095/* Comparison operators.  Assumes that the two expression nodes
 contain two constants of the same type. The op argument is
 needed to handle NaN correctly.  */

1099int
1100gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1101{
int rc;

switch (op1->ts.type)
  {
  case BT_INTEGER:
    rc = mpz_cmp__gmpz_cmp (op1->value.integer, op2->value.integer);
    break;

  case BT_REAL:
    rc = compare_real (op1, op2, op);
    break;

  case BT_CHARACTER:
    rc = gfc_compare_string (op1, op2);
    break;

  case BT_LOGICAL:
    rc = ((!op1->value.logical && op2->value.logical)
   || (op1->value.logical && !op2->value.logical));
    break;

  default:
    gfc_internal_error ("gfc_compare_expr(): Bad basic type");
  }

return rc;
1128}


1131/* Compare a pair of complex numbers.  Naturally, this is only for
 equality and inequality.  */

1134static int
1135compare_complex (gfc_expr *op1, gfc_expr *op2)
1136{
return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
1138}


1141/* Given two constant strings and the inverse collating sequence, compare the
 strings.  We return -1 for a < b, 0 for a == b and 1 for a > b.
 We use the processor's default collating sequence.  */

1145int
1146gfc_compare_string (gfc_expr *a, gfc_expr *b)
1147{
size_t len, alen, blen, i;
gfc_char_t ac, bc;

alen = a->value.character.length;
blen = b->value.character.length;

len = MAX(alen, blen)((alen) > (blen) ? (alen) : (blen));

for (i = 0; i < len; i++)
  {
    ac = ((i < alen) ? a->value.character.string[i] : ' ');
    bc = ((i < blen) ? b->value.character.string[i] : ' ');

    if (ac < bc)
return -1;
    if (ac > bc)
return 1;
  }

/* Strings are equal */
return 0;
1169}


1172int
1173gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
1174{
size_t len, alen, blen, i;
gfc_char_t ac, bc;

alen = a->value.character.length;
blen = strlen (b);

len = MAX(alen, blen)((alen) > (blen) ? (alen) : (blen));

for (i = 0; i < len; i++)
  {
    ac = ((i < alen) ? a->value.character.string[i] : ' ');
    bc = ((i < blen) ? b[i] : ' ');

    if (!case_sensitive)
{
 ac = TOLOWER (ac)_sch_tolower[(ac) & 0xff];
 bc = TOLOWER (bc)_sch_tolower[(bc) & 0xff];
}

    if (ac < bc)
return -1;
    if (ac > bc)
return 1;
  }

/* Strings are equal */
return 0;
1202}


1205/* Specific comparison subroutines.  */

1207static arith
1208gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1209{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
	? compare_complex (op1, op2)
	: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);

*resultp = result;
return ARITH_OK;
1223}


1226static arith
1227gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1228{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (op1->ts.type == BT_COMPLEX)
	? !compare_complex (op1, op2)
	: (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);

*resultp = result;
return ARITH_OK;
1242}


1245static arith
1246gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1247{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
*resultp = result;

return ARITH_OK;
1259}


1262static arith
1263gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1264{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
*resultp = result;

return ARITH_OK;
1276}


1279static arith
1280gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1281{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
*resultp = result;

return ARITH_OK;
1293}


1296static arith
1297gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
1298{
gfc_expr *result;

if (op1->ts.type != op2->ts.type)
  return ARITH_INVALID_TYPE;

result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
		  &op1->where);
result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
*resultp = result;

return ARITH_OK;
1310}


1313static arith
1314reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
     gfc_expr **result)
1316{
gfc_constructor_base head;
gfc_constructor *c;
gfc_expr *r;
arith rc;

if (op->expr_type == EXPR_CONSTANT)
16
←
Assuming field 'expr_type' is not equal to EXPR_CONSTANT→
17
←
Taking false branch→
  return eval (op, result);

if (op->expr_type != EXPR_ARRAY)
18
←
Assuming field 'expr_type' is equal to EXPR_ARRAY→
19
←
Taking false branch→
  return ARITH_NOT_REDUCED;

rc = ARITH_OK;
head = gfc_constructor_copy (op->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
20
←
Loop condition is true.  Entering loop body→
  {
    rc = reduce_unary (eval, c->expr, &r);

    if (rc != ARITH_OK)
21
←
Assuming 'rc' is not equal to ARITH_OK→
22
←
Taking true branch→
break;

    gfc_replace_expr (c->expr, r);
  }

if (rc23.1
'rc' is not equal to ARITH_OK
 != ARITH_OK)
23
←
 Execution continues on line 1340→
24
←
Taking true branch→
  gfc_constructor_free (head);
else
  {
    gfc_constructor *c = gfc_constructor_first (head);
    if (c == NULL__null)
{
 /* Handle zero-sized arrays.  */
 r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
}
    else
{
 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
		  &op->where);
}
    r->shape = gfc_copy_shape (op->shape, op->rank);
    r->rank = op->rank;
    r->value.constructor = head;
    *result = r;
  }

return rc;
25
←
Returning without writing to '*result'→
1362}


1365static arith
1366reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1368{
gfc_constructor_base head;
gfc_constructor *c;
gfc_expr *r;
arith rc = ARITH_OK;

head = gfc_constructor_copy (op1->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
  {
    gfc_simplify_expr (c->expr, 0);

    if (c->expr->expr_type == EXPR_CONSTANT)
      rc = eval (c->expr, op2, &r);
    else if (c->expr->expr_type != EXPR_ARRAY)
rc = ARITH_NOT_REDUCED;
    else
rc = reduce_binary_ac (eval, c->expr, op2, &r);

    if (rc != ARITH_OK)
break;

    gfc_replace_expr (c->expr, r);
  }

if (rc != ARITH_OK)
  gfc_constructor_free (head);
else
  {
    gfc_constructor *c = gfc_constructor_first (head);
    if (c)
{
 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
		  &op1->where);
 r->shape = gfc_copy_shape (op1->shape, op1->rank);
}
    else
{
 gcc_assert (op1->ts.type != BT_UNKNOWN)((void)(!(op1->ts.type != BT_UNKNOWN) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/arith.cc"
, 1405, __FUNCTION__), 0 : 0));
 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
		  &op1->where);
 r->shape = gfc_get_shape (op1->rank)(((mpz_t *) xcalloc (((op1->rank)), sizeof (mpz_t))));
}
    r->rank = op1->rank;
    r->value.constructor = head;
    *result = r;
  }

return rc;
1416}


1419static arith
1420reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1422{
gfc_constructor_base head;
gfc_constructor *c;
gfc_expr *r;
arith rc = ARITH_OK;

head = gfc_constructor_copy (op2->value.constructor);
for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
  {
    gfc_simplify_expr (c->expr, 0);

    if (c->expr->expr_type == EXPR_CONSTANT)
rc = eval (op1, c->expr, &r);
    else if (c->expr->expr_type != EXPR_ARRAY)
rc = ARITH_NOT_REDUCED;
    else
rc = reduce_binary_ca (eval, op1, c->expr, &r);

    if (rc != ARITH_OK)
break;

    gfc_replace_expr (c->expr, r);
  }

if (rc != ARITH_OK)
  gfc_constructor_free (head);
else
  {
    gfc_constructor *c = gfc_constructor_first (head);
    if (c)
{
 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
		  &op2->where);
 r->shape = gfc_copy_shape (op2->shape, op2->rank);
}
    else
{
 gcc_assert (op2->ts.type != BT_UNKNOWN)((void)(!(op2->ts.type != BT_UNKNOWN) ? fancy_abort ("/buildworker/marxinbox-gcc-clang-static-analyzer/build/gcc/fortran/arith.cc"
, 1459, __FUNCTION__), 0 : 0));
 r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
		  &op2->where);
 r->shape = gfc_get_shape (op2->rank)(((mpz_t *) xcalloc (((op2->rank)), sizeof (mpz_t))));
}
    r->rank = op2->rank;
    r->value.constructor = head;
    *result = r;
  }

return rc;
1470}


1473/* We need a forward declaration of reduce_binary.  */
1474static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
	    gfc_expr *op1, gfc_expr *op2, gfc_expr **result);


1478static arith
1479reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
  gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1481{
gfc_constructor_base head;
gfc_constructor *c, *d;
gfc_expr *r;
arith rc = ARITH_OK;

if (!gfc_check_conformance (op1, op2, _("elemental binary operation")gettext ("elemental binary operation")))
  return ARITH_INCOMMENSURATE;

head = gfc_constructor_copy (op1->value.constructor);
for (c = gfc_constructor_first (head),
     d = gfc_constructor_first (op2->value.constructor);
     c && d;
     c = gfc_constructor_next (c), d = gfc_constructor_next (d))
  {
    rc = reduce_binary (eval, c->expr, d->expr, &r);

    if (rc != ARITH_OK)
break;

    gfc_replace_expr (c->expr, r);
  }

if (rc == ARITH_OK && (c || d))
  rc = ARITH_INCOMMENSURATE;

if (rc != ARITH_OK)
  gfc_constructor_free (head);
else
  {
    gfc_constructor *c = gfc_constructor_first (head);
    if (c == NULL__null)
{
 /* Handle zero-sized arrays.  */
 r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
}
    else
{
 r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
		  &op1->where);
}
    r->shape = gfc_copy_shape (op1->shape, op1->rank);
    r->rank = op1->rank;
    r->value.constructor = head;
    *result = r;
  }

return rc;
1529}


1532static arith
1533reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
      gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
1535{
if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
  return eval (op1, op2, result);

if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
  return reduce_binary_ca (eval, op1, op2, result);

if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
  return reduce_binary_ac (eval, op1, op2, result);

if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
  return ARITH_NOT_REDUCED;

return reduce_binary_aa (eval, op1, op2, result);
1549}


1552typedef union
1553{
arith (*f2)(gfc_expr *, gfc_expr **);
arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
1556}
1557eval_f;

1559/* High level arithmetic subroutines.  These subroutines go into
 eval_intrinsic(), which can do one of several things to its
 operands.  If the operands are incompatible with the intrinsic
 operation, we return a node pointing to the operands and hope that
 an operator interface is found during resolution.

 If the operands are compatible and are constants, then we try doing
 the arithmetic.  We also handle the cases where either or both
 operands are array constructors.  */

1569static gfc_expr *
1570eval_intrinsic (gfc_intrinsic_op op,
eval_f eval, gfc_expr *op1, gfc_expr *op2)
1572{
gfc_expr temp, *result;
5
←
'result' declared without an initial value→
int unary;
arith rc;

if (!op15.1
'op1' is non-null
)
6
←
Taking false branch→
  return NULL__null;

gfc_clear_ts (&temp.ts);

switch (op)
7
←
Control jumps to 'case INTRINSIC_PARENTHESES:'  at line 1617→
  {
  /* Logical unary  */
  case INTRINSIC_NOT:
    if (op1->ts.type != BT_LOGICAL)
goto runtime;

    temp.ts.type = BT_LOGICAL;
    temp.ts.kind = gfc_default_logical_kind;
    unary = 1;
    break;

  /* Logical binary operators  */
  case INTRINSIC_OR:
  case INTRINSIC_AND:
  case INTRINSIC_NEQV:
  case INTRINSIC_EQV:
    if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
goto runtime;

    temp.ts.type = BT_LOGICAL;
    temp.ts.kind = gfc_default_logical_kind;
    unary = 0;
    break;

  /* Numeric unary  */
  case INTRINSIC_UPLUS:
  case INTRINSIC_UMINUS:
    if (!gfc_numeric_ts (&op1->ts))
goto runtime;

    temp.ts = op1->ts;
    unary = 1;
    break;

  case INTRINSIC_PARENTHESES:
    temp.ts = op1->ts;
    unary = 1;
    break;
8
←
 Execution continues on line 1710→

  /* Additional restrictions for ordering relations.  */
  case INTRINSIC_GE:
  case INTRINSIC_GE_OS:
  case INTRINSIC_LT:
  case INTRINSIC_LT_OS:
  case INTRINSIC_LE:
  case INTRINSIC_LE_OS:
  case INTRINSIC_GT:
  case INTRINSIC_GT_OS:
    if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
{
 temp.ts.type = BT_LOGICAL;
 temp.ts.kind = gfc_default_logical_kind;
 goto runtime;
}

  /* Fall through  */
  case INTRINSIC_EQ:
  case INTRINSIC_EQ_OS:
  case INTRINSIC_NE:
  case INTRINSIC_NE_OS:
    if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
{
 unary = 0;
 temp.ts.type = BT_LOGICAL;
 temp.ts.kind = gfc_default_logical_kind;

 /* If kind mismatch, exit and we'll error out later.  */
 if (op1->ts.kind != op2->ts.kind)
   goto runtime;

 break;
}

  gcc_fallthrough ();
  /* Numeric binary  */
  case INTRINSIC_PLUS:
  case INTRINSIC_MINUS:
  case INTRINSIC_TIMES:
  case INTRINSIC_DIVIDE:
  case INTRINSIC_POWER:
    if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
goto runtime;

    /* Insert any necessary type conversions to make the operands
compatible.  */

    temp.expr_type = EXPR_OP;
    gfc_clear_ts (&temp.ts);
    temp.value.op.op = op;

    temp.value.op.op1 = op1;
    temp.value.op.op2 = op2;

    gfc_type_convert_binary (&temp, warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra);

    if (op == INTRINSIC_EQ || op == INTRINSIC_NE
 || op == INTRINSIC_GE || op == INTRINSIC_GT
 || op == INTRINSIC_LE || op == INTRINSIC_LT
 || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
 || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
 || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
{
 temp.ts.type = BT_LOGICAL;
 temp.ts.kind = gfc_default_logical_kind;
}

    unary = 0;
    break;

  /* Character binary  */
  case INTRINSIC_CONCAT:
    if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
 || op1->ts.kind != op2->ts.kind)
goto runtime;

    temp.ts.type = BT_CHARACTER;
    temp.ts.kind = op1->ts.kind;
    unary = 0;
    break;

  case INTRINSIC_USER:
    goto runtime;

  default:
    gfc_internal_error ("eval_intrinsic(): Bad operator");
  }

if (op1->expr_type8.1
Field 'expr_type' is not equal to EXPR_CONSTANT
 != EXPR_CONSTANT
    && (op1->expr_type8.2
Field 'expr_type' is equal to EXPR_ARRAY
 != EXPR_ARRAY
 || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
9
←
Assuming the condition is false→
10
←
Assuming the condition is false→
  goto runtime;

if (op210.1
'op2' is not equal to NULL
 != NULL__null
13
←
Taking false branch→
    && op2->expr_type10.2
Field 'expr_type' is not equal to EXPR_CONSTANT
 != EXPR_CONSTANT
&& (op2->expr_type10.3
Field 'expr_type' is equal to EXPR_ARRAY
 != EXPR_ARRAY
    || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
11
←
Assuming the condition is false→
12
←
Assuming the condition is false→
  goto runtime;

if (unary13.1
'unary' is 1
)
14
←
Taking true branch→
  rc = reduce_unary (eval.f2, op1, &result);
15
←
Calling 'reduce_unary'→
26
←
Returning from 'reduce_unary'→
else
  rc = reduce_binary (eval.f3, op1, op2, &result);

if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
27
←
Assuming 'rc' is not equal to ARITH_INVALID_TYPE→
28
←
Assuming 'rc' is not equal to ARITH_NOT_REDUCED→
  goto runtime;

/* Something went wrong.  */
if (op28.1
'op' is not equal to INTRINSIC_POWER
 == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
  return NULL__null;

if (rc28.2
'rc' is not equal to ARITH_OK
 != ARITH_OK)
29
←
Taking true branch→
  {
    gfc_error (gfc_arith_error (rc), &op1->where);
    if (rc29.1
'rc' is equal to ARITH_OVERFLOW
 == ARITH_OVERFLOW)
30
←
Taking true branch→
goto done;
31
←
Control jumps to line 1747→

    if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
gfc_seen_div0 = true;

    return NULL__null;
  }

1745done:

gfc_free_expr (op1);
gfc_free_expr (op2);
return result;
32
←
Undefined or garbage value returned to caller

1751runtime:
/* Create a run-time expression.  */
result = gfc_get_operator_expr (&op1->where, op, op1, op2);
result->ts = temp.ts;

return result;
1757}


1760/* Modify type of expression for zero size array.  */

1762static gfc_expr *
1763eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
1764{
if (op == NULL__null)
  gfc_internal_error ("eval_type_intrinsic0(): op NULL");

switch (iop)
  {
  case INTRINSIC_GE:
  case INTRINSIC_GE_OS:
  case INTRINSIC_LT:
  case INTRINSIC_LT_OS:
  case INTRINSIC_LE:
  case INTRINSIC_LE_OS:
  case INTRINSIC_GT:
  case INTRINSIC_GT_OS:
  case INTRINSIC_EQ:
  case INTRINSIC_EQ_OS:
  case INTRINSIC_NE:
  case INTRINSIC_NE_OS:
    op->ts.type = BT_LOGICAL;
    op->ts.kind = gfc_default_logical_kind;
    break;

  default:
    break;
  }

return op;
1791}


1794/* Return nonzero if the expression is a zero size array.  */

1796static bool
1797gfc_zero_size_array (gfc_expr *e)
1798{
if (e == NULL__null || e->expr_type != EXPR_ARRAY)
  return false;

return e->value.constructor == NULL__null;
1803}


1806/* Reduce a binary expression where at least one of the operands
 involves a zero-length array.  Returns NULL if neither of the
 operands is a zero-length array.  */

1810static gfc_expr *
1811reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
1812{
if (gfc_zero_size_array (op1))
  {
    gfc_free_expr (op2);
    return op1;
  }

if (gfc_zero_size_array (op2))
  {
    gfc_free_expr (op1);
    return op2;
  }

return NULL__null;
1826}


1829static gfc_expr *
1830eval_intrinsic_f2 (gfc_intrinsic_op op,
   arith (*eval) (gfc_expr *, gfc_expr **),
   gfc_expr *op1, gfc_expr *op2)
1833{
gfc_expr *result;
eval_f f;

if (op2 == NULL__null)
  {
    if (gfc_zero_size_array (op1))
return eval_type_intrinsic0 (op, op1);
  }
else
  {
    result = reduce_binary0 (op1, op2);
    if (result != NULL__null)
return eval_type_intrinsic0 (op, result);
  }

f.f2 = eval;
return eval_intrinsic (op, f, op1, op2);
1851}


1854static gfc_expr *
1855eval_intrinsic_f3 (gfc_intrinsic_op op,
   arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
   gfc_expr *op1, gfc_expr *op2)
1858{
gfc_expr *result;
eval_f f;

if (!op1 && !op2)
2
←
Assuming 'op1' is non-null→
  return NULL__null;

result = reduce_binary0 (op1, op2);
if (result2.1
'result' is equal to NULL
 != NULL__null)
3
←
Taking false branch→
  return eval_type_intrinsic0(op, result);

f.f3 = eval;
return eval_intrinsic (op, f, op1, op2);
4
←
Calling 'eval_intrinsic'→
1871}


1874gfc_expr *
1875gfc_parentheses (gfc_expr *op)
1876{
if (gfc_is_constant_expr (op))
  return op;

return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
	    op, NULL__null);
1882}

1884gfc_expr *
1885gfc_uplus (gfc_expr *op)
1886{
return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL__null);
1888}


1891gfc_expr *
1892gfc_uminus (gfc_expr *op)
1893{
return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL__null);
1895}


1898gfc_expr *
1899gfc_add (gfc_expr *op1, gfc_expr *op2)
1900{
return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
1902}


1905gfc_expr *
1906gfc_subtract (gfc_expr *op1, gfc_expr *op2)
1907{
return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
1909}


1912gfc_expr *
1913gfc_multiply (gfc_expr *op1, gfc_expr *op2)
1914{
return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
1916}


1919gfc_expr *
1920gfc_divide (gfc_expr *op1, gfc_expr *op2)
1921{
return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
1923}


1926gfc_expr *
1927gfc_power (gfc_expr *op1, gfc_expr *op2)
1928{
return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
1930}


1933gfc_expr *
1934gfc_concat (gfc_expr *op1, gfc_expr *op2)
1935{
return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
1937}


1940gfc_expr *
1941gfc_and (gfc_expr *op1, gfc_expr *op2)
1942{
return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
1944}


1947gfc_expr *
1948gfc_or (gfc_expr *op1, gfc_expr *op2)
1949{
return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
1951}


1954gfc_expr *
1955gfc_not (gfc_expr *op1)
1956{
return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL__null);
1958}


1961gfc_expr *
1962gfc_eqv (gfc_expr *op1, gfc_expr *op2)
1963{
return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
1965}


1968gfc_expr *
1969gfc_neqv (gfc_expr *op1, gfc_expr *op2)
1970{
return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
1972}


1975gfc_expr *
1976gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1977{
return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
1979}


1982gfc_expr *
1983gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1984{
return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
1986}


1989gfc_expr *
1990gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1991{
return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
1993}


1996gfc_expr *
1997gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
1998{
return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
2000}


2003gfc_expr *
2004gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2005{
return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
2007}


2010gfc_expr *
2011gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
2012{
return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
1
Calling 'eval_intrinsic_f3'→
2014}


2017/******* Simplification of intrinsic functions with constant arguments *****/


2020/* Deal with an arithmetic error.  */

2022static void
2023arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
2024{
switch (rc)
  {
  case ARITH_OK:
    gfc_error ("Arithmetic OK converting %s to %s at %L",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_OVERFLOW:
    gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
 "can be disabled with the option %<-fno-range-check%>",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_UNDERFLOW:
    gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
 "can be disabled with the option %<-fno-range-check%>",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_NAN:
    gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
 "can be disabled with the option %<-fno-range-check%>",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_DIV0:
    gfc_error ("Division by zero converting %s to %s at %L",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_INCOMMENSURATE:
    gfc_error ("Array operands are incommensurate converting %s to %s at %L",
 gfc_typename (from), gfc_typename (to), where);
    break;
  case ARITH_ASYMMETRIC:
    gfc_error ("Integer outside symmetric range implied by Standard Fortran"
	 " converting %s to %s at %L",
 gfc_typename (from), gfc_typename (to), where);
    break;
  default:
    gfc_internal_error ("gfc_arith_error(): Bad error code");
  }

/* TODO: Do something about the error, i.e., throw exception, return
   NaN, etc.  */
2065}

2067/* Returns true if significant bits were lost when converting real
 constant r from from_kind to to_kind.  */

2070static bool
2071wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
2072{
mpfr_t rv, diff;
bool ret;

gfc_set_model_kind (to_kind);
mpfr_init (rv);
gfc_set_model_kind (from_kind);
mpfr_init (diff);

mpfr_set (rv, r, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (r); mpfr_set4(rv,_p,MPFR_RNDN
,((_p)->_mpfr_sign)); });
mpfr_sub (diff, rv, r, GFC_RND_MODEMPFR_RNDN);

ret = ! mpfr_zero_p (diff)(((mpfr_srcptr) (0 ? (diff) : (mpfr_srcptr) (diff)))->_mpfr_exp
 == (0 - ((mpfr_exp_t) (((mpfr_uexp_t) -1) >> 1))));
mpfr_clear (rv);
mpfr_clear (diff);
return ret;
2088}

2090/* Return true if conversion from an integer to a real loses precision.  */

2092static bool
2093wprecision_int_real (mpz_t n, mpfr_t r)
2094{
bool ret;
mpz_t i;
mpz_init__gmpz_init (i);
mpfr_get_z (i, r, GFC_RND_MODEMPFR_RNDN);
mpz_sub__gmpz_sub (i, i, n);
ret = mpz_cmp_si (i, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(i)->_mp_size < 0 ? -1 : (i)->_mp_size > 0) : __gmpz_cmp_ui
 (i,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si (
i,0)) != 0;
mpz_clear__gmpz_clear (i);
return ret;
2103}

2105/* Convert integers to integers.  */

2107gfc_expr *
2108gfc_int2int (gfc_expr *src, int kind)
2109{
gfc_expr *result;
arith rc;

if (src->ts.type != BT_INTEGER)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);

mpz_set__gmpz_set (result->value.integer, src->value.integer);

if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
  {
    if (rc == ARITH_ASYMMETRIC)
{
 gfc_warning (0, gfc_arith_error (rc), &src->where);
}
    else
{
 arith_error (rc, &src->ts, &result->ts, &src->where);
 gfc_free_expr (result);
 return NULL__null;
}
  }

/*  If we do not trap numeric overflow, we need to convert the number to
    signed, throwing away high-order bits if necessary.  */
if (flag_range_checkglobal_options.x_flag_range_check == 0)
  {
    int k;

    k = gfc_validate_kind (BT_INTEGER, kind, false);
    gfc_convert_mpz_to_signed (result->value.integer,
		 gfc_integer_kinds[k].bit_size);

    if (warn_conversionglobal_options.x_warn_conversion && !src->do_not_warn && kind < src->ts.kind)
gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
	 gfc_typename (&src->ts), gfc_typename (&result->ts),
	 &src->where);
  }
return result;
2150}


2153/* Convert integers to reals.  */

2155gfc_expr *
2156gfc_int2real (gfc_expr *src, int kind)
2157{
gfc_expr *result;
arith rc;

if (src->ts.type != BT_INTEGER)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, kind, &src->where);

mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODEMPFR_RNDN);

if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if (warn_conversionglobal_options.x_warn_conversion
    && wprecision_int_real (src->value.integer, result->value.real))
  gfc_warning (OPT_Wconversion, "Change of value in conversion "
 "from %qs to %qs at %L",
 gfc_typename (&src->ts),
 gfc_typename (&result->ts),
 &src->where);

return result;
2184}


2187/* Convert default integer to default complex.  */

2189gfc_expr *
2190gfc_int2complex (gfc_expr *src, int kind)
2191{
gfc_expr *result;
arith rc;

if (src->ts.type != BT_INTEGER)
  return NULL__null;

result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);

mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));

if ((rc = gfc_check_real_range (mpc_realref (result->value.complex)((result->value.complex)->re), kind))
    != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if (warn_conversionglobal_options.x_warn_conversion
    && wprecision_int_real (src->value.integer,
	      mpc_realref (result->value.complex)((result->value.complex)->re)))
    gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
       "from %qs to %qs at %L",
       gfc_typename (&src->ts),
       gfc_typename (&result->ts),
       &src->where);

return result;
2220}


2223/* Convert default real to default integer.  */

2225gfc_expr *
2226gfc_real2int (gfc_expr *src, int kind)
2227{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_REAL)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);

gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);

if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

/* If there was a fractional part, warn about this.  */

if (warn_conversionglobal_options.x_warn_conversion)
  {
    mpfr_t f;
    mpfr_init (f);
    mpfr_frac (f, src->value.real, GFC_RND_MODEMPFR_RNDN);
    if (mpfr_cmp_si (f, 0)mpfr_cmp_si_2exp((f),(0),0) != 0)
{
 gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
	   "from %qs to %qs at %L", gfc_typename (&src->ts),
	   gfc_typename (&result->ts), &src->where);
 did_warn = true;
}
    mpfr_clear (f);
  }
if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra)
  {
    gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
       "at %L", gfc_typename (&src->ts),
       gfc_typename (&result->ts), &src->where);
  }

return result;
2270}


2273/* Convert real to real.  */

2275gfc_expr *
2276gfc_real2real (gfc_expr *src, int kind)
2277{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_REAL)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, kind, &src->where);

mpfr_set (result->value.real, src->value.real, GFC_RND_MODE)__extension__ ({ mpfr_srcptr _p = (src->value.real); mpfr_set4
(result->value.real,_p,MPFR_RNDN,((_p)->_mpfr_sign)); }
);

rc = gfc_check_real_range (result->value.real, kind);

if (rc == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN);
  }
else if (rc != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

/* As a special bonus, don't warn about REAL values which are not changed by
   the conversion if -Wconversion is specified and -Wconversion-extra is
   not.  */

if ((warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra) && src->ts.kind > kind)
  {
    int w = warn_conversionglobal_options.x_warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;

    /* Calculate the difference between the constant and the rounded
value and check it against zero.  */

    if (wprecision_real_real (src->value.real, src->ts.kind, kind))
{
 gfc_warning_now (w, "Change of value in conversion from "
	   "%qs to %qs at %L",
	   gfc_typename (&src->ts), gfc_typename (&result->ts),
	   &src->where);
 /* Make sure the conversion warning is not emitted again.  */
 did_warn = true;
}
  }

  if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra)
    gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
       "at %L", gfc_typename(&src->ts),
       gfc_typename(&result->ts), &src->where);

return result;
2332}


2335/* Convert real to complex.  */

2337gfc_expr *
2338gfc_real2complex (gfc_expr *src, int kind)
2339{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_REAL)
  return NULL__null;

result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);

mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));

rc = gfc_check_real_range (mpc_realref (result->value.complex)((result->value.complex)->re), kind);

if (rc == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    mpfr_set_ui (mpc_realref (result->value.complex)((result->value.complex)->re), 0, GFC_RND_MODEMPFR_RNDN);
  }
else if (rc != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if ((warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra) && src->ts.kind > kind)
  {
    int w = warn_conversionglobal_options.x_warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;

    if (wprecision_real_real (src->value.real, src->ts.kind, kind))
{
 gfc_warning_now (w, "Change of value in conversion from "
	   "%qs to %qs at %L",
	   gfc_typename (&src->ts), gfc_typename (&result->ts),
	   &src->where);
 /* Make sure the conversion warning is not emitted again.  */
 did_warn = true;
}
  }

if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra)
  gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
     "at %L", gfc_typename(&src->ts),
     gfc_typename(&result->ts), &src->where);

return result;
2387}


2390/* Convert complex to integer.  */

2392gfc_expr *
2393gfc_complex2int (gfc_expr *src, int kind)
2394{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_COMPLEX)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);

gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex)((src->value.complex)->re),
   &src->where);

if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if (warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra)
  {
    int w = warn_conversionglobal_options.x_warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;

    /* See if we discarded an imaginary part.  */
    if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0)mpfr_cmp_si_2exp((((src->value.complex)->im)),(0),0) != 0)
{
 gfc_warning_now (w, "Non-zero imaginary part discarded "
	   "in conversion from %qs to %qs at %L",
	   gfc_typename(&src->ts), gfc_typename (&result->ts),
	   &src->where);
 did_warn = true;
}

    else {
mpfr_t f;

mpfr_init (f);
mpfr_frac (f, src->value.real, GFC_RND_MODEMPFR_RNDN);
if (mpfr_cmp_si (f, 0)mpfr_cmp_si_2exp((f),(0),0) != 0)
 {
   gfc_warning_now (w, "Change of value in conversion from "
	     "%qs to %qs at %L", gfc_typename (&src->ts),
	     gfc_typename (&result->ts), &src->where);
   did_warn = true;
 }
mpfr_clear (f);
    }

    if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra)
{
 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
	   "at %L", gfc_typename (&src->ts),
	   gfc_typename (&result->ts), &src->where);
}
  }

return result;
2452}


2455/* Convert complex to real.  */

2457gfc_expr *
2458gfc_complex2real (gfc_expr *src, int kind)
2459{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_COMPLEX)
  return NULL__null;

result = gfc_get_constant_expr (BT_REAL, kind, &src->where);

mpc_real (result->value.real, src->value.complex, GFC_RND_MODEMPFR_RNDN);

rc = gfc_check_real_range (result->value.real, kind);

if (rc == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    mpfr_set_ui (result->value.real, 0, GFC_RND_MODEMPFR_RNDN);
  }
if (rc != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if (warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra)
  {
    int w = warn_conversionglobal_options.x_warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;

    /* See if we discarded an imaginary part.  */
    if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0)mpfr_cmp_si_2exp((((src->value.complex)->im)),(0),0) != 0)
{
 gfc_warning (w, "Non-zero imaginary part discarded "
       "in conversion from %qs to %qs at %L",
       gfc_typename(&src->ts), gfc_typename (&result->ts),
       &src->where);
 did_warn = true;
}

    /* Calculate the difference between the real constant and the rounded
value and check it against zero.  */

    if (kind > src->ts.kind
 && wprecision_real_real (mpc_realref (src->value.complex)((src->value.complex)->re),
		   src->ts.kind, kind))
{
 gfc_warning_now (w, "Change of value in conversion from "
	   "%qs to %qs at %L",
	   gfc_typename (&src->ts), gfc_typename (&result->ts),
	   &src->where);
 /* Make sure the conversion warning is not emitted again.  */
 did_warn = true;
}
  }

if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra)
  gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
     gfc_typename(&src->ts), gfc_typename (&result->ts),
     &src->where);

return result;
2522}


2525/* Convert complex to complex.  */

2527gfc_expr *
2528gfc_complex2complex (gfc_expr *src, int kind)
2529{
gfc_expr *result;
arith rc;
bool did_warn = false;

if (src->ts.type != BT_COMPLEX)
  return NULL__null;

result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);

mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE(((int)(MPFR_RNDN)) + ((int)(MPFR_RNDN) << 4)));

rc = gfc_check_real_range (mpc_realref (result->value.complex)((result->value.complex)->re), kind);

if (rc == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    mpfr_set_ui (mpc_realref (result->value.complex)((result->value.complex)->re), 0, GFC_RND_MODEMPFR_RNDN);
  }
else if (rc != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

rc = gfc_check_real_range (mpc_imagref (result->value.complex)((result->value.complex)->im), kind);

if (rc == ARITH_UNDERFLOW)
  {
    if (warn_underflowglobal_options.x_warn_underflow)
gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    mpfr_set_ui (mpc_imagref (result->value.complex)((result->value.complex)->im), 0, GFC_RND_MODEMPFR_RNDN);
  }
else if (rc != ARITH_OK)
  {
    arith_error (rc, &src->ts, &result->ts, &src->where);
    gfc_free_expr (result);
    return NULL__null;
  }

if ((warn_conversionglobal_options.x_warn_conversion || warn_conversion_extraglobal_options.x_warn_conversion_extra) && src->ts.kind > kind
    && (wprecision_real_real (mpc_realref (src->value.complex)((src->value.complex)->re),
		src->ts.kind, kind)
 || wprecision_real_real (mpc_imagref (src->value.complex)((src->value.complex)->im),
		   src->ts.kind, kind)))
  {
    int w = warn_conversionglobal_options.x_warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;

    gfc_warning_now (w, "Change of value in conversion from "
       "%qs to %qs at %L",
       gfc_typename (&src->ts), gfc_typename (&result->ts),
       &src->where);
    did_warn = true;
  }

if (!did_warn && warn_conversion_extraglobal_options.x_warn_conversion_extra && src->ts.kind != kind)
  gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
     "at %L", gfc_typename(&src->ts),
     gfc_typename (&result->ts), &src->where);

return result;
2592}


2595/* Logical kind conversion.  */

2597gfc_expr *
2598gfc_log2log (gfc_expr *src, int kind)
2599{
gfc_expr *result;

if (src->ts.type != BT_LOGICAL)
  return NULL__null;

result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = src->value.logical;

return result;
2609}


2612/* Convert logical to integer.  */

2614gfc_expr *
2615gfc_log2int (gfc_expr *src, int kind)
2616{
gfc_expr *result;

if (src->ts.type != BT_LOGICAL)
  return NULL__null;

result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
mpz_set_si__gmpz_set_si (result->value.integer, src->value.logical);

return result;
2626}


2629/* Convert integer to logical.  */

2631gfc_expr *
2632gfc_int2log (gfc_expr *src, int kind)
2633{
gfc_expr *result;

if (src->ts.type != BT_INTEGER)
  return NULL__null;

result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
result->value.logical = (mpz_cmp_si (src->value.integer, 0)(__builtin_constant_p ((0) >= 0) && (0) >= 0 ? (
__builtin_constant_p ((static_cast<unsigned long> (0)))
 && ((static_cast<unsigned long> (0))) == 0 ? (
(src->value.integer)->_mp_size < 0 ? -1 : (src->value
.integer)->_mp_size > 0) : __gmpz_cmp_ui (src->value
.integer,(static_cast<unsigned long> (0)))) : __gmpz_cmp_si
 (src->value.integer,0)) != 0);

return result;
2643}

2645/* Convert character to character. We only use wide strings internally,
 so we only set the kind.  */

2648gfc_expr *
2649gfc_character2character (gfc_expr *src, int kind)
2650{
gfc_expr *result;
result = gfc_copy_expr (src);
result->ts.kind = kind;

return result;
2656}

2658/* Helper function to set the representation in a Hollerith conversion.
 This assumes that the ts.type and ts.kind of the result have already
 been set.  */

2662static void
2663hollerith2representation (gfc_expr *result, gfc_expr *src)
2664{
size_t src_len, result_len;

src_len = src->representation.length - src->ts.u.pad;
gfc_target_expr_size (result, &result_len);

if (src_len > result_len)
  {
    gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
   "is truncated in conversion to %qs", &src->where,
   gfc_typename(&result->ts));
  }

result->representation.string = XCNEWVEC (char, result_len + 1)((char *) xcalloc ((result_len + 1), sizeof (char)));
memcpy (result->representation.string, src->representation.string,
 MIN (result_len, src_len)((result_len) < (src_len) ? (result_len) : (src_len)));

if (src_len < result_len)
  memset (&result->representation.string[src_len], ' ', result_len - src_len);

result->representation.string[result_len] = '\0'; /* For debugger  */
result->representation.length = result_len;
2686}


2689/* Helper function to set the representation in a character conversion.
 This assumes that the ts.type and ts.kind of the result have already
 been set.  */

2693static void
2694character2representation (gfc_expr *result, gfc_expr *src)
2695{
size_t src_len, result_len, i;
src_len = src->value.character.length;
gfc_target_expr_size (result, &result_len);

if (src_len > result_len)
  gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
 "truncated in conversion to %s", &src->where,
 gfc_typename(&result->ts));

result->representation.string = XCNEWVEC (char, result_len + 1)((char *) xcalloc ((result_len + 1), sizeof (char)));

for (i = 0; i < MIN (result_len, src_len)((result_len) < (src_len) ? (result_len) : (src_len)); i++)
  result->representation.string[i] = (char) src->value.character.string[i];

if (src_len < result_len)
  memset (&result->representation.string[src_len], ' ',
   result_len - src_len);

result->representation.string[result_len] = '\0'; /* For debugger.  */
result->representation.length = result_len;
2716}

2718/* Convert Hollerith to integer. The constant will be padded or truncated.  */

2720gfc_expr *
2721gfc_hollerith2int (gfc_expr *src, int kind)
2722{
gfc_expr *result;
result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);

hollerith2representation (result, src);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
	 result->representation.length, result->value.integer);

return result;
2731}

2733/* Convert character to integer.  The constant will be padded or truncated.  */

2735gfc_expr *
2736gfc_character2int (gfc_expr *src, int kind)
2737{
gfc_expr *result;
result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);

character2representation (result, src);
gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
	 result->representation.length, result->value.integer);
return result;
2745}

2747/* Convert Hollerith to real.  The constant will be padded or truncated.  */

2749gfc_expr *
2750gfc_hollerith2real (gfc_expr *src, int kind)
2751{
gfc_expr *result;
result = gfc_get_constant_expr (BT_REAL, kind, &src->where);

hollerith2representation (result, src);
if (gfc_interpret_float (kind,
	   (unsigned char *) result->representation.string,
	   result->representation.length, result->value.real))
  return result;
else
  return NULL__null;
2762}

2764/* Convert character to real.  The constant will be padded or truncated.  */

2766gfc_expr *
2767gfc_character2real (gfc_expr *src, int kind)
2768{
gfc_expr *result;
result = gfc_get_constant_expr (BT_REAL, kind, &src->where);

character2representation (result, src);
gfc_interpret_float (kind, (unsigned char *) result->representation.string,
       result->representation.length, result->value.real);

return result;
2777}


2780/* Convert Hollerith to complex. The constant will be padded or truncated.  */

2782gfc_expr *
2783gfc_hollerith2complex (gfc_expr *src, int kind)
2784{
gfc_expr *result;
result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);

hollerith2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
	 result->representation.length, result->value.complex);

return result;
2793}

2795/* Convert character to complex. The constant will be padded or truncated.  */

2797gfc_expr *
2798gfc_character2complex (gfc_expr *src, int kind)
2799{
gfc_expr *result;
result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);

character2representation (result, src);
gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
	 result->representation.length, result->value.complex);

return result;
2808}


2811/* Convert Hollerith to character.  */

2813gfc_expr *
2814gfc_hollerith2character (gfc_expr *src, int kind)
2815{
gfc_expr *result;

result = gfc_copy_expr (src);
result->ts.type = BT_CHARACTER;
result->ts.kind = kind;
result->ts.u.pad = 0;

result->value.character.length = result->representation.length;
result->value.character.string
  = gfc_char_to_widechar (result->representation.string);

return result;
2828}


2831/* Convert Hollerith to logical. The constant will be padded or truncated.  */

2833gfc_expr *
2834gfc_hollerith2logical (gfc_expr *src, int kind)
2835{
gfc_expr *result;
result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);

hollerith2representation (result, src);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
	 result->representation.length, &result->value.logical);

return result;
2844}

2846/* Convert character to logical. The constant will be padded or truncated.  */

2848gfc_expr *
2849gfc_character2logical (gfc_expr *src, int kind)
2850{
gfc_expr *result;
result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);

character2representation (result, src);
gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
	 result->representation.length, &result->value.logical);

return result;
2859}