LCOV - code coverage report
Current view: top level - gcc/fortran - arith.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 88.8 % 1299 1153
Test Date: 2023-09-09 13:19:57 Functions: 95.7 % 93 89
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Compiler arithmetic
       2                 :             :    Copyright (C) 2000-2023 Free Software Foundation, Inc.
       3                 :             :    Contributed by Andy Vaught
       4                 :             : 
       5                 :             : This file is part of GCC.
       6                 :             : 
       7                 :             : GCC is free software; you can redistribute it and/or modify it under
       8                 :             : the terms of the GNU General Public License as published by the Free
       9                 :             : Software Foundation; either version 3, or (at your option) any later
      10                 :             : version.
      11                 :             : 
      12                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      13                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      14                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      15                 :             : for more details.
      16                 :             : 
      17                 :             : You should have received a copy of the GNU General Public License
      18                 :             : along with GCC; see the file COPYING3.  If not see
      19                 :             : <http://www.gnu.org/licenses/>.  */
      20                 :             : 
      21                 :             : /* Since target arithmetic must be done on the host, there has to
      22                 :             :    be some way of evaluating arithmetic expressions as the host
      23                 :             :    would evaluate them.  We use the GNU MP library and the MPFR
      24                 :             :    library to do arithmetic, and this file provides the interface.  */
      25                 :             : 
      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"
      34                 :             : 
      35                 :             : bool gfc_seen_div0;
      36                 :             : 
      37                 :             : /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
      38                 :             :    It's easily implemented with a few calls though.  */
      39                 :             : 
      40                 :             : void
      41                 :         732 : gfc_mpfr_to_mpz (mpz_t z, mpfr_t x, locus *where)
      42                 :             : {
      43                 :         732 :   mpfr_exp_t e;
      44                 :             : 
      45                 :         732 :   if (mpfr_inf_p (x) || mpfr_nan_p (x))
      46                 :             :     {
      47                 :           1 :       gfc_error ("Conversion of an Infinity or Not-a-Number at %L "
      48                 :             :                  "to INTEGER", where);
      49                 :           1 :       mpz_set_ui (z, 0);
      50                 :           1 :       return;
      51                 :             :     }
      52                 :             : 
      53                 :         731 :   e = mpfr_get_z_exp (z, x);
      54                 :             : 
      55                 :         731 :   if (e > 0)
      56                 :          24 :     mpz_mul_2exp (z, z, e);
      57                 :             :   else
      58                 :         707 :     mpz_tdiv_q_2exp (z, z, -e);
      59                 :             : }
      60                 :             : 
      61                 :             : 
      62                 :             : /* Set the model number precision by the requested KIND.  */
      63                 :             : 
      64                 :             : void
      65                 :      733534 : gfc_set_model_kind (int kind)
      66                 :             : {
      67                 :      733534 :   int index = gfc_validate_kind (BT_REAL, kind, false);
      68                 :      733534 :   int base2prec;
      69                 :             : 
      70                 :      733534 :   base2prec = gfc_real_kinds[index].digits;
      71                 :      733534 :   if (gfc_real_kinds[index].radix != 2)
      72                 :           0 :     base2prec *= gfc_real_kinds[index].radix / 2;
      73                 :      733534 :   mpfr_set_default_prec (base2prec);
      74                 :      733534 : }
      75                 :             : 
      76                 :             : 
      77                 :             : /* Set the model number precision from mpfr_t x.  */
      78                 :             : 
      79                 :             : void
      80                 :      378788 : gfc_set_model (mpfr_t x)
      81                 :             : {
      82                 :      378788 :   mpfr_set_default_prec (mpfr_get_prec (x));
      83                 :      378788 : }
      84                 :             : 
      85                 :             : 
      86                 :             : /* Given an arithmetic error code, return a pointer to a string that
      87                 :             :    explains the error.  */
      88                 :             : 
      89                 :             : static const char *
      90                 :         140 : gfc_arith_error (arith code)
      91                 :             : {
      92                 :         140 :   const char *p;
      93                 :             : 
      94                 :         140 :   switch (code)
      95                 :             :     {
      96                 :             :     case ARITH_OK:
      97                 :             :       p = G_("Arithmetic OK at %L");
      98                 :             :       break;
      99                 :          17 :     case ARITH_OVERFLOW:
     100                 :          17 :       p = G_("Arithmetic overflow at %L");
     101                 :          17 :       break;
     102                 :           3 :     case ARITH_UNDERFLOW:
     103                 :           3 :       p = G_("Arithmetic underflow at %L");
     104                 :           3 :       break;
     105                 :           0 :     case ARITH_NAN:
     106                 :           0 :       p = G_("Arithmetic NaN at %L");
     107                 :           0 :       break;
     108                 :          33 :     case ARITH_DIV0:
     109                 :          33 :       p = G_("Division by zero at %L");
     110                 :          33 :       break;
     111                 :           0 :     case ARITH_INCOMMENSURATE:
     112                 :           0 :       p = G_("Array operands are incommensurate at %L");
     113                 :           0 :       break;
     114                 :          86 :     case ARITH_ASYMMETRIC:
     115                 :          86 :       p = G_("Integer outside symmetric range implied by Standard Fortran"
     116                 :             :              " at %L");
     117                 :          86 :       break;
     118                 :           1 :     case ARITH_WRONGCONCAT:
     119                 :           1 :       p = G_("Illegal type in character concatenation at %L");
     120                 :           1 :       break;
     121                 :           0 :     case ARITH_INVALID_TYPE:
     122                 :           0 :       p = G_("Invalid type in arithmetic operation at %L");
     123                 :           0 :       break;
     124                 :             : 
     125                 :           0 :     default:
     126                 :           0 :       gfc_internal_error ("gfc_arith_error(): Bad error code");
     127                 :             :     }
     128                 :             : 
     129                 :         140 :   return p;
     130                 :             : }
     131                 :             : 
     132                 :             : 
     133                 :             : /* Get things ready to do math.  */
     134                 :             : 
     135                 :             : void
     136                 :       29017 : gfc_arith_init_1 (void)
     137                 :             : {
     138                 :       29017 :   gfc_integer_info *int_info;
     139                 :       29017 :   gfc_real_info *real_info;
     140                 :       29017 :   mpfr_t a, b;
     141                 :       29017 :   int i;
     142                 :             : 
     143                 :       29017 :   mpfr_set_default_prec (128);
     144                 :       29017 :   mpfr_init (a);
     145                 :             : 
     146                 :             :   /* Convert the minimum and maximum values for each kind into their
     147                 :             :      GNU MP representation.  */
     148                 :      202712 :   for (int_info = gfc_integer_kinds; int_info->kind != 0; int_info++)
     149                 :             :     {
     150                 :             :       /* Huge  */
     151                 :      144678 :       mpz_init (int_info->huge);
     152                 :      144678 :       mpz_set_ui (int_info->huge, int_info->radix);
     153                 :      144678 :       mpz_pow_ui (int_info->huge, int_info->huge, int_info->digits);
     154                 :      144678 :       mpz_sub_ui (int_info->huge, int_info->huge, 1);
     155                 :             : 
     156                 :             :       /* These are the numbers that are actually representable by the
     157                 :             :          target.  For bases other than two, this needs to be changed.  */
     158                 :      144678 :       if (int_info->radix != 2)
     159                 :           0 :         gfc_internal_error ("Fix min_int calculation");
     160                 :             : 
     161                 :             :       /* See PRs 13490 and 17912, related to integer ranges.
     162                 :             :          The pedantic_min_int exists for range checking when a program
     163                 :             :          is compiled with -pedantic, and reflects the belief that
     164                 :             :          Standard Fortran requires integers to be symmetrical, i.e.
     165                 :             :          every negative integer must have a representable positive
     166                 :             :          absolute value, and vice versa.  */
     167                 :             : 
     168                 :      144678 :       mpz_init (int_info->pedantic_min_int);
     169                 :      144678 :       mpz_neg (int_info->pedantic_min_int, int_info->huge);
     170                 :             : 
     171                 :      144678 :       mpz_init (int_info->min_int);
     172                 :      144678 :       mpz_sub_ui (int_info->min_int, int_info->pedantic_min_int, 1);
     173                 :             : 
     174                 :             :       /* Range  */
     175                 :      144678 :       mpfr_set_z (a, int_info->huge, GFC_RND_MODE);
     176                 :      144678 :       mpfr_log10 (a, a, GFC_RND_MODE);
     177                 :      144678 :       mpfr_trunc (a, a);
     178                 :      144678 :       int_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
     179                 :             :     }
     180                 :             : 
     181                 :       29017 :   mpfr_clear (a);
     182                 :             : 
     183                 :      174102 :   for (real_info = gfc_real_kinds; real_info->kind != 0; real_info++)
     184                 :             :     {
     185                 :      116068 :       gfc_set_model_kind (real_info->kind);
     186                 :             : 
     187                 :      116068 :       mpfr_init (a);
     188                 :      116068 :       mpfr_init (b);
     189                 :             : 
     190                 :             :       /* huge(x) = (1 - b**(-p)) * b**(emax-1) * b  */
     191                 :             :       /* 1 - b**(-p)  */
     192                 :      116068 :       mpfr_init (real_info->huge);
     193                 :      116068 :       mpfr_set_ui (real_info->huge, 1, GFC_RND_MODE);
     194                 :      116068 :       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
     195                 :      116068 :       mpfr_pow_si (a, a, -real_info->digits, GFC_RND_MODE);
     196                 :      116068 :       mpfr_sub (real_info->huge, real_info->huge, a, GFC_RND_MODE);
     197                 :             : 
     198                 :             :       /* b**(emax-1)  */
     199                 :      116068 :       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
     200                 :      116068 :       mpfr_pow_ui (a, a, real_info->max_exponent - 1, GFC_RND_MODE);
     201                 :             : 
     202                 :             :       /* (1 - b**(-p)) * b**(emax-1)  */
     203                 :      116068 :       mpfr_mul (real_info->huge, real_info->huge, a, GFC_RND_MODE);
     204                 :             : 
     205                 :             :       /* (1 - b**(-p)) * b**(emax-1) * b  */
     206                 :      116068 :       mpfr_mul_ui (real_info->huge, real_info->huge, real_info->radix,
     207                 :             :                    GFC_RND_MODE);
     208                 :             : 
     209                 :             :       /* tiny(x) = b**(emin-1)  */
     210                 :      116068 :       mpfr_init (real_info->tiny);
     211                 :      116068 :       mpfr_set_ui (real_info->tiny, real_info->radix, GFC_RND_MODE);
     212                 :      116068 :       mpfr_pow_si (real_info->tiny, real_info->tiny,
     213                 :      116068 :                    real_info->min_exponent - 1, GFC_RND_MODE);
     214                 :             : 
     215                 :             :       /* subnormal (x) = b**(emin - digit)  */
     216                 :      116068 :       mpfr_init (real_info->subnormal);
     217                 :      116068 :       mpfr_set_ui (real_info->subnormal, real_info->radix, GFC_RND_MODE);
     218                 :      116068 :       mpfr_pow_si (real_info->subnormal, real_info->subnormal,
     219                 :      116068 :                    real_info->min_exponent - real_info->digits, GFC_RND_MODE);
     220                 :             : 
     221                 :             :       /* epsilon(x) = b**(1-p)  */
     222                 :      116068 :       mpfr_init (real_info->epsilon);
     223                 :      116068 :       mpfr_set_ui (real_info->epsilon, real_info->radix, GFC_RND_MODE);
     224                 :      116068 :       mpfr_pow_si (real_info->epsilon, real_info->epsilon,
     225                 :      116068 :                    1 - real_info->digits, GFC_RND_MODE);
     226                 :             : 
     227                 :             :       /* range(x) = int(min(log10(huge(x)), -log10(tiny))  */
     228                 :      116068 :       mpfr_log10 (a, real_info->huge, GFC_RND_MODE);
     229                 :      116068 :       mpfr_log10 (b, real_info->tiny, GFC_RND_MODE);
     230                 :      116068 :       mpfr_neg (b, b, GFC_RND_MODE);
     231                 :             : 
     232                 :             :       /* a = min(a, b)  */
     233                 :      116068 :       mpfr_min (a, a, b, GFC_RND_MODE);
     234                 :      116068 :       mpfr_trunc (a, a);
     235                 :      116068 :       real_info->range = (int) mpfr_get_si (a, GFC_RND_MODE);
     236                 :             : 
     237                 :             :       /* precision(x) = int((p - 1) * log10(b)) + k  */
     238                 :      116068 :       mpfr_set_ui (a, real_info->radix, GFC_RND_MODE);
     239                 :      116068 :       mpfr_log10 (a, a, GFC_RND_MODE);
     240                 :      116068 :       mpfr_mul_ui (a, a, real_info->digits - 1, GFC_RND_MODE);
     241                 :      116068 :       mpfr_trunc (a, a);
     242                 :      116068 :       real_info->precision = (int) mpfr_get_si (a, GFC_RND_MODE);
     243                 :             : 
     244                 :             :       /* If the radix is an integral power of 10, add one to the precision.  */
     245                 :      116068 :       for (i = 10; i <= real_info->radix; i *= 10)
     246                 :           0 :         if (i == real_info->radix)
     247                 :           0 :           real_info->precision++;
     248                 :             : 
     249                 :      116068 :       mpfr_clears (a, b, NULL);
     250                 :             :     }
     251                 :       29017 : }
     252                 :             : 
     253                 :             : 
     254                 :             : /* Clean up, get rid of numeric constants.  */
     255                 :             : 
     256                 :             : void
     257                 :       29000 : gfc_arith_done_1 (void)
     258                 :             : {
     259                 :       29000 :   gfc_integer_info *ip;
     260                 :       29000 :   gfc_real_info *rp;
     261                 :             : 
     262                 :      173593 :   for (ip = gfc_integer_kinds; ip->kind; ip++)
     263                 :             :     {
     264                 :      144593 :       mpz_clear (ip->min_int);
     265                 :      144593 :       mpz_clear (ip->pedantic_min_int);
     266                 :      144593 :       mpz_clear (ip->huge);
     267                 :             :     }
     268                 :             : 
     269                 :      145000 :   for (rp = gfc_real_kinds; rp->kind; rp++)
     270                 :      116000 :     mpfr_clears (rp->epsilon, rp->huge, rp->tiny, rp->subnormal, NULL);
     271                 :             : 
     272                 :       29000 :   mpfr_free_cache ();
     273                 :       29000 : }
     274                 :             : 
     275                 :             : 
     276                 :             : /* Given a wide character value and a character kind, determine whether
     277                 :             :    the character is representable for that kind.  */
     278                 :             : bool
     279                 :     1659862 : gfc_check_character_range (gfc_char_t c, int kind)
     280                 :             : {
     281                 :             :   /* As wide characters are stored as 32-bit values, they're all
     282                 :             :      representable in UCS=4.  */
     283                 :     1659862 :   if (kind == 4)
     284                 :             :     return true;
     285                 :             : 
     286                 :     1488499 :   if (kind == 1)
     287                 :     1488499 :     return c <= 255 ? true : false;
     288                 :             : 
     289                 :           0 :   gcc_unreachable ();
     290                 :             : }
     291                 :             : 
     292                 :             : 
     293                 :             : /* Given an integer and a kind, make sure that the integer lies within
     294                 :             :    the range of the kind.  Returns ARITH_OK, ARITH_ASYMMETRIC or
     295                 :             :    ARITH_OVERFLOW.  */
     296                 :             : 
     297                 :             : arith
     298                 :    15074952 : gfc_check_integer_range (mpz_t p, int kind)
     299                 :             : {
     300                 :    15074952 :   arith result;
     301                 :    15074952 :   int i;
     302                 :             : 
     303                 :    15074952 :   i = gfc_validate_kind (BT_INTEGER, kind, false);
     304                 :    15074952 :   result = ARITH_OK;
     305                 :             : 
     306                 :    15074952 :   if (pedantic)
     307                 :             :     {
     308                 :    13051958 :       if (mpz_cmp (p, gfc_integer_kinds[i].pedantic_min_int) < 0)
     309                 :    15074952 :         result = ARITH_ASYMMETRIC;
     310                 :             :     }
     311                 :             : 
     312                 :             : 
     313                 :    15074952 :   if (flag_range_check == 0)
     314                 :             :     return result;
     315                 :             : 
     316                 :    15045526 :   if (mpz_cmp (p, gfc_integer_kinds[i].min_int) < 0
     317                 :    15045526 :       || mpz_cmp (p, gfc_integer_kinds[i].huge) > 0)
     318                 :    15074952 :     result = ARITH_OVERFLOW;
     319                 :             : 
     320                 :             :   return result;
     321                 :             : }
     322                 :             : 
     323                 :             : 
     324                 :             : /* Given a real and a kind, make sure that the real lies within the
     325                 :             :    range of the kind.  Returns ARITH_OK, ARITH_OVERFLOW or
     326                 :             :    ARITH_UNDERFLOW.  */
     327                 :             : 
     328                 :             : static arith
     329                 :      377318 : gfc_check_real_range (mpfr_t p, int kind)
     330                 :             : {
     331                 :      377318 :   arith retval;
     332                 :      377318 :   mpfr_t q;
     333                 :      377318 :   int i;
     334                 :             : 
     335                 :      377318 :   i = gfc_validate_kind (BT_REAL, kind, false);
     336                 :             : 
     337                 :      377318 :   gfc_set_model (p);
     338                 :      377318 :   mpfr_init (q);
     339                 :      377318 :   mpfr_abs (q, p, GFC_RND_MODE);
     340                 :             : 
     341                 :      377318 :   retval = ARITH_OK;
     342                 :             : 
     343                 :      377318 :   if (mpfr_inf_p (p))
     344                 :             :     {
     345                 :        1136 :       if (flag_range_check != 0)
     346                 :          15 :         retval = ARITH_OVERFLOW;
     347                 :             :     }
     348                 :      376182 :   else if (mpfr_nan_p (p))
     349                 :             :     {
     350                 :         211 :       if (flag_range_check != 0)
     351                 :      315095 :         retval = ARITH_NAN;
     352                 :             :     }
     353                 :      375971 :   else if (mpfr_sgn (q) == 0)
     354                 :             :     {
     355                 :       62223 :       mpfr_clear (q);
     356                 :       62223 :       return retval;
     357                 :             :     }
     358                 :      313748 :   else if (mpfr_cmp (q, gfc_real_kinds[i].huge) > 0)
     359                 :             :     {
     360                 :          43 :       if (flag_range_check == 0)
     361                 :          39 :         mpfr_set_inf (p, mpfr_sgn (p));
     362                 :             :       else
     363                 :             :         retval = ARITH_OVERFLOW;
     364                 :             :     }
     365                 :      313705 :   else if (mpfr_cmp (q, gfc_real_kinds[i].subnormal) < 0)
     366                 :             :     {
     367                 :          22 :       if (flag_range_check == 0)
     368                 :             :         {
     369                 :          13 :           if (mpfr_sgn (p) < 0)
     370                 :             :             {
     371                 :           6 :               mpfr_set_ui (p, 0, GFC_RND_MODE);
     372                 :           6 :               mpfr_set_si (q, -1, GFC_RND_MODE);
     373                 :           6 :               mpfr_copysign (p, p, q, GFC_RND_MODE);
     374                 :             :             }
     375                 :             :           else
     376                 :           7 :             mpfr_set_ui (p, 0, GFC_RND_MODE);
     377                 :             :         }
     378                 :             :       else
     379                 :             :         retval = ARITH_UNDERFLOW;
     380                 :             :     }
     381                 :      313683 :   else if (mpfr_cmp (q, gfc_real_kinds[i].tiny) < 0)
     382                 :             :     {
     383                 :         156 :       mpfr_exp_t emin, emax;
     384                 :         156 :       int en;
     385                 :             : 
     386                 :             :       /* Save current values of emin and emax.  */
     387                 :         156 :       emin = mpfr_get_emin ();
     388                 :         156 :       emax = mpfr_get_emax ();
     389                 :             : 
     390                 :             :       /* Set emin and emax for the current model number.  */
     391                 :         156 :       en = gfc_real_kinds[i].min_exponent - gfc_real_kinds[i].digits + 1;
     392                 :         156 :       mpfr_set_emin ((mpfr_exp_t) en);
     393                 :         156 :       mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[i].max_exponent);
     394                 :         156 :       mpfr_check_range (q, 0, GFC_RND_MODE);
     395                 :         156 :       mpfr_subnormalize (q, 0, GFC_RND_MODE);
     396                 :             : 
     397                 :             :       /* Reset emin and emax.  */
     398                 :         156 :       mpfr_set_emin (emin);
     399                 :         156 :       mpfr_set_emax (emax);
     400                 :             : 
     401                 :             :       /* Copy sign if needed.  */
     402                 :         156 :       if (mpfr_sgn (p) < 0)
     403                 :          24 :         mpfr_neg (p, q, MPFR_RNDN);
     404                 :             :       else
     405                 :         132 :         mpfr_set (p, q, MPFR_RNDN);
     406                 :             :     }
     407                 :             : 
     408                 :      315095 :   mpfr_clear (q);
     409                 :             : 
     410                 :      315095 :   return retval;
     411                 :             : }
     412                 :             : 
     413                 :             : 
     414                 :             : /* Low-level arithmetic functions.  All of these subroutines assume
     415                 :             :    that all operands are of the same type and return an operand of the
     416                 :             :    same type.  The other thing about these subroutines is that they
     417                 :             :    can fail in various ways -- overflow, underflow, division by zero,
     418                 :             :    zero raised to the zero, etc.  */
     419                 :             : 
     420                 :             : static arith
     421                 :         499 : gfc_arith_not (gfc_expr *op1, gfc_expr **resultp)
     422                 :             : {
     423                 :         499 :   gfc_expr *result;
     424                 :             : 
     425                 :         499 :   if (op1->ts.type != BT_LOGICAL)
     426                 :             :     return ARITH_INVALID_TYPE;
     427                 :             : 
     428                 :         499 :   result = gfc_get_constant_expr (BT_LOGICAL, op1->ts.kind, &op1->where);
     429                 :         499 :   result->value.logical = !op1->value.logical;
     430                 :         499 :   *resultp = result;
     431                 :             : 
     432                 :         499 :   return ARITH_OK;
     433                 :             : }
     434                 :             : 
     435                 :             : 
     436                 :             : static arith
     437                 :        1332 : gfc_arith_and (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     438                 :             : {
     439                 :        1332 :   gfc_expr *result;
     440                 :             : 
     441                 :        1332 :   if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
     442                 :             :     return ARITH_INVALID_TYPE;
     443                 :             : 
     444                 :        1331 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
     445                 :             :                                   &op1->where);
     446                 :        1331 :   result->value.logical = op1->value.logical && op2->value.logical;
     447                 :        1331 :   *resultp = result;
     448                 :             : 
     449                 :        1331 :   return ARITH_OK;
     450                 :             : }
     451                 :             : 
     452                 :             : 
     453                 :             : static arith
     454                 :        6785 : gfc_arith_or (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     455                 :             : {
     456                 :        6785 :   gfc_expr *result;
     457                 :             : 
     458                 :        6785 :   if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
     459                 :             :     return ARITH_INVALID_TYPE;
     460                 :             : 
     461                 :        6784 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
     462                 :             :                                   &op1->where);
     463                 :        6784 :   result->value.logical = op1->value.logical || op2->value.logical;
     464                 :        6784 :   *resultp = result;
     465                 :             : 
     466                 :        6784 :   return ARITH_OK;
     467                 :             : }
     468                 :             : 
     469                 :             : 
     470                 :             : static arith
     471                 :          13 : gfc_arith_eqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     472                 :             : {
     473                 :          13 :   gfc_expr *result;
     474                 :             : 
     475                 :          13 :   if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
     476                 :             :     return ARITH_INVALID_TYPE;
     477                 :             : 
     478                 :          12 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
     479                 :             :                                   &op1->where);
     480                 :          12 :   result->value.logical = op1->value.logical == op2->value.logical;
     481                 :          12 :   *resultp = result;
     482                 :             : 
     483                 :          12 :   return ARITH_OK;
     484                 :             : }
     485                 :             : 
     486                 :             : 
     487                 :             : static arith
     488                 :        1130 : gfc_arith_neqv (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     489                 :             : {
     490                 :        1130 :   gfc_expr *result;
     491                 :             : 
     492                 :        1130 :   if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
     493                 :             :     return ARITH_INVALID_TYPE;
     494                 :             : 
     495                 :        1129 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_kind_max (op1, op2),
     496                 :             :                                   &op1->where);
     497                 :        1129 :   result->value.logical = op1->value.logical != op2->value.logical;
     498                 :        1129 :   *resultp = result;
     499                 :             : 
     500                 :        1129 :   return ARITH_OK;
     501                 :             : }
     502                 :             : 
     503                 :             : 
     504                 :             : /* Make sure a constant numeric expression is within the range for
     505                 :             :    its type and kind.  Note that there's also a gfc_check_range(),
     506                 :             :    but that one deals with the intrinsic RANGE function.  */
     507                 :             : 
     508                 :             : arith
     509                 :    15315432 : gfc_range_check (gfc_expr *e)
     510                 :             : {
     511                 :    15315432 :   arith rc;
     512                 :    15315432 :   arith rc2;
     513                 :             : 
     514                 :    15315432 :   switch (e->ts.type)
     515                 :             :     {
     516                 :    15014738 :     case BT_INTEGER:
     517                 :    15014738 :       rc = gfc_check_integer_range (e->value.integer, e->ts.kind);
     518                 :    15014738 :       break;
     519                 :             : 
     520                 :      293715 :     case BT_REAL:
     521                 :      293715 :       rc = gfc_check_real_range (e->value.real, e->ts.kind);
     522                 :      293715 :       if (rc == ARITH_UNDERFLOW)
     523                 :           9 :         mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
     524                 :      293715 :       if (rc == ARITH_OVERFLOW)
     525                 :          10 :         mpfr_set_inf (e->value.real, mpfr_sgn (e->value.real));
     526                 :      293715 :       if (rc == ARITH_NAN)
     527                 :           0 :         mpfr_set_nan (e->value.real);
     528                 :             :       break;
     529                 :             : 
     530                 :        6979 :     case BT_COMPLEX:
     531                 :        6979 :       rc = gfc_check_real_range (mpc_realref (e->value.complex), e->ts.kind);
     532                 :        6979 :       if (rc == ARITH_UNDERFLOW)
     533                 :           0 :         mpfr_set_ui (mpc_realref (e->value.complex), 0, GFC_RND_MODE);
     534                 :        6979 :       if (rc == ARITH_OVERFLOW)
     535                 :           2 :         mpfr_set_inf (mpc_realref (e->value.complex),
     536                 :           2 :                       mpfr_sgn (mpc_realref (e->value.complex)));
     537                 :        6979 :       if (rc == ARITH_NAN)
     538                 :           0 :         mpfr_set_nan (mpc_realref (e->value.complex));
     539                 :             : 
     540                 :        6979 :       rc2 = gfc_check_real_range (mpc_imagref (e->value.complex), e->ts.kind);
     541                 :        6979 :       if (rc == ARITH_UNDERFLOW)
     542                 :           0 :         mpfr_set_ui (mpc_imagref (e->value.complex), 0, GFC_RND_MODE);
     543                 :        6979 :       if (rc == ARITH_OVERFLOW)
     544                 :           2 :         mpfr_set_inf (mpc_imagref (e->value.complex),
     545                 :           2 :                       mpfr_sgn (mpc_imagref (e->value.complex)));
     546                 :        6979 :       if (rc == ARITH_NAN)
     547                 :           0 :         mpfr_set_nan (mpc_imagref (e->value.complex));
     548                 :             : 
     549                 :        6979 :       if (rc == ARITH_OK)
     550                 :        6977 :         rc = rc2;
     551                 :             :       break;
     552                 :             : 
     553                 :           0 :     default:
     554                 :           0 :       gfc_internal_error ("gfc_range_check(): Bad type");
     555                 :             :     }
     556                 :             : 
     557                 :    15315432 :   return rc;
     558                 :             : }
     559                 :             : 
     560                 :             : 
     561                 :             : /* Several of the following routines use the same set of statements to
     562                 :             :    check the validity of the result.  Encapsulate the checking here.  */
     563                 :             : 
     564                 :             : static arith
     565                 :    11300375 : check_result (arith rc, gfc_expr *x, gfc_expr *r, gfc_expr **rp)
     566                 :             : {
     567                 :    11300375 :   arith val = rc;
     568                 :             : 
     569                 :    11300375 :   if (val == ARITH_UNDERFLOW)
     570                 :             :     {
     571                 :           9 :       if (warn_underflow)
     572                 :           3 :         gfc_warning (OPT_Wunderflow, gfc_arith_error (val), &x->where);
     573                 :             :       val = ARITH_OK;
     574                 :             :     }
     575                 :             : 
     576                 :    11300366 :   if (val == ARITH_ASYMMETRIC)
     577                 :             :     {
     578                 :          86 :       gfc_warning (0, gfc_arith_error (val), &x->where);
     579                 :          86 :       val = ARITH_OK;
     580                 :             :     }
     581                 :             : 
     582                 :    11300375 :   if (val == ARITH_OK || val == ARITH_OVERFLOW)
     583                 :    11300342 :     *rp = r;
     584                 :             :   else
     585                 :          33 :     gfc_free_expr (r);
     586                 :             : 
     587                 :    11300375 :   return val;
     588                 :             : }
     589                 :             : 
     590                 :             : 
     591                 :             : /* It may seem silly to have a subroutine that actually computes the
     592                 :             :    unary plus of a constant, but it prevents us from making exceptions
     593                 :             :    in the code elsewhere.  Used for unary plus and parenthesized
     594                 :             :    expressions.  */
     595                 :             : 
     596                 :             : static arith
     597                 :         345 : gfc_arith_identity (gfc_expr *op1, gfc_expr **resultp)
     598                 :             : {
     599                 :         345 :   *resultp = gfc_copy_expr (op1);
     600                 :         345 :   return ARITH_OK;
     601                 :             : }
     602                 :             : 
     603                 :             : 
     604                 :             : static arith
     605                 :      125084 : gfc_arith_uminus (gfc_expr *op1, gfc_expr **resultp)
     606                 :             : {
     607                 :      125084 :   gfc_expr *result;
     608                 :      125084 :   arith rc;
     609                 :             : 
     610                 :      125084 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     611                 :             : 
     612                 :      125084 :   switch (op1->ts.type)
     613                 :             :     {
     614                 :       94135 :     case BT_INTEGER:
     615                 :       94135 :       mpz_neg (result->value.integer, op1->value.integer);
     616                 :       94135 :       break;
     617                 :             : 
     618                 :       30949 :     case BT_REAL:
     619                 :       30949 :       mpfr_neg (result->value.real, op1->value.real, GFC_RND_MODE);
     620                 :       30949 :       break;
     621                 :             : 
     622                 :           0 :     case BT_COMPLEX:
     623                 :           0 :       mpc_neg (result->value.complex, op1->value.complex, GFC_MPC_RND_MODE);
     624                 :           0 :       break;
     625                 :             : 
     626                 :           0 :     default:
     627                 :           0 :       gfc_internal_error ("gfc_arith_uminus(): Bad basic type");
     628                 :             :     }
     629                 :             : 
     630                 :      125084 :   rc = gfc_range_check (result);
     631                 :             : 
     632                 :      125084 :   return check_result (rc, op1, result, resultp);
     633                 :             : }
     634                 :             : 
     635                 :             : 
     636                 :             : static arith
     637                 :    10348631 : gfc_arith_plus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     638                 :             : {
     639                 :    10348631 :   gfc_expr *result;
     640                 :    10348631 :   arith rc;
     641                 :             : 
     642                 :    10348631 :   if (op1->ts.type != op2->ts.type)
     643                 :             :     return ARITH_INVALID_TYPE;
     644                 :             : 
     645                 :    10348630 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     646                 :             : 
     647                 :    10348630 :   switch (op1->ts.type)
     648                 :             :     {
     649                 :    10345723 :     case BT_INTEGER:
     650                 :    10345723 :       mpz_add (result->value.integer, op1->value.integer, op2->value.integer);
     651                 :    10345723 :       break;
     652                 :             : 
     653                 :        2901 :     case BT_REAL:
     654                 :        2901 :       mpfr_add (result->value.real, op1->value.real, op2->value.real,
     655                 :             :                GFC_RND_MODE);
     656                 :        2901 :       break;
     657                 :             : 
     658                 :           6 :     case BT_COMPLEX:
     659                 :           6 :       mpc_add (result->value.complex, op1->value.complex, op2->value.complex,
     660                 :             :                GFC_MPC_RND_MODE);
     661                 :           6 :       break;
     662                 :             : 
     663                 :           0 :     default:
     664                 :           0 :       gfc_internal_error ("gfc_arith_plus(): Bad basic type");
     665                 :             :     }
     666                 :             : 
     667                 :    10348630 :   rc = gfc_range_check (result);
     668                 :             : 
     669                 :    10348630 :   return check_result (rc, op1, result, resultp);
     670                 :             : }
     671                 :             : 
     672                 :             : 
     673                 :             : static arith
     674                 :      510142 : gfc_arith_minus (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     675                 :             : {
     676                 :      510142 :   gfc_expr *result;
     677                 :      510142 :   arith rc;
     678                 :             : 
     679                 :      510142 :   if (op1->ts.type != op2->ts.type)
     680                 :             :     return ARITH_INVALID_TYPE;
     681                 :             : 
     682                 :      510141 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     683                 :             : 
     684                 :      510141 :   switch (op1->ts.type)
     685                 :             :     {
     686                 :      509112 :     case BT_INTEGER:
     687                 :      509112 :       mpz_sub (result->value.integer, op1->value.integer, op2->value.integer);
     688                 :      509112 :       break;
     689                 :             : 
     690                 :         929 :     case BT_REAL:
     691                 :         929 :       mpfr_sub (result->value.real, op1->value.real, op2->value.real,
     692                 :             :                 GFC_RND_MODE);
     693                 :         929 :       break;
     694                 :             : 
     695                 :         100 :     case BT_COMPLEX:
     696                 :         100 :       mpc_sub (result->value.complex, op1->value.complex,
     697                 :         100 :                op2->value.complex, GFC_MPC_RND_MODE);
     698                 :         100 :       break;
     699                 :             : 
     700                 :           0 :     default:
     701                 :           0 :       gfc_internal_error ("gfc_arith_minus(): Bad basic type");
     702                 :             :     }
     703                 :             : 
     704                 :      510141 :   rc = gfc_range_check (result);
     705                 :             : 
     706                 :      510141 :   return check_result (rc, op1, result, resultp);
     707                 :             : }
     708                 :             : 
     709                 :             : 
     710                 :             : static arith
     711                 :      303265 : gfc_arith_times (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     712                 :             : {
     713                 :      303265 :   gfc_expr *result;
     714                 :      303265 :   arith rc;
     715                 :             : 
     716                 :      303265 :   if (op1->ts.type != op2->ts.type)
     717                 :             :     return ARITH_INVALID_TYPE;
     718                 :             : 
     719                 :      303263 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     720                 :             : 
     721                 :      303263 :   switch (op1->ts.type)
     722                 :             :     {
     723                 :      291107 :     case BT_INTEGER:
     724                 :      291107 :       mpz_mul (result->value.integer, op1->value.integer, op2->value.integer);
     725                 :      291107 :       break;
     726                 :             : 
     727                 :       10953 :     case BT_REAL:
     728                 :       10953 :       mpfr_mul (result->value.real, op1->value.real, op2->value.real,
     729                 :             :                GFC_RND_MODE);
     730                 :       10953 :       break;
     731                 :             : 
     732                 :        1203 :     case BT_COMPLEX:
     733                 :        1203 :       gfc_set_model (mpc_realref (op1->value.complex));
     734                 :        1203 :       mpc_mul (result->value.complex, op1->value.complex, op2->value.complex,
     735                 :             :                GFC_MPC_RND_MODE);
     736                 :        1203 :       break;
     737                 :             : 
     738                 :           0 :     default:
     739                 :           0 :       gfc_internal_error ("gfc_arith_times(): Bad basic type");
     740                 :             :     }
     741                 :             : 
     742                 :      303263 :   rc = gfc_range_check (result);
     743                 :             : 
     744                 :      303263 :   return check_result (rc, op1, result, resultp);
     745                 :             : }
     746                 :             : 
     747                 :             : 
     748                 :             : static arith
     749                 :        7275 : gfc_arith_divide (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     750                 :             : {
     751                 :        7275 :   gfc_expr *result;
     752                 :        7275 :   arith rc;
     753                 :             : 
     754                 :        7275 :   if (op1->ts.type != op2->ts.type)
     755                 :             :     return ARITH_INVALID_TYPE;
     756                 :             : 
     757                 :        7273 :   rc = ARITH_OK;
     758                 :             : 
     759                 :        7273 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     760                 :             : 
     761                 :        7273 :   switch (op1->ts.type)
     762                 :             :     {
     763                 :        3321 :     case BT_INTEGER:
     764                 :        3321 :       if (mpz_sgn (op2->value.integer) == 0)
     765                 :             :         {
     766                 :             :           rc = ARITH_DIV0;
     767                 :             :           break;
     768                 :             :         }
     769                 :             : 
     770                 :        3303 :       if (warn_integer_division)
     771                 :             :         {
     772                 :          49 :           mpz_t r;
     773                 :          49 :           mpz_init (r);
     774                 :          49 :           mpz_tdiv_qr (result->value.integer, r, op1->value.integer,
     775                 :          49 :                        op2->value.integer);
     776                 :             : 
     777                 :          49 :           if (mpz_cmp_si (r, 0) != 0)
     778                 :             :             {
     779                 :           6 :               char *p;
     780                 :           6 :               p = mpz_get_str (NULL, 10, result->value.integer);
     781                 :           6 :               gfc_warning (OPT_Winteger_division, "Integer division "
     782                 :             :                                "truncated to constant %qs at %L", p,
     783                 :             :                                &op1->where);
     784                 :           6 :               free (p);
     785                 :             :             }
     786                 :          49 :           mpz_clear (r);
     787                 :             :         }
     788                 :             :       else
     789                 :        3254 :         mpz_tdiv_q (result->value.integer, op1->value.integer,
     790                 :        3254 :                     op2->value.integer);
     791                 :             : 
     792                 :             :       break;
     793                 :             : 
     794                 :        3918 :     case BT_REAL:
     795                 :        3918 :       if (mpfr_sgn (op2->value.real) == 0 && flag_range_check == 1)
     796                 :             :         {
     797                 :             :           rc = ARITH_DIV0;
     798                 :             :           break;
     799                 :             :         }
     800                 :             : 
     801                 :        3907 :       mpfr_div (result->value.real, op1->value.real, op2->value.real,
     802                 :             :                GFC_RND_MODE);
     803                 :        3907 :       break;
     804                 :             : 
     805                 :          34 :     case BT_COMPLEX:
     806                 :          34 :       if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0
     807                 :          34 :           && flag_range_check == 1)
     808                 :             :         {
     809                 :             :           rc = ARITH_DIV0;
     810                 :             :           break;
     811                 :             :         }
     812                 :             : 
     813                 :          33 :       gfc_set_model (mpc_realref (op1->value.complex));
     814                 :          33 :       if (mpc_cmp_si_si (op2->value.complex, 0, 0) == 0)
     815                 :             :       {
     816                 :             :         /* In Fortran, return (NaN + NaN I) for any zero divisor.  See
     817                 :             :            PR 40318.  */
     818                 :          13 :         mpfr_set_nan (mpc_realref (result->value.complex));
     819                 :          13 :         mpfr_set_nan (mpc_imagref (result->value.complex));
     820                 :             :       }
     821                 :             :       else
     822                 :          20 :         mpc_div (result->value.complex, op1->value.complex, op2->value.complex,
     823                 :             :                  GFC_MPC_RND_MODE);
     824                 :             :       break;
     825                 :             : 
     826                 :           0 :     default:
     827                 :           0 :       gfc_internal_error ("gfc_arith_divide(): Bad basic type");
     828                 :             :     }
     829                 :             : 
     830                 :        7243 :   if (rc == ARITH_OK)
     831                 :        7243 :     rc = gfc_range_check (result);
     832                 :             : 
     833                 :        7273 :   return check_result (rc, op1, result, resultp);
     834                 :             : }
     835                 :             : 
     836                 :             : /* Raise a number to a power.  */
     837                 :             : 
     838                 :             : static arith
     839                 :        5996 : arith_power (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
     840                 :             : {
     841                 :        5996 :   int power_sign;
     842                 :        5996 :   gfc_expr *result;
     843                 :        5996 :   arith rc;
     844                 :             : 
     845                 :        5996 :   if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
     846                 :           4 :     return ARITH_INVALID_TYPE;
     847                 :             : 
     848                 :             :   /* The result type is derived from op1 and must be compatible with the
     849                 :             :      result of the simplification.  Otherwise postpone simplification until
     850                 :             :      after operand conversions usually done by gfc_type_convert_binary.  */
     851                 :        5992 :   if ((op1->ts.type == BT_INTEGER && op2->ts.type != BT_INTEGER)
     852                 :        5987 :       || (op1->ts.type == BT_REAL && op2->ts.type == BT_COMPLEX))
     853                 :             :     return ARITH_NOT_REDUCED;
     854                 :             : 
     855                 :        5985 :   rc = ARITH_OK;
     856                 :        5985 :   result = gfc_get_constant_expr (op1->ts.type, op1->ts.kind, &op1->where);
     857                 :             : 
     858                 :        5985 :   switch (op2->ts.type)
     859                 :             :     {
     860                 :        5659 :     case BT_INTEGER:
     861                 :        5659 :       power_sign = mpz_sgn (op2->value.integer);
     862                 :             : 
     863                 :        5583 :       if (power_sign == 0)
     864                 :             :         {
     865                 :             :           /* Handle something to the zeroth power.  Since we're dealing
     866                 :             :              with integral exponents, there is no ambiguity in the
     867                 :             :              limiting procedure used to determine the value of 0**0.  */
     868                 :          84 :           switch (op1->ts.type)
     869                 :             :             {
     870                 :          35 :             case BT_INTEGER:
     871                 :          35 :               mpz_set_ui (result->value.integer, 1);
     872                 :          35 :               break;
     873                 :             : 
     874                 :          10 :             case BT_REAL:
     875                 :          10 :               mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
     876                 :          10 :               break;
     877                 :             : 
     878                 :          39 :             case BT_COMPLEX:
     879                 :          39 :               mpc_set_ui (result->value.complex, 1, GFC_MPC_RND_MODE);
     880                 :          39 :               break;
     881                 :             : 
     882                 :           0 :             default:
     883                 :           0 :               gfc_internal_error ("arith_power(): Bad base");
     884                 :             :             }
     885                 :             :         }
     886                 :             :       else
     887                 :             :         {
     888                 :        5575 :           switch (op1->ts.type)
     889                 :             :             {
     890                 :        5286 :             case BT_INTEGER:
     891                 :        5286 :               {
     892                 :             :                 /* First, we simplify the cases of op1 == 1, 0 or -1.  */
     893                 :        5286 :                 if (mpz_cmp_si (op1->value.integer, 1) == 0)
     894                 :             :                   {
     895                 :             :                     /* 1**op2 == 1 */
     896                 :         800 :                     mpz_set_si (result->value.integer, 1);
     897                 :             :                   }
     898                 :        4486 :                 else if (mpz_cmp_si (op1->value.integer, 0) == 0)
     899                 :             :                   {
     900                 :             :                     /* 0**op2 == 0, if op2 > 0
     901                 :             :                        0**op2 overflow, if op2 < 0 ; in that case, we
     902                 :             :                        set the result to 0 and return ARITH_DIV0.  */
     903                 :           6 :                     mpz_set_si (result->value.integer, 0);
     904                 :           6 :                     if (mpz_cmp_si (op2->value.integer, 0) < 0)
     905                 :             :                       rc = ARITH_DIV0;
     906                 :             :                   }
     907                 :        4480 :                 else if (mpz_cmp_si (op1->value.integer, -1) == 0)
     908                 :             :                   {
     909                 :             :                     /* (-1)**op2 == (-1)**(mod(op2,2)) */
     910                 :          24 :                     unsigned int odd = mpz_fdiv_ui (op2->value.integer, 2);
     911                 :          24 :                     if (odd)
     912                 :          12 :                       mpz_set_si (result->value.integer, -1);
     913                 :             :                     else
     914                 :          12 :                       mpz_set_si (result->value.integer, 1);
     915                 :             :                   }
     916                 :             :                 /* Then, we take care of op2 < 0.  */
     917                 :        4456 :                 else if (mpz_cmp_si (op2->value.integer, 0) < 0)
     918                 :             :                   {
     919                 :             :                     /* if op2 < 0, op1**op2 == 0  because abs(op1) > 1.  */
     920                 :           9 :                     mpz_set_si (result->value.integer, 0);
     921                 :           9 :                     if (warn_integer_division)
     922                 :           1 :                       gfc_warning_now (OPT_Winteger_division, "Negative "
     923                 :             :                                        "exponent of integer has zero "
     924                 :             :                                        "result at %L", &result->where);
     925                 :             :                   }
     926                 :             :                 else
     927                 :             :                   {
     928                 :             :                     /* We have abs(op1) > 1 and op2 > 1.
     929                 :             :                        If op2 > bit_size(op1), we'll have an out-of-range
     930                 :             :                        result.  */
     931                 :        4447 :                     int k, power;
     932                 :             : 
     933                 :        4447 :                     k = gfc_validate_kind (BT_INTEGER, op1->ts.kind, false);
     934                 :        4447 :                     power = gfc_integer_kinds[k].bit_size;
     935                 :        4447 :                     if (mpz_cmp_si (op2->value.integer, power) < 0)
     936                 :             :                       {
     937                 :        4441 :                         gfc_extract_int (op2, &power);
     938                 :        4441 :                         mpz_pow_ui (result->value.integer, op1->value.integer,
     939                 :             :                                     power);
     940                 :        4441 :                         rc = gfc_range_check (result);
     941                 :        4441 :                         if (rc == ARITH_OVERFLOW)
     942                 :           0 :                           gfc_error_now ("Result of exponentiation at %L "
     943                 :             :                                          "exceeds the range of %s", &op1->where,
     944                 :             :                                          gfc_typename (&(op1->ts)));
     945                 :             :                       }
     946                 :             :                     else
     947                 :             :                       {
     948                 :             :                         /* Provide a nonsense value to propagate up. */
     949                 :           6 :                         mpz_set (result->value.integer,
     950                 :           6 :                                  gfc_integer_kinds[k].huge);
     951                 :           6 :                         mpz_add_ui (result->value.integer,
     952                 :             :                                     result->value.integer, 1);
     953                 :           6 :                         rc = ARITH_OVERFLOW;
     954                 :             :                       }
     955                 :             :                   }
     956                 :             :               }
     957                 :             :               break;
     958                 :             : 
     959                 :         249 :             case BT_REAL:
     960                 :         249 :               mpfr_pow_z (result->value.real, op1->value.real,
     961                 :         249 :                           op2->value.integer, GFC_RND_MODE);
     962                 :         249 :               break;
     963                 :             : 
     964                 :          40 :             case BT_COMPLEX:
     965                 :          40 :               mpc_pow_z (result->value.complex, op1->value.complex,
     966                 :          40 :                          op2->value.integer, GFC_MPC_RND_MODE);
     967                 :          40 :               break;
     968                 :             : 
     969                 :             :             default:
     970                 :             :               break;
     971                 :             :             }
     972                 :             :         }
     973                 :             :       break;
     974                 :             : 
     975                 :         278 :     case BT_REAL:
     976                 :             : 
     977                 :         278 :       if (gfc_init_expr_flag)
     978                 :             :         {
     979                 :          92 :           if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
     980                 :             :                                "exponent in an initialization "
     981                 :             :                                "expression at %L", &op2->where))
     982                 :             :             {
     983                 :           1 :               gfc_free_expr (result);
     984                 :           1 :               return ARITH_PROHIBIT;
     985                 :             :             }
     986                 :             :         }
     987                 :             : 
     988                 :         277 :       if (mpfr_cmp_si (op1->value.real, 0) < 0)
     989                 :             :         {
     990                 :           0 :           gfc_error ("Raising a negative REAL at %L to "
     991                 :             :                      "a REAL power is prohibited", &op1->where);
     992                 :           0 :           gfc_free_expr (result);
     993                 :           0 :           return ARITH_PROHIBIT;
     994                 :             :         }
     995                 :             : 
     996                 :         277 :         mpfr_pow (result->value.real, op1->value.real, op2->value.real,
     997                 :             :                   GFC_RND_MODE);
     998                 :         277 :       break;
     999                 :             : 
    1000                 :          48 :     case BT_COMPLEX:
    1001                 :          48 :       {
    1002                 :          48 :         if (gfc_init_expr_flag)
    1003                 :             :           {
    1004                 :          41 :             if (!gfc_notify_std (GFC_STD_F2003, "Noninteger "
    1005                 :             :                                  "exponent in an initialization "
    1006                 :             :                                  "expression at %L", &op2->where))
    1007                 :             :               {
    1008                 :           0 :                 gfc_free_expr (result);
    1009                 :           0 :                 return ARITH_PROHIBIT;
    1010                 :             :               }
    1011                 :             :           }
    1012                 :             : 
    1013                 :          48 :         mpc_pow (result->value.complex, op1->value.complex,
    1014                 :          48 :                  op2->value.complex, GFC_MPC_RND_MODE);
    1015                 :             :       }
    1016                 :          48 :       break;
    1017                 :           0 :     default:
    1018                 :           0 :       gfc_internal_error ("arith_power(): unknown type");
    1019                 :             :     }
    1020                 :             : 
    1021                 :        5970 :   if (rc == ARITH_OK)
    1022                 :        5975 :     rc = gfc_range_check (result);
    1023                 :             : 
    1024                 :        5984 :   return check_result (rc, op1, result, resultp);
    1025                 :             : }
    1026                 :             : 
    1027                 :             : 
    1028                 :             : /* Concatenate two string constants.  */
    1029                 :             : 
    1030                 :             : static arith
    1031                 :        2693 : gfc_arith_concat (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1032                 :             : {
    1033                 :        2693 :   gfc_expr *result;
    1034                 :        2693 :   size_t len;
    1035                 :             : 
    1036                 :             :   /* By cleverly playing around with constructors, it is possible
    1037                 :             :      to get mismatching types here.  */
    1038                 :        2693 :   if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
    1039                 :        2692 :       || op1->ts.kind != op2->ts.kind)
    1040                 :             :     return ARITH_WRONGCONCAT;
    1041                 :             : 
    1042                 :        2692 :   result = gfc_get_constant_expr (BT_CHARACTER, op1->ts.kind,
    1043                 :             :                                   &op1->where);
    1044                 :             : 
    1045                 :        2692 :   len = op1->value.character.length + op2->value.character.length;
    1046                 :             : 
    1047                 :        2692 :   result->value.character.string = gfc_get_wide_string (len + 1);
    1048                 :        2692 :   result->value.character.length = len;
    1049                 :             : 
    1050                 :        2692 :   memcpy (result->value.character.string, op1->value.character.string,
    1051                 :        2692 :           op1->value.character.length * sizeof (gfc_char_t));
    1052                 :             : 
    1053                 :        2692 :   memcpy (&result->value.character.string[op1->value.character.length],
    1054                 :        2692 :           op2->value.character.string,
    1055                 :        2692 :           op2->value.character.length * sizeof (gfc_char_t));
    1056                 :             : 
    1057                 :        2692 :   result->value.character.string[len] = '\0';
    1058                 :             : 
    1059                 :        2692 :   *resultp = result;
    1060                 :             : 
    1061                 :        2692 :   return ARITH_OK;
    1062                 :             : }
    1063                 :             : 
    1064                 :             : /* Comparison between real values; returns 0 if (op1 .op. op2) is true.
    1065                 :             :    This function mimics mpfr_cmp but takes NaN into account.  */
    1066                 :             : 
    1067                 :             : static int
    1068                 :        3158 : compare_real (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    1069                 :             : {
    1070                 :        3158 :   int rc;
    1071                 :        3158 :   switch (op)
    1072                 :             :     {
    1073                 :        1673 :       case INTRINSIC_EQ:
    1074                 :        1673 :         rc = mpfr_equal_p (op1->value.real, op2->value.real) ? 0 : 1;
    1075                 :        1673 :         break;
    1076                 :         872 :       case INTRINSIC_GT:
    1077                 :         872 :         rc = mpfr_greater_p (op1->value.real, op2->value.real) ? 1 : -1;
    1078                 :             :         break;
    1079                 :          72 :       case INTRINSIC_GE:
    1080                 :          72 :         rc = mpfr_greaterequal_p (op1->value.real, op2->value.real) ? 1 : -1;
    1081                 :             :         break;
    1082                 :          60 :       case INTRINSIC_LT:
    1083                 :          60 :         rc = mpfr_less_p (op1->value.real, op2->value.real) ? -1 : 1;
    1084                 :             :         break;
    1085                 :         481 :       case INTRINSIC_LE:
    1086                 :         481 :         rc = mpfr_lessequal_p (op1->value.real, op2->value.real) ? -1 : 1;
    1087                 :             :         break;
    1088                 :           0 :       default:
    1089                 :           0 :         gfc_internal_error ("compare_real(): Bad operator");
    1090                 :             :     }
    1091                 :             : 
    1092                 :        3158 :   return rc;
    1093                 :             : }
    1094                 :             : 
    1095                 :             : /* Comparison operators.  Assumes that the two expression nodes
    1096                 :             :    contain two constants of the same type. The op argument is
    1097                 :             :    needed to handle NaN correctly.  */
    1098                 :             : 
    1099                 :             : int
    1100                 :       39626 : gfc_compare_expr (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    1101                 :             : {
    1102                 :       39626 :   int rc;
    1103                 :             : 
    1104                 :       39626 :   switch (op1->ts.type)
    1105                 :             :     {
    1106                 :       29629 :     case BT_INTEGER:
    1107                 :       29629 :       rc = mpz_cmp (op1->value.integer, op2->value.integer);
    1108                 :       29629 :       break;
    1109                 :             : 
    1110                 :        3158 :     case BT_REAL:
    1111                 :        3158 :       rc = compare_real (op1, op2, op);
    1112                 :        3158 :       break;
    1113                 :             : 
    1114                 :        6791 :     case BT_CHARACTER:
    1115                 :        6791 :       rc = gfc_compare_string (op1, op2);
    1116                 :        6791 :       break;
    1117                 :             : 
    1118                 :          38 :     case BT_LOGICAL:
    1119                 :           0 :       rc = ((!op1->value.logical && op2->value.logical)
    1120                 :          38 :             || (op1->value.logical && !op2->value.logical));
    1121                 :          38 :       break;
    1122                 :             : 
    1123                 :          10 :     case BT_COMPLEX:
    1124                 :          10 :       gcc_assert (op == INTRINSIC_EQ);
    1125                 :          10 :       rc = mpc_cmp (op1->value.complex, op2->value.complex);
    1126                 :          10 :       break;
    1127                 :             : 
    1128                 :           0 :     default:
    1129                 :           0 :       gfc_internal_error ("gfc_compare_expr(): Bad basic type");
    1130                 :             :     }
    1131                 :             : 
    1132                 :       39626 :   return rc;
    1133                 :             : }
    1134                 :             : 
    1135                 :             : 
    1136                 :             : /* Compare a pair of complex numbers.  Naturally, this is only for
    1137                 :             :    equality and inequality.  */
    1138                 :             : 
    1139                 :             : static int
    1140                 :         196 : compare_complex (gfc_expr *op1, gfc_expr *op2)
    1141                 :             : {
    1142                 :         196 :   return mpc_cmp (op1->value.complex, op2->value.complex) == 0;
    1143                 :             : }
    1144                 :             : 
    1145                 :             : 
    1146                 :             : /* Given two constant strings and the inverse collating sequence, compare the
    1147                 :             :    strings.  We return -1 for a < b, 0 for a == b and 1 for a > b.
    1148                 :             :    We use the processor's default collating sequence.  */
    1149                 :             : 
    1150                 :             : int
    1151                 :        7414 : gfc_compare_string (gfc_expr *a, gfc_expr *b)
    1152                 :             : {
    1153                 :        7414 :   size_t len, alen, blen, i;
    1154                 :        7414 :   gfc_char_t ac, bc;
    1155                 :             : 
    1156                 :        7414 :   alen = a->value.character.length;
    1157                 :        7414 :   blen = b->value.character.length;
    1158                 :             : 
    1159                 :        7414 :   len = MAX(alen, blen);
    1160                 :             : 
    1161                 :       18338 :   for (i = 0; i < len; i++)
    1162                 :             :     {
    1163                 :       13587 :       ac = ((i < alen) ? a->value.character.string[i] : ' ');
    1164                 :       13587 :       bc = ((i < blen) ? b->value.character.string[i] : ' ');
    1165                 :             : 
    1166                 :       13587 :       if (ac < bc)
    1167                 :             :         return -1;
    1168                 :       12617 :       if (ac > bc)
    1169                 :             :         return 1;
    1170                 :             :     }
    1171                 :             : 
    1172                 :             :   /* Strings are equal */
    1173                 :             :   return 0;
    1174                 :             : }
    1175                 :             : 
    1176                 :             : 
    1177                 :             : int
    1178                 :         360 : gfc_compare_with_Cstring (gfc_expr *a, const char *b, bool case_sensitive)
    1179                 :             : {
    1180                 :         360 :   size_t len, alen, blen, i;
    1181                 :         360 :   gfc_char_t ac, bc;
    1182                 :             : 
    1183                 :         360 :   alen = a->value.character.length;
    1184                 :         360 :   blen = strlen (b);
    1185                 :             : 
    1186                 :         360 :   len = MAX(alen, blen);
    1187                 :             : 
    1188                 :        1299 :   for (i = 0; i < len; i++)
    1189                 :             :     {
    1190                 :        1178 :       ac = ((i < alen) ? a->value.character.string[i] : ' ');
    1191                 :        1178 :       bc = ((i < blen) ? b[i] : ' ');
    1192                 :             : 
    1193                 :        1178 :       if (!case_sensitive)
    1194                 :             :         {
    1195                 :        1178 :           ac = TOLOWER (ac);
    1196                 :        1178 :           bc = TOLOWER (bc);
    1197                 :             :         }
    1198                 :             : 
    1199                 :        1178 :       if (ac < bc)
    1200                 :             :         return -1;
    1201                 :        1099 :       if (ac > bc)
    1202                 :             :         return 1;
    1203                 :             :     }
    1204                 :             : 
    1205                 :             :   /* Strings are equal */
    1206                 :             :   return 0;
    1207                 :             : }
    1208                 :             : 
    1209                 :             : 
    1210                 :             : /* Specific comparison subroutines.  */
    1211                 :             : 
    1212                 :             : static arith
    1213                 :        2990 : gfc_arith_eq (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1214                 :             : {
    1215                 :        2990 :   gfc_expr *result;
    1216                 :             : 
    1217                 :        2990 :   if (op1->ts.type != op2->ts.type)
    1218                 :             :     return ARITH_INVALID_TYPE;
    1219                 :             : 
    1220                 :        2988 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1221                 :             :                                   &op1->where);
    1222                 :        5976 :   result->value.logical = (op1->ts.type == BT_COMPLEX)
    1223                 :        2988 :                         ? compare_complex (op1, op2)
    1224                 :        2988 :                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) == 0);
    1225                 :             : 
    1226                 :        2988 :   *resultp = result;
    1227                 :        2988 :   return ARITH_OK;
    1228                 :             : }
    1229                 :             : 
    1230                 :             : 
    1231                 :             : static arith
    1232                 :       30496 : gfc_arith_ne (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1233                 :             : {
    1234                 :       30496 :   gfc_expr *result;
    1235                 :             : 
    1236                 :       30496 :   if (op1->ts.type != op2->ts.type)
    1237                 :             :     return ARITH_INVALID_TYPE;
    1238                 :             : 
    1239                 :       30494 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1240                 :             :                                   &op1->where);
    1241                 :       60988 :   result->value.logical = (op1->ts.type == BT_COMPLEX)
    1242                 :       30690 :                         ? !compare_complex (op1, op2)
    1243                 :       30298 :                         : (gfc_compare_expr (op1, op2, INTRINSIC_EQ) != 0);
    1244                 :             : 
    1245                 :       30494 :   *resultp = result;
    1246                 :       30494 :   return ARITH_OK;
    1247                 :             : }
    1248                 :             : 
    1249                 :             : 
    1250                 :             : static arith
    1251                 :        3013 : gfc_arith_gt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1252                 :             : {
    1253                 :        3013 :   gfc_expr *result;
    1254                 :             : 
    1255                 :        3013 :   if (op1->ts.type != op2->ts.type)
    1256                 :             :     return ARITH_INVALID_TYPE;
    1257                 :             : 
    1258                 :        3011 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1259                 :             :                                   &op1->where);
    1260                 :        3011 :   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GT) > 0);
    1261                 :        3011 :   *resultp = result;
    1262                 :             : 
    1263                 :        3011 :   return ARITH_OK;
    1264                 :             : }
    1265                 :             : 
    1266                 :             : 
    1267                 :             : static arith
    1268                 :         262 : gfc_arith_ge (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1269                 :             : {
    1270                 :         262 :   gfc_expr *result;
    1271                 :             : 
    1272                 :         262 :   if (op1->ts.type != op2->ts.type)
    1273                 :             :     return ARITH_INVALID_TYPE;
    1274                 :             : 
    1275                 :         260 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1276                 :             :                                   &op1->where);
    1277                 :         260 :   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_GE) >= 0);
    1278                 :         260 :   *resultp = result;
    1279                 :             : 
    1280                 :         260 :   return ARITH_OK;
    1281                 :             : }
    1282                 :             : 
    1283                 :             : 
    1284                 :             : static arith
    1285                 :         428 : gfc_arith_lt (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1286                 :             : {
    1287                 :         428 :   gfc_expr *result;
    1288                 :             : 
    1289                 :         428 :   if (op1->ts.type != op2->ts.type)
    1290                 :             :     return ARITH_INVALID_TYPE;
    1291                 :             : 
    1292                 :         426 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1293                 :             :                                   &op1->where);
    1294                 :         426 :   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LT) < 0);
    1295                 :         426 :   *resultp = result;
    1296                 :             : 
    1297                 :         426 :   return ARITH_OK;
    1298                 :             : }
    1299                 :             : 
    1300                 :             : 
    1301                 :             : static arith
    1302                 :         661 : gfc_arith_le (gfc_expr *op1, gfc_expr *op2, gfc_expr **resultp)
    1303                 :             : {
    1304                 :         661 :   gfc_expr *result;
    1305                 :             : 
    1306                 :         661 :   if (op1->ts.type != op2->ts.type)
    1307                 :             :     return ARITH_INVALID_TYPE;
    1308                 :             : 
    1309                 :         659 :   result = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
    1310                 :             :                                   &op1->where);
    1311                 :         659 :   result->value.logical = (gfc_compare_expr (op1, op2, INTRINSIC_LE) <= 0);
    1312                 :         659 :   *resultp = result;
    1313                 :             : 
    1314                 :         659 :   return ARITH_OK;
    1315                 :             : }
    1316                 :             : 
    1317                 :             : 
    1318                 :             : static arith
    1319                 :      126083 : reduce_unary (arith (*eval) (gfc_expr *, gfc_expr **), gfc_expr *op,
    1320                 :             :               gfc_expr **result)
    1321                 :             : {
    1322                 :      126083 :   gfc_constructor_base head;
    1323                 :      126083 :   gfc_constructor *c;
    1324                 :      126083 :   gfc_expr *r;
    1325                 :      126083 :   arith rc;
    1326                 :             : 
    1327                 :      126083 :   if (op->expr_type == EXPR_CONSTANT)
    1328                 :      125928 :     return eval (op, result);
    1329                 :             : 
    1330                 :         155 :   if (op->expr_type != EXPR_ARRAY)
    1331                 :             :     return ARITH_NOT_REDUCED;
    1332                 :             : 
    1333                 :         144 :   rc = ARITH_OK;
    1334                 :         144 :   head = gfc_constructor_copy (op->value.constructor);
    1335                 :         428 :   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
    1336                 :             :     {
    1337                 :         301 :       rc = reduce_unary (eval, c->expr, &r);
    1338                 :             : 
    1339                 :         301 :       if (rc != ARITH_OK)
    1340                 :             :         break;
    1341                 :             : 
    1342                 :         284 :       gfc_replace_expr (c->expr, r);
    1343                 :             :     }
    1344                 :             : 
    1345                 :         144 :   if (rc != ARITH_OK)
    1346                 :          17 :     gfc_constructor_free (head);
    1347                 :             :   else
    1348                 :             :     {
    1349                 :         127 :       gfc_constructor *c = gfc_constructor_first (head);
    1350                 :         127 :       if (c == NULL)
    1351                 :             :         {
    1352                 :             :           /* Handle zero-sized arrays.  */
    1353                 :          30 :           r = gfc_get_array_expr (op->ts.type, op->ts.kind, &op->where);
    1354                 :             :         }
    1355                 :             :       else
    1356                 :             :         {
    1357                 :          97 :           r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
    1358                 :             :                                   &op->where);
    1359                 :             :         }
    1360                 :         127 :       r->shape = gfc_copy_shape (op->shape, op->rank);
    1361                 :         127 :       r->rank = op->rank;
    1362                 :         127 :       r->value.constructor = head;
    1363                 :         127 :       *result = r;
    1364                 :             :     }
    1365                 :             : 
    1366                 :             :   return rc;
    1367                 :             : }
    1368                 :             : 
    1369                 :             : 
    1370                 :             : static arith
    1371                 :        1374 : reduce_binary_ac (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1372                 :             :                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
    1373                 :             : {
    1374                 :        1374 :   gfc_constructor_base head;
    1375                 :        1374 :   gfc_constructor *c;
    1376                 :        1374 :   gfc_expr *r;
    1377                 :        1374 :   arith rc = ARITH_OK;
    1378                 :             : 
    1379                 :        1374 :   head = gfc_constructor_copy (op1->value.constructor);
    1380                 :        9531 :   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
    1381                 :             :     {
    1382                 :        8214 :       gfc_simplify_expr (c->expr, 0);
    1383                 :             : 
    1384                 :        8214 :       if (c->expr->expr_type == EXPR_CONSTANT)
    1385                 :        8177 :         rc = eval (c->expr, op2, &r);
    1386                 :          37 :       else if (c->expr->expr_type != EXPR_ARRAY)
    1387                 :             :         rc = ARITH_NOT_REDUCED;
    1388                 :             :       else
    1389                 :          27 :         rc = reduce_binary_ac (eval, c->expr, op2, &r);
    1390                 :             : 
    1391                 :        8204 :       if (rc != ARITH_OK)
    1392                 :             :         break;
    1393                 :             : 
    1394                 :        8157 :       gfc_replace_expr (c->expr, r);
    1395                 :             :     }
    1396                 :             : 
    1397                 :        1374 :   if (rc != ARITH_OK)
    1398                 :          57 :     gfc_constructor_free (head);
    1399                 :             :   else
    1400                 :             :     {
    1401                 :        1317 :       gfc_constructor *c = gfc_constructor_first (head);
    1402                 :        1317 :       if (c)
    1403                 :             :         {
    1404                 :        1317 :           r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
    1405                 :             :                                   &op1->where);
    1406                 :        1317 :           r->shape = gfc_copy_shape (op1->shape, op1->rank);
    1407                 :             :         }
    1408                 :             :       else
    1409                 :             :         {
    1410                 :           0 :           gcc_assert (op1->ts.type != BT_UNKNOWN);
    1411                 :           0 :           r = gfc_get_array_expr (op1->ts.type, op1->ts.kind,
    1412                 :             :                                   &op1->where);
    1413                 :           0 :           r->shape = gfc_get_shape (op1->rank);
    1414                 :             :         }
    1415                 :        1317 :       r->rank = op1->rank;
    1416                 :        1317 :       r->value.constructor = head;
    1417                 :        1317 :       *result = r;
    1418                 :             :     }
    1419                 :             : 
    1420                 :        1374 :   return rc;
    1421                 :             : }
    1422                 :             : 
    1423                 :             : 
    1424                 :             : static arith
    1425                 :         624 : reduce_binary_ca (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1426                 :             :                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
    1427                 :             : {
    1428                 :         624 :   gfc_constructor_base head;
    1429                 :         624 :   gfc_constructor *c;
    1430                 :         624 :   gfc_expr *r;
    1431                 :         624 :   arith rc = ARITH_OK;
    1432                 :             : 
    1433                 :         624 :   head = gfc_constructor_copy (op2->value.constructor);
    1434                 :        3143 :   for (c = gfc_constructor_first (head); c; c = gfc_constructor_next (c))
    1435                 :             :     {
    1436                 :        2551 :       gfc_simplify_expr (c->expr, 0);
    1437                 :             : 
    1438                 :        2551 :       if (c->expr->expr_type == EXPR_CONSTANT)
    1439                 :        2421 :         rc = eval (op1, c->expr, &r);
    1440                 :         130 :       else if (c->expr->expr_type != EXPR_ARRAY)
    1441                 :             :         rc = ARITH_NOT_REDUCED;
    1442                 :             :       else
    1443                 :         120 :         rc = reduce_binary_ca (eval, op1, c->expr, &r);
    1444                 :             : 
    1445                 :        2541 :       if (rc != ARITH_OK)
    1446                 :             :         break;
    1447                 :             : 
    1448                 :        2519 :       gfc_replace_expr (c->expr, r);
    1449                 :             :     }
    1450                 :             : 
    1451                 :         624 :   if (rc != ARITH_OK)
    1452                 :          32 :     gfc_constructor_free (head);
    1453                 :             :   else
    1454                 :             :     {
    1455                 :         592 :       gfc_constructor *c = gfc_constructor_first (head);
    1456                 :         592 :       if (c)
    1457                 :             :         {
    1458                 :         502 :           r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
    1459                 :             :                                   &op2->where);
    1460                 :         502 :           r->shape = gfc_copy_shape (op2->shape, op2->rank);
    1461                 :             :         }
    1462                 :             :       else
    1463                 :             :         {
    1464                 :          90 :           gcc_assert (op2->ts.type != BT_UNKNOWN);
    1465                 :          90 :           r = gfc_get_array_expr (op2->ts.type, op2->ts.kind,
    1466                 :             :                                   &op2->where);
    1467                 :          90 :           r->shape = gfc_get_shape (op2->rank);
    1468                 :             :         }
    1469                 :         592 :       r->rank = op2->rank;
    1470                 :         592 :       r->value.constructor = head;
    1471                 :         592 :       *result = r;
    1472                 :             :     }
    1473                 :             : 
    1474                 :         624 :   return rc;
    1475                 :             : }
    1476                 :             : 
    1477                 :             : 
    1478                 :             : /* We need a forward declaration of reduce_binary.  */
    1479                 :             : static arith reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1480                 :             :                             gfc_expr *op1, gfc_expr *op2, gfc_expr **result);
    1481                 :             : 
    1482                 :             : 
    1483                 :             : static arith
    1484                 :        1371 : reduce_binary_aa (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1485                 :             :                   gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
    1486                 :             : {
    1487                 :        1371 :   gfc_constructor_base head;
    1488                 :        1371 :   gfc_constructor *c, *d;
    1489                 :        1371 :   gfc_expr *r;
    1490                 :        1371 :   arith rc = ARITH_OK;
    1491                 :             : 
    1492                 :        1371 :   if (!gfc_check_conformance (op1, op2, _("elemental binary operation")))
    1493                 :             :     return ARITH_INCOMMENSURATE;
    1494                 :             : 
    1495                 :        1371 :   head = gfc_constructor_copy (op1->value.constructor);
    1496                 :        1371 :   for (c = gfc_constructor_first (head),
    1497                 :        1371 :        d = gfc_constructor_first (op2->value.constructor);
    1498                 :        5208 :        c && d;
    1499                 :        3837 :        c = gfc_constructor_next (c), d = gfc_constructor_next (d))
    1500                 :             :     {
    1501                 :        3846 :       rc = reduce_binary (eval, c->expr, d->expr, &r);
    1502                 :             : 
    1503                 :        3846 :       if (rc != ARITH_OK)
    1504                 :             :         break;
    1505                 :             : 
    1506                 :        3837 :       gfc_replace_expr (c->expr, r);
    1507                 :             :     }
    1508                 :             : 
    1509                 :        1371 :   if (rc == ARITH_OK && (c || d))
    1510                 :             :     rc = ARITH_INCOMMENSURATE;
    1511                 :             : 
    1512                 :        1362 :   if (rc != ARITH_OK)
    1513                 :           9 :     gfc_constructor_free (head);
    1514                 :             :   else
    1515                 :             :     {
    1516                 :        1362 :       gfc_constructor *c = gfc_constructor_first (head);
    1517                 :        1362 :       if (c == NULL)
    1518                 :             :         {
    1519                 :             :           /* Handle zero-sized arrays.  */
    1520                 :         132 :           r = gfc_get_array_expr (op1->ts.type, op1->ts.kind, &op1->where);
    1521                 :             :         }
    1522                 :             :       else
    1523                 :             :         {
    1524                 :        1230 :           r = gfc_get_array_expr (c->expr->ts.type, c->expr->ts.kind,
    1525                 :             :                                   &op1->where);
    1526                 :             :         }
    1527                 :        1362 :       r->shape = gfc_copy_shape (op1->shape, op1->rank);
    1528                 :        1362 :       r->rank = op1->rank;
    1529                 :        1362 :       r->value.constructor = head;
    1530                 :        1362 :       *result = r;
    1531                 :             :     }
    1532                 :             : 
    1533                 :             :   return rc;
    1534                 :             : }
    1535                 :             : 
    1536                 :             : 
    1537                 :             : static arith
    1538                 :    11217744 : reduce_binary (arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1539                 :             :                gfc_expr *op1, gfc_expr *op2, gfc_expr **result)
    1540                 :             : {
    1541                 :    11217744 :   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_CONSTANT)
    1542                 :    11214514 :     return eval (op1, op2, result);
    1543                 :             : 
    1544                 :        3230 :   if (op1->expr_type == EXPR_CONSTANT && op2->expr_type == EXPR_ARRAY)
    1545                 :         504 :     return reduce_binary_ca (eval, op1, op2, result);
    1546                 :             : 
    1547                 :        2726 :   if (op1->expr_type == EXPR_ARRAY && op2->expr_type == EXPR_CONSTANT)
    1548                 :        1347 :     return reduce_binary_ac (eval, op1, op2, result);
    1549                 :             : 
    1550                 :        1379 :   if (op1->expr_type != EXPR_ARRAY || op2->expr_type != EXPR_ARRAY)
    1551                 :             :     return ARITH_NOT_REDUCED;
    1552                 :             : 
    1553                 :        1371 :   return reduce_binary_aa (eval, op1, op2, result);
    1554                 :             : }
    1555                 :             : 
    1556                 :             : 
    1557                 :             : typedef union
    1558                 :             : {
    1559                 :             :   arith (*f2)(gfc_expr *, gfc_expr **);
    1560                 :             :   arith (*f3)(gfc_expr *, gfc_expr *, gfc_expr **);
    1561                 :             : }
    1562                 :             : eval_f;
    1563                 :             : 
    1564                 :             : /* High level arithmetic subroutines.  These subroutines go into
    1565                 :             :    eval_intrinsic(), which can do one of several things to its
    1566                 :             :    operands.  If the operands are incompatible with the intrinsic
    1567                 :             :    operation, we return a node pointing to the operands and hope that
    1568                 :             :    an operator interface is found during resolution.
    1569                 :             : 
    1570                 :             :    If the operands are compatible and are constants, then we try doing
    1571                 :             :    the arithmetic.  We also handle the cases where either or both
    1572                 :             :    operands are array constructors.  */
    1573                 :             : 
    1574                 :             : static gfc_expr *
    1575                 :    12391637 : eval_intrinsic (gfc_intrinsic_op op,
    1576                 :             :                 eval_f eval, gfc_expr *op1, gfc_expr *op2)
    1577                 :             : {
    1578                 :    12391637 :   gfc_expr temp, *result;
    1579                 :    12391637 :   int unary;
    1580                 :    12391637 :   arith rc;
    1581                 :             : 
    1582                 :    12391637 :   if (!op1)
    1583                 :             :     return NULL;
    1584                 :             : 
    1585                 :    12391633 :   gfc_clear_ts (&temp.ts);
    1586                 :             : 
    1587                 :    12391633 :   switch (op)
    1588                 :             :     {
    1589                 :             :     /* Logical unary  */
    1590                 :       71066 :     case INTRINSIC_NOT:
    1591                 :       71066 :       if (op1->ts.type != BT_LOGICAL)
    1592                 :       63785 :         goto runtime;
    1593                 :             : 
    1594                 :        7281 :       temp.ts.type = BT_LOGICAL;
    1595                 :        7281 :       temp.ts.kind = gfc_default_logical_kind;
    1596                 :        7281 :       unary = 1;
    1597                 :        7281 :       break;
    1598                 :             : 
    1599                 :             :     /* Logical binary operators  */
    1600                 :      120343 :     case INTRINSIC_OR:
    1601                 :      120343 :     case INTRINSIC_AND:
    1602                 :      120343 :     case INTRINSIC_NEQV:
    1603                 :      120343 :     case INTRINSIC_EQV:
    1604                 :      120343 :       if (op1->ts.type != BT_LOGICAL || op2->ts.type != BT_LOGICAL)
    1605                 :       56027 :         goto runtime;
    1606                 :             : 
    1607                 :       64316 :       temp.ts.type = BT_LOGICAL;
    1608                 :       64316 :       temp.ts.kind = gfc_default_logical_kind;
    1609                 :       64316 :       unary = 0;
    1610                 :       64316 :       break;
    1611                 :             : 
    1612                 :             :     /* Numeric unary  */
    1613                 :      145226 :     case INTRINSIC_UPLUS:
    1614                 :      145226 :     case INTRINSIC_UMINUS:
    1615                 :      145226 :       if (!gfc_numeric_ts (&op1->ts))
    1616                 :        6147 :         goto runtime;
    1617                 :             : 
    1618                 :      139079 :       temp.ts = op1->ts;
    1619                 :      139079 :       unary = 1;
    1620                 :      139079 :       break;
    1621                 :             : 
    1622                 :           0 :     case INTRINSIC_PARENTHESES:
    1623                 :           0 :       temp.ts = op1->ts;
    1624                 :           0 :       unary = 1;
    1625                 :           0 :       break;
    1626                 :             : 
    1627                 :             :     /* Additional restrictions for ordering relations.  */
    1628                 :       64113 :     case INTRINSIC_GE:
    1629                 :       64113 :     case INTRINSIC_GE_OS:
    1630                 :       64113 :     case INTRINSIC_LT:
    1631                 :       64113 :     case INTRINSIC_LT_OS:
    1632                 :       64113 :     case INTRINSIC_LE:
    1633                 :       64113 :     case INTRINSIC_LE_OS:
    1634                 :       64113 :     case INTRINSIC_GT:
    1635                 :       64113 :     case INTRINSIC_GT_OS:
    1636                 :       64113 :       if (op1->ts.type == BT_COMPLEX || op2->ts.type == BT_COMPLEX)
    1637                 :             :         {
    1638                 :          36 :           temp.ts.type = BT_LOGICAL;
    1639                 :          36 :           temp.ts.kind = gfc_default_logical_kind;
    1640                 :          36 :           goto runtime;
    1641                 :             :         }
    1642                 :             : 
    1643                 :             :     /* Fall through  */
    1644                 :      690495 :     case INTRINSIC_EQ:
    1645                 :      690495 :     case INTRINSIC_EQ_OS:
    1646                 :      690495 :     case INTRINSIC_NE:
    1647                 :      690495 :     case INTRINSIC_NE_OS:
    1648                 :      690495 :       if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER)
    1649                 :             :         {
    1650                 :       95330 :           unary = 0;
    1651                 :       95330 :           temp.ts.type = BT_LOGICAL;
    1652                 :       95330 :           temp.ts.kind = gfc_default_logical_kind;
    1653                 :             : 
    1654                 :             :           /* If kind mismatch, exit and we'll error out later.  */
    1655                 :       95330 :           if (op1->ts.kind != op2->ts.kind)
    1656                 :          36 :             goto runtime;
    1657                 :             : 
    1658                 :             :           break;
    1659                 :             :         }
    1660                 :             : 
    1661                 :    11953523 :     gcc_fallthrough ();
    1662                 :             :     /* Numeric binary  */
    1663                 :    11953523 :     case INTRINSIC_PLUS:
    1664                 :    11953523 :     case INTRINSIC_MINUS:
    1665                 :    11953523 :     case INTRINSIC_TIMES:
    1666                 :    11953523 :     case INTRINSIC_DIVIDE:
    1667                 :    11953523 :     case INTRINSIC_POWER:
    1668                 :    11953523 :       if (!gfc_numeric_ts (&op1->ts) || !gfc_numeric_ts (&op2->ts))
    1669                 :      423355 :         goto runtime;
    1670                 :             : 
    1671                 :             :       /* Do not perform conversions if operands are not conformable as
    1672                 :             :          required for the binary intrinsic operators (F2018:10.1.5).
    1673                 :             :          Defer to a possibly overloading user-defined operator.  */
    1674                 :    11530168 :       if (!gfc_op_rank_conformable (op1, op2))
    1675                 :         220 :             goto runtime;
    1676                 :             : 
    1677                 :             :       /* Insert any necessary type conversions to make the operands
    1678                 :             :          compatible.  */
    1679                 :             : 
    1680                 :    11529948 :       temp.expr_type = EXPR_OP;
    1681                 :    11529948 :       gfc_clear_ts (&temp.ts);
    1682                 :    11529948 :       temp.value.op.op = op;
    1683                 :             : 
    1684                 :    11529948 :       temp.value.op.op1 = op1;
    1685                 :    11529948 :       temp.value.op.op2 = op2;
    1686                 :             : 
    1687                 :    11531373 :       gfc_type_convert_binary (&temp, warn_conversion || warn_conversion_extra);
    1688                 :             : 
    1689                 :    11529948 :       if (op == INTRINSIC_EQ || op == INTRINSIC_NE
    1690                 :    11529948 :           || op == INTRINSIC_GE || op == INTRINSIC_GT
    1691                 :    11407959 :           || op == INTRINSIC_LE || op == INTRINSIC_LT
    1692                 :    11397724 :           || op == INTRINSIC_EQ_OS || op == INTRINSIC_NE_OS
    1693                 :    11386698 :           || op == INTRINSIC_GE_OS || op == INTRINSIC_GT_OS
    1694                 :    11303947 :           || op == INTRINSIC_LE_OS || op == INTRINSIC_LT_OS)
    1695                 :             :         {
    1696                 :      235753 :           temp.ts.type = BT_LOGICAL;
    1697                 :      235753 :           temp.ts.kind = gfc_default_logical_kind;
    1698                 :             :         }
    1699                 :             : 
    1700                 :             :       unary = 0;
    1701                 :             :       break;
    1702                 :             : 
    1703                 :             :     /* Character binary  */
    1704                 :        6109 :     case INTRINSIC_CONCAT:
    1705                 :        6109 :       if (op1->ts.type != BT_CHARACTER || op2->ts.type != BT_CHARACTER
    1706                 :        4658 :           || op1->ts.kind != op2->ts.kind)
    1707                 :        1460 :         goto runtime;
    1708                 :             : 
    1709                 :        4649 :       temp.ts.type = BT_CHARACTER;
    1710                 :        4649 :       temp.ts.kind = op1->ts.kind;
    1711                 :        4649 :       unary = 0;
    1712                 :        4649 :       break;
    1713                 :             : 
    1714                 :           0 :     case INTRINSIC_USER:
    1715                 :           0 :       goto runtime;
    1716                 :             : 
    1717                 :           0 :     default:
    1718                 :           0 :       gfc_internal_error ("eval_intrinsic(): Bad operator");
    1719                 :             :     }
    1720                 :             : 
    1721                 :    11840567 :   if (op1->expr_type != EXPR_CONSTANT
    1722                 :    11840567 :       && (op1->expr_type != EXPR_ARRAY
    1723                 :        2719 :           || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
    1724                 :      474305 :     goto runtime;
    1725                 :             : 
    1726                 :    11366262 :   if (op2 != NULL
    1727                 :    11240480 :       && op2->expr_type != EXPR_CONSTANT
    1728                 :    11394585 :          && (op2->expr_type != EXPR_ARRAY
    1729                 :        1741 :              || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
    1730                 :       26582 :     goto runtime;
    1731                 :             : 
    1732                 :    11339680 :   if (unary)
    1733                 :      125782 :     rc = reduce_unary (eval.f2, op1, &result);
    1734                 :             :   else
    1735                 :    11213898 :     rc = reduce_binary (eval.f3, op1, op2, &result);
    1736                 :             : 
    1737                 :    11339680 :   if (rc == ARITH_INVALID_TYPE || rc == ARITH_NOT_REDUCED)
    1738                 :          72 :     goto runtime;
    1739                 :             : 
    1740                 :             :   /* Something went wrong.  */
    1741                 :    11339608 :   if (op == INTRINSIC_POWER && rc == ARITH_PROHIBIT)
    1742                 :             :     return NULL;
    1743                 :             : 
    1744                 :    11339607 :   if (rc != ARITH_OK)
    1745                 :             :     {
    1746                 :          51 :       gfc_error (gfc_arith_error (rc), &op1->where);
    1747                 :          51 :       if (rc == ARITH_OVERFLOW)
    1748                 :          17 :         goto done;
    1749                 :             : 
    1750                 :          34 :       if (rc == ARITH_DIV0 && op2->ts.type == BT_INTEGER)
    1751                 :          21 :         gfc_seen_div0 = true;
    1752                 :             : 
    1753                 :          34 :       return NULL;
    1754                 :             :     }
    1755                 :             : 
    1756                 :    11339556 : done:
    1757                 :             : 
    1758                 :    11339573 :   gfc_free_expr (op1);
    1759                 :    11339573 :   gfc_free_expr (op2);
    1760                 :    11339573 :   return result;
    1761                 :             : 
    1762                 :     1052025 : runtime:
    1763                 :             :   /* Create a run-time expression.  */
    1764                 :     1052025 :   result = gfc_get_operator_expr (&op1->where, op, op1, op2);
    1765                 :     1052025 :   result->ts = temp.ts;
    1766                 :             : 
    1767                 :     1052025 :   return result;
    1768                 :             : }
    1769                 :             : 
    1770                 :             : 
    1771                 :             : /* Modify type of expression for zero size array.  */
    1772                 :             : 
    1773                 :             : static gfc_expr *
    1774                 :          65 : eval_type_intrinsic0 (gfc_intrinsic_op iop, gfc_expr *op)
    1775                 :             : {
    1776                 :          65 :   if (op == NULL)
    1777                 :           0 :     gfc_internal_error ("eval_type_intrinsic0(): op NULL");
    1778                 :             : 
    1779                 :          65 :   switch (iop)
    1780                 :             :     {
    1781                 :          64 :     case INTRINSIC_GE:
    1782                 :          64 :     case INTRINSIC_GE_OS:
    1783                 :          64 :     case INTRINSIC_LT:
    1784                 :          64 :     case INTRINSIC_LT_OS:
    1785                 :          64 :     case INTRINSIC_LE:
    1786                 :          64 :     case INTRINSIC_LE_OS:
    1787                 :          64 :     case INTRINSIC_GT:
    1788                 :          64 :     case INTRINSIC_GT_OS:
    1789                 :          64 :     case INTRINSIC_EQ:
    1790                 :          64 :     case INTRINSIC_EQ_OS:
    1791                 :          64 :     case INTRINSIC_NE:
    1792                 :          64 :     case INTRINSIC_NE_OS:
    1793                 :          64 :       op->ts.type = BT_LOGICAL;
    1794                 :          64 :       op->ts.kind = gfc_default_logical_kind;
    1795                 :          64 :       break;
    1796                 :             : 
    1797                 :             :     default:
    1798                 :             :       break;
    1799                 :             :     }
    1800                 :             : 
    1801                 :          65 :   return op;
    1802                 :             : }
    1803                 :             : 
    1804                 :             : 
    1805                 :             : /* Return nonzero if the expression is a zero size array.  */
    1806                 :             : 
    1807                 :             : static bool
    1808                 :    24567048 : gfc_zero_size_array (gfc_expr *e)
    1809                 :             : {
    1810                 :    24567044 :   if (e == NULL || e->expr_type != EXPR_ARRAY)
    1811                 :             :     return false;
    1812                 :             : 
    1813                 :           0 :   return e->value.constructor == NULL;
    1814                 :             : }
    1815                 :             : 
    1816                 :             : 
    1817                 :             : /* Reduce a binary expression where at least one of the operands
    1818                 :             :    involves a zero-length array.  Returns NULL if neither of the
    1819                 :             :    operands is a zero-length array.  */
    1820                 :             : 
    1821                 :             : static gfc_expr *
    1822                 :    12175410 : reduce_binary0 (gfc_expr *op1, gfc_expr *op2)
    1823                 :             : {
    1824                 :    12179822 :   if (gfc_zero_size_array (op1))
    1825                 :             :     {
    1826                 :          64 :       gfc_free_expr (op2);
    1827                 :          64 :       return op1;
    1828                 :             :     }
    1829                 :             : 
    1830                 :    12226804 :   if (gfc_zero_size_array (op2))
    1831                 :             :     {
    1832                 :           1 :       gfc_free_expr (op1);
    1833                 :           1 :       return op2;
    1834                 :             :     }
    1835                 :             : 
    1836                 :             :   return NULL;
    1837                 :             : }
    1838                 :             : 
    1839                 :             : 
    1840                 :             : static gfc_expr *
    1841                 :      216292 : eval_intrinsic_f2 (gfc_intrinsic_op op,
    1842                 :             :                    arith (*eval) (gfc_expr *, gfc_expr **),
    1843                 :             :                    gfc_expr *op1, gfc_expr *op2)
    1844                 :             : {
    1845                 :      216292 :   gfc_expr *result;
    1846                 :      216292 :   eval_f f;
    1847                 :             : 
    1848                 :      216292 :   if (op2 == NULL)
    1849                 :             :     {
    1850                 :      216410 :       if (gfc_zero_size_array (op1))
    1851                 :           0 :         return eval_type_intrinsic0 (op, op1);
    1852                 :             :     }
    1853                 :             :   else
    1854                 :             :     {
    1855                 :           0 :       result = reduce_binary0 (op1, op2);
    1856                 :           0 :       if (result != NULL)
    1857                 :           0 :         return eval_type_intrinsic0 (op, result);
    1858                 :             :     }
    1859                 :             : 
    1860                 :      216292 :   f.f2 = eval;
    1861                 :      216292 :   return eval_intrinsic (op, f, op1, op2);
    1862                 :             : }
    1863                 :             : 
    1864                 :             : 
    1865                 :             : static gfc_expr *
    1866                 :    12175415 : eval_intrinsic_f3 (gfc_intrinsic_op op,
    1867                 :             :                    arith (*eval) (gfc_expr *, gfc_expr *, gfc_expr **),
    1868                 :             :                    gfc_expr *op1, gfc_expr *op2)
    1869                 :             : {
    1870                 :    12175415 :   gfc_expr *result;
    1871                 :    12175415 :   eval_f f;
    1872                 :             : 
    1873                 :    12175415 :   if (!op1 && !op2)
    1874                 :             :     return NULL;
    1875                 :             : 
    1876                 :    12175410 :   result = reduce_binary0 (op1, op2);
    1877                 :    12175410 :   if (result != NULL)
    1878                 :          65 :     return eval_type_intrinsic0(op, result);
    1879                 :             : 
    1880                 :    12175345 :   f.f3 = eval;
    1881                 :    12175345 :   return eval_intrinsic (op, f, op1, op2);
    1882                 :             : }
    1883                 :             : 
    1884                 :             : 
    1885                 :             : gfc_expr *
    1886                 :    10256459 : gfc_parentheses (gfc_expr *op)
    1887                 :             : {
    1888                 :    10256459 :   if (gfc_is_constant_expr (op))
    1889                 :             :     return op;
    1890                 :             : 
    1891                 :           0 :   return eval_intrinsic_f2 (INTRINSIC_PARENTHESES, gfc_arith_identity,
    1892                 :           0 :                             op, NULL);
    1893                 :             : }
    1894                 :             : 
    1895                 :             : gfc_expr *
    1896                 :         392 : gfc_uplus (gfc_expr *op)
    1897                 :             : {
    1898                 :         392 :   return eval_intrinsic_f2 (INTRINSIC_UPLUS, gfc_arith_identity, op, NULL);
    1899                 :             : }
    1900                 :             : 
    1901                 :             : 
    1902                 :             : gfc_expr *
    1903                 :      144834 : gfc_uminus (gfc_expr *op)
    1904                 :             : {
    1905                 :      144834 :   return eval_intrinsic_f2 (INTRINSIC_UMINUS, gfc_arith_uminus, op, NULL);
    1906                 :             : }
    1907                 :             : 
    1908                 :             : 
    1909                 :             : gfc_expr *
    1910                 :    10398968 : gfc_add (gfc_expr *op1, gfc_expr *op2)
    1911                 :             : {
    1912                 :    10398968 :   return eval_intrinsic_f3 (INTRINSIC_PLUS, gfc_arith_plus, op1, op2);
    1913                 :             : }
    1914                 :             : 
    1915                 :             : 
    1916                 :             : gfc_expr *
    1917                 :      572566 : gfc_subtract (gfc_expr *op1, gfc_expr *op2)
    1918                 :             : {
    1919                 :      572566 :   return eval_intrinsic_f3 (INTRINSIC_MINUS, gfc_arith_minus, op1, op2);
    1920                 :             : }
    1921                 :             : 
    1922                 :             : 
    1923                 :             : gfc_expr *
    1924                 :      356732 : gfc_multiply (gfc_expr *op1, gfc_expr *op2)
    1925                 :             : {
    1926                 :      356732 :   return eval_intrinsic_f3 (INTRINSIC_TIMES, gfc_arith_times, op1, op2);
    1927                 :             : }
    1928                 :             : 
    1929                 :             : 
    1930                 :             : gfc_expr *
    1931                 :       17801 : gfc_divide (gfc_expr *op1, gfc_expr *op2)
    1932                 :             : {
    1933                 :       17801 :   return eval_intrinsic_f3 (INTRINSIC_DIVIDE, gfc_arith_divide, op1, op2);
    1934                 :             : }
    1935                 :             : 
    1936                 :             : 
    1937                 :             : gfc_expr *
    1938                 :       12301 : gfc_power (gfc_expr *op1, gfc_expr *op2)
    1939                 :             : {
    1940                 :       12301 :   return eval_intrinsic_f3 (INTRINSIC_POWER, arith_power, op1, op2);
    1941                 :             : }
    1942                 :             : 
    1943                 :             : 
    1944                 :             : gfc_expr *
    1945                 :        6109 : gfc_concat (gfc_expr *op1, gfc_expr *op2)
    1946                 :             : {
    1947                 :        6109 :   return eval_intrinsic_f3 (INTRINSIC_CONCAT, gfc_arith_concat, op1, op2);
    1948                 :             : }
    1949                 :             : 
    1950                 :             : 
    1951                 :             : gfc_expr *
    1952                 :       17646 : gfc_and (gfc_expr *op1, gfc_expr *op2)
    1953                 :             : {
    1954                 :       17646 :   return eval_intrinsic_f3 (INTRINSIC_AND, gfc_arith_and, op1, op2);
    1955                 :             : }
    1956                 :             : 
    1957                 :             : 
    1958                 :             : gfc_expr *
    1959                 :       79724 : gfc_or (gfc_expr *op1, gfc_expr *op2)
    1960                 :             : {
    1961                 :       79724 :   return eval_intrinsic_f3 (INTRINSIC_OR, gfc_arith_or, op1, op2);
    1962                 :             : }
    1963                 :             : 
    1964                 :             : 
    1965                 :             : gfc_expr *
    1966                 :       71066 : gfc_not (gfc_expr *op1)
    1967                 :             : {
    1968                 :       71066 :   return eval_intrinsic_f2 (INTRINSIC_NOT, gfc_arith_not, op1, NULL);
    1969                 :             : }
    1970                 :             : 
    1971                 :             : 
    1972                 :             : gfc_expr *
    1973                 :        1652 : gfc_eqv (gfc_expr *op1, gfc_expr *op2)
    1974                 :             : {
    1975                 :        1652 :   return eval_intrinsic_f3 (INTRINSIC_EQV, gfc_arith_eqv, op1, op2);
    1976                 :             : }
    1977                 :             : 
    1978                 :             : 
    1979                 :             : gfc_expr *
    1980                 :       21321 : gfc_neqv (gfc_expr *op1, gfc_expr *op2)
    1981                 :             : {
    1982                 :       21321 :   return eval_intrinsic_f3 (INTRINSIC_NEQV, gfc_arith_neqv, op1, op2);
    1983                 :             : }
    1984                 :             : 
    1985                 :             : 
    1986                 :             : gfc_expr *
    1987                 :       32958 : gfc_eq (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    1988                 :             : {
    1989                 :       32958 :   return eval_intrinsic_f3 (op, gfc_arith_eq, op1, op2);
    1990                 :             : }
    1991                 :             : 
    1992                 :             : 
    1993                 :             : gfc_expr *
    1994                 :      593472 : gfc_ne (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    1995                 :             : {
    1996                 :      593472 :   return eval_intrinsic_f3 (op, gfc_arith_ne, op1, op2);
    1997                 :             : }
    1998                 :             : 
    1999                 :             : 
    2000                 :             : gfc_expr *
    2001                 :       40795 : gfc_gt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    2002                 :             : {
    2003                 :       40795 :   return eval_intrinsic_f3 (op, gfc_arith_gt, op1, op2);
    2004                 :             : }
    2005                 :             : 
    2006                 :             : 
    2007                 :             : gfc_expr *
    2008                 :        4858 : gfc_ge (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    2009                 :             : {
    2010                 :        4858 :   return eval_intrinsic_f3 (op, gfc_arith_ge, op1, op2);
    2011                 :             : }
    2012                 :             : 
    2013                 :             : 
    2014                 :             : gfc_expr *
    2015                 :       10862 : gfc_lt (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    2016                 :             : {
    2017                 :       10862 :   return eval_intrinsic_f3 (op, gfc_arith_lt, op1, op2);
    2018                 :             : }
    2019                 :             : 
    2020                 :             : 
    2021                 :             : gfc_expr *
    2022                 :        7650 : gfc_le (gfc_expr *op1, gfc_expr *op2, gfc_intrinsic_op op)
    2023                 :             : {
    2024                 :        7650 :   return eval_intrinsic_f3 (op, gfc_arith_le, op1, op2);
    2025                 :             : }
    2026                 :             : 
    2027                 :             : 
    2028                 :             : /******* Simplification of intrinsic functions with constant arguments *****/
    2029                 :             : 
    2030                 :             : 
    2031                 :             : /* Deal with an arithmetic error.  */
    2032                 :             : 
    2033                 :             : static void
    2034                 :           6 : arith_error (arith rc, gfc_typespec *from, gfc_typespec *to, locus *where)
    2035                 :             : {
    2036                 :           6 :   switch (rc)
    2037                 :             :     {
    2038                 :           0 :     case ARITH_OK:
    2039                 :           0 :       gfc_error ("Arithmetic OK converting %s to %s at %L",
    2040                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2041                 :           0 :       break;
    2042                 :           6 :     case ARITH_OVERFLOW:
    2043                 :           6 :       gfc_error ("Arithmetic overflow converting %s to %s at %L. This check "
    2044                 :             :                  "can be disabled with the option %<-fno-range-check%>",
    2045                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2046                 :           6 :       break;
    2047                 :           0 :     case ARITH_UNDERFLOW:
    2048                 :           0 :       gfc_error ("Arithmetic underflow converting %s to %s at %L. This check "
    2049                 :             :                  "can be disabled with the option %<-fno-range-check%>",
    2050                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2051                 :           0 :       break;
    2052                 :           0 :     case ARITH_NAN:
    2053                 :           0 :       gfc_error ("Arithmetic NaN converting %s to %s at %L. This check "
    2054                 :             :                  "can be disabled with the option %<-fno-range-check%>",
    2055                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2056                 :           0 :       break;
    2057                 :           0 :     case ARITH_DIV0:
    2058                 :           0 :       gfc_error ("Division by zero converting %s to %s at %L",
    2059                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2060                 :           0 :       break;
    2061                 :           0 :     case ARITH_INCOMMENSURATE:
    2062                 :           0 :       gfc_error ("Array operands are incommensurate converting %s to %s at %L",
    2063                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2064                 :           0 :       break;
    2065                 :           0 :     case ARITH_ASYMMETRIC:
    2066                 :           0 :       gfc_error ("Integer outside symmetric range implied by Standard Fortran"
    2067                 :             :                  " converting %s to %s at %L",
    2068                 :             :                  gfc_typename (from), gfc_typename (to), where);
    2069                 :           0 :       break;
    2070                 :           0 :     default:
    2071                 :           0 :       gfc_internal_error ("gfc_arith_error(): Bad error code");
    2072                 :             :     }
    2073                 :             : 
    2074                 :             :   /* TODO: Do something about the error, i.e., throw exception, return
    2075                 :             :      NaN, etc.  */
    2076                 :           6 : }
    2077                 :             : 
    2078                 :             : /* Returns true if significant bits were lost when converting real
    2079                 :             :    constant r from from_kind to to_kind.  */
    2080                 :             : 
    2081                 :             : static bool
    2082                 :          19 : wprecision_real_real (mpfr_t r, int from_kind, int to_kind)
    2083                 :             : {
    2084                 :          19 :   mpfr_t rv, diff;
    2085                 :          19 :   bool ret;
    2086                 :             : 
    2087                 :          19 :   gfc_set_model_kind (to_kind);
    2088                 :          19 :   mpfr_init (rv);
    2089                 :          19 :   gfc_set_model_kind (from_kind);
    2090                 :          19 :   mpfr_init (diff);
    2091                 :             : 
    2092                 :          19 :   mpfr_set (rv, r, GFC_RND_MODE);
    2093                 :          19 :   mpfr_sub (diff, rv, r, GFC_RND_MODE);
    2094                 :             : 
    2095                 :          19 :   ret = ! mpfr_zero_p (diff);
    2096                 :          19 :   mpfr_clear (rv);
    2097                 :          19 :   mpfr_clear (diff);
    2098                 :          19 :   return ret;
    2099                 :             : }
    2100                 :             : 
    2101                 :             : /* Return true if conversion from an integer to a real loses precision.  */
    2102                 :             : 
    2103                 :             : static bool
    2104                 :          72 : wprecision_int_real (mpz_t n, mpfr_t r)
    2105                 :             : {
    2106                 :          72 :   bool ret;
    2107                 :          72 :   mpz_t i;
    2108                 :          72 :   mpz_init (i);
    2109                 :          72 :   mpfr_get_z (i, r, GFC_RND_MODE);
    2110                 :          72 :   mpz_sub (i, i, n);
    2111                 :          72 :   ret = mpz_cmp_si (i, 0) != 0;
    2112                 :          72 :   mpz_clear (i);
    2113                 :          72 :   return ret;
    2114                 :             : }
    2115                 :             : 
    2116                 :             : /* Convert integers to integers.  */
    2117                 :             : 
    2118                 :             : gfc_expr *
    2119                 :       58373 : gfc_int2int (gfc_expr *src, int kind)
    2120                 :             : {
    2121                 :       58373 :   gfc_expr *result;
    2122                 :       58373 :   arith rc;
    2123                 :             : 
    2124                 :       58373 :   if (src->ts.type != BT_INTEGER)
    2125                 :             :     return NULL;
    2126                 :             : 
    2127                 :       58373 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2128                 :             : 
    2129                 :       58373 :   mpz_set (result->value.integer, src->value.integer);
    2130                 :             : 
    2131                 :       58373 :   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
    2132                 :             :     {
    2133                 :           5 :       if (rc == ARITH_ASYMMETRIC)
    2134                 :             :         {
    2135                 :           0 :           gfc_warning (0, gfc_arith_error (rc), &src->where);
    2136                 :             :         }
    2137                 :             :       else
    2138                 :             :         {
    2139                 :           5 :           arith_error (rc, &src->ts, &result->ts, &src->where);
    2140                 :           5 :           gfc_free_expr (result);
    2141                 :           5 :           return NULL;
    2142                 :             :         }
    2143                 :             :     }
    2144                 :             : 
    2145                 :             :   /*  If we do not trap numeric overflow, we need to convert the number to
    2146                 :             :       signed, throwing away high-order bits if necessary.  */
    2147                 :       58368 :   if (flag_range_check == 0)
    2148                 :             :     {
    2149                 :         142 :       int k;
    2150                 :             : 
    2151                 :         142 :       k = gfc_validate_kind (BT_INTEGER, kind, false);
    2152                 :         142 :       gfc_convert_mpz_to_signed (result->value.integer,
    2153                 :             :                                  gfc_integer_kinds[k].bit_size);
    2154                 :             : 
    2155                 :         142 :       if (warn_conversion && !src->do_not_warn && kind < src->ts.kind)
    2156                 :           1 :         gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
    2157                 :             :                          gfc_typename (&src->ts), gfc_typename (&result->ts),
    2158                 :             :                          &src->where);
    2159                 :             :     }
    2160                 :             :   return result;
    2161                 :             : }
    2162                 :             : 
    2163                 :             : 
    2164                 :             : /* Convert integers to reals.  */
    2165                 :             : 
    2166                 :             : gfc_expr *
    2167                 :       58658 : gfc_int2real (gfc_expr *src, int kind)
    2168                 :             : {
    2169                 :       58658 :   gfc_expr *result;
    2170                 :       58658 :   arith rc;
    2171                 :             : 
    2172                 :       58658 :   if (src->ts.type != BT_INTEGER)
    2173                 :             :     return NULL;
    2174                 :             : 
    2175                 :       58657 :   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
    2176                 :             : 
    2177                 :       58657 :   mpfr_set_z (result->value.real, src->value.integer, GFC_RND_MODE);
    2178                 :             : 
    2179                 :       58657 :   if ((rc = gfc_check_real_range (result->value.real, kind)) != ARITH_OK)
    2180                 :             :     {
    2181                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2182                 :           0 :       gfc_free_expr (result);
    2183                 :           0 :       return NULL;
    2184                 :             :     }
    2185                 :             : 
    2186                 :       58657 :   if (warn_conversion
    2187                 :       58657 :       && wprecision_int_real (src->value.integer, result->value.real))
    2188                 :           4 :     gfc_warning (OPT_Wconversion, "Change of value in conversion "
    2189                 :             :                  "from %qs to %qs at %L",
    2190                 :             :                  gfc_typename (&src->ts),
    2191                 :             :                  gfc_typename (&result->ts),
    2192                 :             :                  &src->where);
    2193                 :             : 
    2194                 :             :   return result;
    2195                 :             : }
    2196                 :             : 
    2197                 :             : 
    2198                 :             : /* Convert default integer to default complex.  */
    2199                 :             : 
    2200                 :             : gfc_expr *
    2201                 :         832 : gfc_int2complex (gfc_expr *src, int kind)
    2202                 :             : {
    2203                 :         832 :   gfc_expr *result;
    2204                 :         832 :   arith rc;
    2205                 :             : 
    2206                 :         832 :   if (src->ts.type != BT_INTEGER)
    2207                 :             :     return NULL;
    2208                 :             : 
    2209                 :         829 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
    2210                 :             : 
    2211                 :         829 :   mpc_set_z (result->value.complex, src->value.integer, GFC_MPC_RND_MODE);
    2212                 :             : 
    2213                 :         829 :   if ((rc = gfc_check_real_range (mpc_realref (result->value.complex), kind))
    2214                 :             :       != ARITH_OK)
    2215                 :             :     {
    2216                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2217                 :           0 :       gfc_free_expr (result);
    2218                 :           0 :       return NULL;
    2219                 :             :     }
    2220                 :             : 
    2221                 :         829 :   if (warn_conversion
    2222                 :         829 :       && wprecision_int_real (src->value.integer,
    2223                 :             :                               mpc_realref (result->value.complex)))
    2224                 :           1 :       gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
    2225                 :             :                        "from %qs to %qs at %L",
    2226                 :             :                        gfc_typename (&src->ts),
    2227                 :             :                        gfc_typename (&result->ts),
    2228                 :             :                        &src->where);
    2229                 :             : 
    2230                 :             :   return result;
    2231                 :             : }
    2232                 :             : 
    2233                 :             : 
    2234                 :             : /* Convert default real to default integer.  */
    2235                 :             : 
    2236                 :             : gfc_expr *
    2237                 :         278 : gfc_real2int (gfc_expr *src, int kind)
    2238                 :             : {
    2239                 :         278 :   gfc_expr *result;
    2240                 :         278 :   arith rc;
    2241                 :         278 :   bool did_warn = false;
    2242                 :             : 
    2243                 :         278 :   if (src->ts.type != BT_REAL)
    2244                 :             :     return NULL;
    2245                 :             : 
    2246                 :         278 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2247                 :             : 
    2248                 :         278 :   gfc_mpfr_to_mpz (result->value.integer, src->value.real, &src->where);
    2249                 :             : 
    2250                 :         278 :   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
    2251                 :             :     {
    2252                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2253                 :           0 :       gfc_free_expr (result);
    2254                 :           0 :       return NULL;
    2255                 :             :     }
    2256                 :             : 
    2257                 :             :   /* If there was a fractional part, warn about this.  */
    2258                 :             : 
    2259                 :         278 :   if (warn_conversion)
    2260                 :             :     {
    2261                 :           4 :       mpfr_t f;
    2262                 :           4 :       mpfr_init (f);
    2263                 :           4 :       mpfr_frac (f, src->value.real, GFC_RND_MODE);
    2264                 :           4 :       if (mpfr_cmp_si (f, 0) != 0)
    2265                 :             :         {
    2266                 :           2 :           gfc_warning_now (OPT_Wconversion, "Change of value in conversion "
    2267                 :             :                            "from %qs to %qs at %L", gfc_typename (&src->ts),
    2268                 :             :                            gfc_typename (&result->ts), &src->where);
    2269                 :           2 :           did_warn = true;
    2270                 :             :         }
    2271                 :           4 :       mpfr_clear (f);
    2272                 :             :     }
    2273                 :         278 :   if (!did_warn && warn_conversion_extra)
    2274                 :             :     {
    2275                 :           1 :       gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
    2276                 :             :                        "at %L", gfc_typename (&src->ts),
    2277                 :             :                        gfc_typename (&result->ts), &src->where);
    2278                 :             :     }
    2279                 :             : 
    2280                 :             :   return result;
    2281                 :             : }
    2282                 :             : 
    2283                 :             : 
    2284                 :             : /* Convert real to real.  */
    2285                 :             : 
    2286                 :             : gfc_expr *
    2287                 :        7301 : gfc_real2real (gfc_expr *src, int kind)
    2288                 :             : {
    2289                 :        7301 :   gfc_expr *result;
    2290                 :        7301 :   arith rc;
    2291                 :        7301 :   bool did_warn = false;
    2292                 :             : 
    2293                 :        7301 :   if (src->ts.type != BT_REAL)
    2294                 :             :     return NULL;
    2295                 :             : 
    2296                 :        7297 :   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
    2297                 :             : 
    2298                 :        7297 :   mpfr_set (result->value.real, src->value.real, GFC_RND_MODE);
    2299                 :             : 
    2300                 :        7297 :   rc = gfc_check_real_range (result->value.real, kind);
    2301                 :             : 
    2302                 :        7297 :   if (rc == ARITH_UNDERFLOW)
    2303                 :             :     {
    2304                 :           0 :       if (warn_underflow)
    2305                 :           0 :         gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    2306                 :           0 :       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    2307                 :             :     }
    2308                 :        7297 :   else if (rc != ARITH_OK)
    2309                 :             :     {
    2310                 :           1 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2311                 :           1 :       gfc_free_expr (result);
    2312                 :           1 :       return NULL;
    2313                 :             :     }
    2314                 :             : 
    2315                 :             :   /* As a special bonus, don't warn about REAL values which are not changed by
    2316                 :             :      the conversion if -Wconversion is specified and -Wconversion-extra is
    2317                 :             :      not.  */
    2318                 :             : 
    2319                 :        7296 :   if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
    2320                 :             :     {
    2321                 :          11 :       int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
    2322                 :             : 
    2323                 :             :       /* Calculate the difference between the constant and the rounded
    2324                 :             :          value and check it against zero.  */
    2325                 :             : 
    2326                 :          11 :       if (wprecision_real_real (src->value.real, src->ts.kind, kind))
    2327                 :             :         {
    2328                 :           2 :           gfc_warning_now (w, "Change of value in conversion from "
    2329                 :             :                            "%qs to %qs at %L",
    2330                 :             :                            gfc_typename (&src->ts), gfc_typename (&result->ts),
    2331                 :             :                            &src->where);
    2332                 :             :           /* Make sure the conversion warning is not emitted again.  */
    2333                 :           2 :           did_warn = true;
    2334                 :             :         }
    2335                 :             :     }
    2336                 :             : 
    2337                 :        7296 :     if (!did_warn && warn_conversion_extra)
    2338                 :           8 :       gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
    2339                 :             :                        "at %L", gfc_typename(&src->ts),
    2340                 :             :                        gfc_typename(&result->ts), &src->where);
    2341                 :             : 
    2342                 :             :   return result;
    2343                 :             : }
    2344                 :             : 
    2345                 :             : 
    2346                 :             : /* Convert real to complex.  */
    2347                 :             : 
    2348                 :             : gfc_expr *
    2349                 :        1308 : gfc_real2complex (gfc_expr *src, int kind)
    2350                 :             : {
    2351                 :        1308 :   gfc_expr *result;
    2352                 :        1308 :   arith rc;
    2353                 :        1308 :   bool did_warn = false;
    2354                 :             : 
    2355                 :        1308 :   if (src->ts.type != BT_REAL)
    2356                 :             :     return NULL;
    2357                 :             : 
    2358                 :        1303 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
    2359                 :             : 
    2360                 :        1303 :   mpc_set_fr (result->value.complex, src->value.real, GFC_MPC_RND_MODE);
    2361                 :             : 
    2362                 :        1303 :   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
    2363                 :             : 
    2364                 :        1303 :   if (rc == ARITH_UNDERFLOW)
    2365                 :             :     {
    2366                 :           0 :       if (warn_underflow)
    2367                 :           0 :         gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    2368                 :           0 :       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
    2369                 :             :     }
    2370                 :        1303 :   else if (rc != ARITH_OK)
    2371                 :             :     {
    2372                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2373                 :           0 :       gfc_free_expr (result);
    2374                 :           0 :       return NULL;
    2375                 :             :     }
    2376                 :             : 
    2377                 :        1303 :   if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind)
    2378                 :             :     {
    2379                 :           2 :       int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
    2380                 :             : 
    2381                 :           2 :       if (wprecision_real_real (src->value.real, src->ts.kind, kind))
    2382                 :             :         {
    2383                 :           1 :           gfc_warning_now (w, "Change of value in conversion from "
    2384                 :             :                            "%qs to %qs at %L",
    2385                 :             :                            gfc_typename (&src->ts), gfc_typename (&result->ts),
    2386                 :             :                            &src->where);
    2387                 :             :           /* Make sure the conversion warning is not emitted again.  */
    2388                 :           1 :           did_warn = true;
    2389                 :             :         }
    2390                 :             :     }
    2391                 :             : 
    2392                 :        1303 :   if (!did_warn && warn_conversion_extra)
    2393                 :           2 :     gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
    2394                 :             :                      "at %L", gfc_typename(&src->ts),
    2395                 :             :                      gfc_typename(&result->ts), &src->where);
    2396                 :             : 
    2397                 :             :   return result;
    2398                 :             : }
    2399                 :             : 
    2400                 :             : 
    2401                 :             : /* Convert complex to integer.  */
    2402                 :             : 
    2403                 :             : gfc_expr *
    2404                 :          80 : gfc_complex2int (gfc_expr *src, int kind)
    2405                 :             : {
    2406                 :          80 :   gfc_expr *result;
    2407                 :          80 :   arith rc;
    2408                 :          80 :   bool did_warn = false;
    2409                 :             : 
    2410                 :          80 :   if (src->ts.type != BT_COMPLEX)
    2411                 :             :     return NULL;
    2412                 :             : 
    2413                 :          80 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2414                 :             : 
    2415                 :          80 :   gfc_mpfr_to_mpz (result->value.integer, mpc_realref (src->value.complex),
    2416                 :             :                    &src->where);
    2417                 :             : 
    2418                 :          80 :   if ((rc = gfc_check_integer_range (result->value.integer, kind)) != ARITH_OK)
    2419                 :             :     {
    2420                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2421                 :           0 :       gfc_free_expr (result);
    2422                 :           0 :       return NULL;
    2423                 :             :     }
    2424                 :             : 
    2425                 :          80 :   if (warn_conversion || warn_conversion_extra)
    2426                 :             :     {
    2427                 :           4 :       int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
    2428                 :             : 
    2429                 :             :       /* See if we discarded an imaginary part.  */
    2430                 :           4 :       if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
    2431                 :             :         {
    2432                 :           2 :           gfc_warning_now (w, "Non-zero imaginary part discarded "
    2433                 :             :                            "in conversion from %qs to %qs at %L",
    2434                 :             :                            gfc_typename(&src->ts), gfc_typename (&result->ts),
    2435                 :             :                            &src->where);
    2436                 :           2 :           did_warn = true;
    2437                 :             :         }
    2438                 :             : 
    2439                 :             :       else {
    2440                 :           2 :         mpfr_t f;
    2441                 :             : 
    2442                 :           2 :         mpfr_init (f);
    2443                 :           2 :         mpfr_frac (f, src->value.real, GFC_RND_MODE);
    2444                 :           2 :         if (mpfr_cmp_si (f, 0) != 0)
    2445                 :             :           {
    2446                 :           1 :             gfc_warning_now (w, "Change of value in conversion from "
    2447                 :             :                              "%qs to %qs at %L", gfc_typename (&src->ts),
    2448                 :             :                              gfc_typename (&result->ts), &src->where);
    2449                 :           1 :             did_warn = true;
    2450                 :             :           }
    2451                 :           2 :         mpfr_clear (f);
    2452                 :             :       }
    2453                 :             : 
    2454                 :           4 :       if (!did_warn && warn_conversion_extra)
    2455                 :             :         {
    2456                 :           0 :           gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
    2457                 :             :                            "at %L", gfc_typename (&src->ts),
    2458                 :             :                            gfc_typename (&result->ts), &src->where);
    2459                 :             :         }
    2460                 :             :     }
    2461                 :             : 
    2462                 :             :   return result;
    2463                 :             : }
    2464                 :             : 
    2465                 :             : 
    2466                 :             : /* Convert complex to real.  */
    2467                 :             : 
    2468                 :             : gfc_expr *
    2469                 :         209 : gfc_complex2real (gfc_expr *src, int kind)
    2470                 :             : {
    2471                 :         209 :   gfc_expr *result;
    2472                 :         209 :   arith rc;
    2473                 :         209 :   bool did_warn = false;
    2474                 :             : 
    2475                 :         209 :   if (src->ts.type != BT_COMPLEX)
    2476                 :             :     return NULL;
    2477                 :             : 
    2478                 :         209 :   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
    2479                 :             : 
    2480                 :         209 :   mpc_real (result->value.real, src->value.complex, GFC_RND_MODE);
    2481                 :             : 
    2482                 :         209 :   rc = gfc_check_real_range (result->value.real, kind);
    2483                 :             : 
    2484                 :         209 :   if (rc == ARITH_UNDERFLOW)
    2485                 :             :     {
    2486                 :           0 :       if (warn_underflow)
    2487                 :           0 :         gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    2488                 :           0 :       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    2489                 :             :     }
    2490                 :         209 :   if (rc != ARITH_OK)
    2491                 :             :     {
    2492                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2493                 :           0 :       gfc_free_expr (result);
    2494                 :           0 :       return NULL;
    2495                 :             :     }
    2496                 :             : 
    2497                 :         209 :   if (warn_conversion || warn_conversion_extra)
    2498                 :             :     {
    2499                 :           4 :       int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
    2500                 :             : 
    2501                 :             :       /* See if we discarded an imaginary part.  */
    2502                 :           4 :       if (mpfr_cmp_si (mpc_imagref (src->value.complex), 0) != 0)
    2503                 :             :         {
    2504                 :           4 :           gfc_warning (w, "Non-zero imaginary part discarded "
    2505                 :             :                        "in conversion from %qs to %qs at %L",
    2506                 :             :                        gfc_typename(&src->ts), gfc_typename (&result->ts),
    2507                 :             :                        &src->where);
    2508                 :           4 :           did_warn = true;
    2509                 :             :         }
    2510                 :             : 
    2511                 :             :       /* Calculate the difference between the real constant and the rounded
    2512                 :             :          value and check it against zero.  */
    2513                 :             : 
    2514                 :           4 :       if (kind > src->ts.kind
    2515                 :           4 :           && wprecision_real_real (mpc_realref (src->value.complex),
    2516                 :             :                                    src->ts.kind, kind))
    2517                 :             :         {
    2518                 :           0 :           gfc_warning_now (w, "Change of value in conversion from "
    2519                 :             :                            "%qs to %qs at %L",
    2520                 :             :                            gfc_typename (&src->ts), gfc_typename (&result->ts),
    2521                 :             :                            &src->where);
    2522                 :             :           /* Make sure the conversion warning is not emitted again.  */
    2523                 :           0 :           did_warn = true;
    2524                 :             :         }
    2525                 :             :     }
    2526                 :             : 
    2527                 :         209 :   if (!did_warn && warn_conversion_extra)
    2528                 :           0 :     gfc_warning_now (OPT_Wconversion, "Conversion from %qs to %qs at %L",
    2529                 :             :                      gfc_typename(&src->ts), gfc_typename (&result->ts),
    2530                 :             :                      &src->where);
    2531                 :             : 
    2532                 :             :   return result;
    2533                 :             : }
    2534                 :             : 
    2535                 :             : 
    2536                 :             : /* Convert complex to complex.  */
    2537                 :             : 
    2538                 :             : gfc_expr *
    2539                 :         679 : gfc_complex2complex (gfc_expr *src, int kind)
    2540                 :             : {
    2541                 :         679 :   gfc_expr *result;
    2542                 :         679 :   arith rc;
    2543                 :         679 :   bool did_warn = false;
    2544                 :             : 
    2545                 :         679 :   if (src->ts.type != BT_COMPLEX)
    2546                 :             :     return NULL;
    2547                 :             : 
    2548                 :         675 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
    2549                 :             : 
    2550                 :         675 :   mpc_set (result->value.complex, src->value.complex, GFC_MPC_RND_MODE);
    2551                 :             : 
    2552                 :         675 :   rc = gfc_check_real_range (mpc_realref (result->value.complex), kind);
    2553                 :             : 
    2554                 :         675 :   if (rc == ARITH_UNDERFLOW)
    2555                 :             :     {
    2556                 :           0 :       if (warn_underflow)
    2557                 :           0 :         gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    2558                 :           0 :       mpfr_set_ui (mpc_realref (result->value.complex), 0, GFC_RND_MODE);
    2559                 :             :     }
    2560                 :         675 :   else if (rc != ARITH_OK)
    2561                 :             :     {
    2562                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2563                 :           0 :       gfc_free_expr (result);
    2564                 :           0 :       return NULL;
    2565                 :             :     }
    2566                 :             : 
    2567                 :         675 :   rc = gfc_check_real_range (mpc_imagref (result->value.complex), kind);
    2568                 :             : 
    2569                 :         675 :   if (rc == ARITH_UNDERFLOW)
    2570                 :             :     {
    2571                 :           0 :       if (warn_underflow)
    2572                 :           0 :         gfc_warning (OPT_Woverflow, gfc_arith_error (rc), &src->where);
    2573                 :           0 :       mpfr_set_ui (mpc_imagref (result->value.complex), 0, GFC_RND_MODE);
    2574                 :             :     }
    2575                 :         675 :   else if (rc != ARITH_OK)
    2576                 :             :     {
    2577                 :           0 :       arith_error (rc, &src->ts, &result->ts, &src->where);
    2578                 :           0 :       gfc_free_expr (result);
    2579                 :           0 :       return NULL;
    2580                 :             :     }
    2581                 :             : 
    2582                 :         675 :   if ((warn_conversion || warn_conversion_extra) && src->ts.kind > kind
    2583                 :         678 :       && (wprecision_real_real (mpc_realref (src->value.complex),
    2584                 :             :                                 src->ts.kind, kind)
    2585                 :           3 :           || wprecision_real_real (mpc_imagref (src->value.complex),
    2586                 :             :                                    src->ts.kind, kind)))
    2587                 :             :     {
    2588                 :           3 :       int w = warn_conversion ? OPT_Wconversion : OPT_Wconversion_extra;
    2589                 :             : 
    2590                 :           3 :       gfc_warning_now (w, "Change of value in conversion from "
    2591                 :             :                        "%qs to %qs at %L",
    2592                 :             :                        gfc_typename (&src->ts), gfc_typename (&result->ts),
    2593                 :             :                        &src->where);
    2594                 :           3 :       did_warn = true;
    2595                 :             :     }
    2596                 :             : 
    2597                 :         675 :   if (!did_warn && warn_conversion_extra && src->ts.kind != kind)
    2598                 :           1 :     gfc_warning_now (OPT_Wconversion_extra, "Conversion from %qs to %qs "
    2599                 :             :                      "at %L", gfc_typename(&src->ts),
    2600                 :             :                      gfc_typename (&result->ts), &src->where);
    2601                 :             : 
    2602                 :             :   return result;
    2603                 :             : }
    2604                 :             : 
    2605                 :             : 
    2606                 :             : /* Logical kind conversion.  */
    2607                 :             : 
    2608                 :             : gfc_expr *
    2609                 :         674 : gfc_log2log (gfc_expr *src, int kind)
    2610                 :             : {
    2611                 :         674 :   gfc_expr *result;
    2612                 :             : 
    2613                 :         674 :   if (src->ts.type != BT_LOGICAL)
    2614                 :             :     return NULL;
    2615                 :             : 
    2616                 :         674 :   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
    2617                 :         674 :   result->value.logical = src->value.logical;
    2618                 :             : 
    2619                 :         674 :   return result;
    2620                 :             : }
    2621                 :             : 
    2622                 :             : 
    2623                 :             : /* Convert logical to integer.  */
    2624                 :             : 
    2625                 :             : gfc_expr *
    2626                 :          14 : gfc_log2int (gfc_expr *src, int kind)
    2627                 :             : {
    2628                 :          14 :   gfc_expr *result;
    2629                 :             : 
    2630                 :          14 :   if (src->ts.type != BT_LOGICAL)
    2631                 :             :     return NULL;
    2632                 :             : 
    2633                 :          14 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2634                 :          14 :   mpz_set_si (result->value.integer, src->value.logical);
    2635                 :             : 
    2636                 :          14 :   return result;
    2637                 :             : }
    2638                 :             : 
    2639                 :             : 
    2640                 :             : /* Convert integer to logical.  */
    2641                 :             : 
    2642                 :             : gfc_expr *
    2643                 :           0 : gfc_int2log (gfc_expr *src, int kind)
    2644                 :             : {
    2645                 :           0 :   gfc_expr *result;
    2646                 :             : 
    2647                 :           0 :   if (src->ts.type != BT_INTEGER)
    2648                 :             :     return NULL;
    2649                 :             : 
    2650                 :           0 :   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
    2651                 :           0 :   result->value.logical = (mpz_cmp_si (src->value.integer, 0) != 0);
    2652                 :             : 
    2653                 :           0 :   return result;
    2654                 :             : }
    2655                 :             : 
    2656                 :             : /* Convert character to character. We only use wide strings internally,
    2657                 :             :    so we only set the kind.  */
    2658                 :             : 
    2659                 :             : gfc_expr *
    2660                 :           0 : gfc_character2character (gfc_expr *src, int kind)
    2661                 :             : {
    2662                 :           0 :   gfc_expr *result;
    2663                 :           0 :   result = gfc_copy_expr (src);
    2664                 :           0 :   result->ts.kind = kind;
    2665                 :             : 
    2666                 :           0 :   return result;
    2667                 :             : }
    2668                 :             : 
    2669                 :             : /* Helper function to set the representation in a Hollerith conversion.
    2670                 :             :    This assumes that the ts.type and ts.kind of the result have already
    2671                 :             :    been set.  */
    2672                 :             : 
    2673                 :             : static void
    2674                 :        1187 : hollerith2representation (gfc_expr *result, gfc_expr *src)
    2675                 :             : {
    2676                 :        1187 :   size_t src_len, result_len;
    2677                 :             : 
    2678                 :        1187 :   src_len = src->representation.length - src->ts.u.pad;
    2679                 :        1187 :   gfc_target_expr_size (result, &result_len);
    2680                 :             : 
    2681                 :        1187 :   if (src_len > result_len)
    2682                 :             :     {
    2683                 :         248 :       gfc_warning (OPT_Wcharacter_truncation, "The Hollerith constant at %L "
    2684                 :             :                    "is truncated in conversion to %qs", &src->where,
    2685                 :             :                    gfc_typename(&result->ts));
    2686                 :             :     }
    2687                 :             : 
    2688                 :        1187 :   result->representation.string = XCNEWVEC (char, result_len + 1);
    2689                 :        1187 :   memcpy (result->representation.string, src->representation.string,
    2690                 :        1187 :           MIN (result_len, src_len));
    2691                 :             : 
    2692                 :        1187 :   if (src_len < result_len)
    2693                 :         294 :     memset (&result->representation.string[src_len], ' ', result_len - src_len);
    2694                 :             : 
    2695                 :        1187 :   result->representation.string[result_len] = '\0'; /* For debugger  */
    2696                 :        1187 :   result->representation.length = result_len;
    2697                 :        1187 : }
    2698                 :             : 
    2699                 :             : 
    2700                 :             : /* Helper function to set the representation in a character conversion.
    2701                 :             :    This assumes that the ts.type and ts.kind of the result have already
    2702                 :             :    been set.  */
    2703                 :             : 
    2704                 :             : static void
    2705                 :         747 : character2representation (gfc_expr *result, gfc_expr *src)
    2706                 :             : {
    2707                 :         747 :   size_t src_len, result_len, i;
    2708                 :         747 :   src_len = src->value.character.length;
    2709                 :         747 :   gfc_target_expr_size (result, &result_len);
    2710                 :             : 
    2711                 :         747 :   if (src_len > result_len)
    2712                 :         240 :     gfc_warning (OPT_Wcharacter_truncation, "The character constant at %L is "
    2713                 :             :                  "truncated in conversion to %s", &src->where,
    2714                 :             :                  gfc_typename(&result->ts));
    2715                 :             : 
    2716                 :         747 :   result->representation.string = XCNEWVEC (char, result_len + 1);
    2717                 :             : 
    2718                 :        3991 :   for (i = 0; i < MIN (result_len, src_len); i++)
    2719                 :        3244 :     result->representation.string[i] = (char) src->value.character.string[i];
    2720                 :             : 
    2721                 :         747 :   if (src_len < result_len)
    2722                 :         246 :     memset (&result->representation.string[src_len], ' ',
    2723                 :             :             result_len - src_len);
    2724                 :             : 
    2725                 :         747 :   result->representation.string[result_len] = '\0'; /* For debugger.  */
    2726                 :         747 :   result->representation.length = result_len;
    2727                 :         747 : }
    2728                 :             : 
    2729                 :             : /* Convert Hollerith to integer. The constant will be padded or truncated.  */
    2730                 :             : 
    2731                 :             : gfc_expr *
    2732                 :         377 : gfc_hollerith2int (gfc_expr *src, int kind)
    2733                 :             : {
    2734                 :         377 :   gfc_expr *result;
    2735                 :         377 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2736                 :             : 
    2737                 :         377 :   hollerith2representation (result, src);
    2738                 :         377 :   gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
    2739                 :         377 :                          result->representation.length, result->value.integer);
    2740                 :             : 
    2741                 :         377 :   return result;
    2742                 :             : }
    2743                 :             : 
    2744                 :             : /* Convert character to integer.  The constant will be padded or truncated.  */
    2745                 :             : 
    2746                 :             : gfc_expr *
    2747                 :         187 : gfc_character2int (gfc_expr *src, int kind)
    2748                 :             : {
    2749                 :         187 :   gfc_expr *result;
    2750                 :         187 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &src->where);
    2751                 :             : 
    2752                 :         187 :   character2representation (result, src);
    2753                 :         187 :   gfc_interpret_integer (kind, (unsigned char *) result->representation.string,
    2754                 :         187 :                          result->representation.length, result->value.integer);
    2755                 :         187 :   return result;
    2756                 :             : }
    2757                 :             : 
    2758                 :             : /* Convert Hollerith to real.  The constant will be padded or truncated.  */
    2759                 :             : 
    2760                 :             : gfc_expr *
    2761                 :         327 : gfc_hollerith2real (gfc_expr *src, int kind)
    2762                 :             : {
    2763                 :         327 :   gfc_expr *result;
    2764                 :         327 :   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
    2765                 :             : 
    2766                 :         327 :   hollerith2representation (result, src);
    2767                 :         327 :   if (gfc_interpret_float (kind,
    2768                 :         327 :                            (unsigned char *) result->representation.string,
    2769                 :         327 :                            result->representation.length, result->value.real))
    2770                 :             :     return result;
    2771                 :             :   else
    2772                 :           0 :     return NULL;
    2773                 :             : }
    2774                 :             : 
    2775                 :             : /* Convert character to real.  The constant will be padded or truncated.  */
    2776                 :             : 
    2777                 :             : gfc_expr *
    2778                 :         187 : gfc_character2real (gfc_expr *src, int kind)
    2779                 :             : {
    2780                 :         187 :   gfc_expr *result;
    2781                 :         187 :   result = gfc_get_constant_expr (BT_REAL, kind, &src->where);
    2782                 :             : 
    2783                 :         187 :   character2representation (result, src);
    2784                 :         187 :   gfc_interpret_float (kind, (unsigned char *) result->representation.string,
    2785                 :         187 :                        result->representation.length, result->value.real);
    2786                 :             : 
    2787                 :         187 :   return result;
    2788                 :             : }
    2789                 :             : 
    2790                 :             : 
    2791                 :             : /* Convert Hollerith to complex. The constant will be padded or truncated.  */
    2792                 :             : 
    2793                 :             : gfc_expr *
    2794                 :         288 : gfc_hollerith2complex (gfc_expr *src, int kind)
    2795                 :             : {
    2796                 :         288 :   gfc_expr *result;
    2797                 :         288 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
    2798                 :             : 
    2799                 :         288 :   hollerith2representation (result, src);
    2800                 :         288 :   gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
    2801                 :         288 :                          result->representation.length, result->value.complex);
    2802                 :             : 
    2803                 :         288 :   return result;
    2804                 :             : }
    2805                 :             : 
    2806                 :             : /* Convert character to complex. The constant will be padded or truncated.  */
    2807                 :             : 
    2808                 :             : gfc_expr *
    2809                 :         187 : gfc_character2complex (gfc_expr *src, int kind)
    2810                 :             : {
    2811                 :         187 :   gfc_expr *result;
    2812                 :         187 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &src->where);
    2813                 :             : 
    2814                 :         187 :   character2representation (result, src);
    2815                 :         187 :   gfc_interpret_complex (kind, (unsigned char *) result->representation.string,
    2816                 :         187 :                          result->representation.length, result->value.complex);
    2817                 :             : 
    2818                 :         187 :   return result;
    2819                 :             : }
    2820                 :             : 
    2821                 :             : 
    2822                 :             : /* Convert Hollerith to character.  */
    2823                 :             : 
    2824                 :             : gfc_expr *
    2825                 :         174 : gfc_hollerith2character (gfc_expr *src, int kind)
    2826                 :             : {
    2827                 :         174 :   gfc_expr *result;
    2828                 :             : 
    2829                 :         174 :   result = gfc_copy_expr (src);
    2830                 :         174 :   result->ts.type = BT_CHARACTER;
    2831                 :         174 :   result->ts.kind = kind;
    2832                 :         174 :   result->ts.u.pad = 0;
    2833                 :             : 
    2834                 :         174 :   result->value.character.length = result->representation.length;
    2835                 :         174 :   result->value.character.string
    2836                 :         174 :     = gfc_char_to_widechar (result->representation.string);
    2837                 :             : 
    2838                 :         174 :   return result;
    2839                 :             : }
    2840                 :             : 
    2841                 :             : 
    2842                 :             : /* Convert Hollerith to logical. The constant will be padded or truncated.  */
    2843                 :             : 
    2844                 :             : gfc_expr *
    2845                 :         195 : gfc_hollerith2logical (gfc_expr *src, int kind)
    2846                 :             : {
    2847                 :         195 :   gfc_expr *result;
    2848                 :         195 :   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
    2849                 :             : 
    2850                 :         195 :   hollerith2representation (result, src);
    2851                 :         195 :   gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
    2852                 :         195 :                          result->representation.length, &result->value.logical);
    2853                 :             : 
    2854                 :         195 :   return result;
    2855                 :             : }
    2856                 :             : 
    2857                 :             : /* Convert character to logical. The constant will be padded or truncated.  */
    2858                 :             : 
    2859                 :             : gfc_expr *
    2860                 :         186 : gfc_character2logical (gfc_expr *src, int kind)
    2861                 :             : {
    2862                 :         186 :   gfc_expr *result;
    2863                 :         186 :   result = gfc_get_constant_expr (BT_LOGICAL, kind, &src->where);
    2864                 :             : 
    2865                 :         186 :   character2representation (result, src);
    2866                 :         186 :   gfc_interpret_logical (kind, (unsigned char *) result->representation.string,
    2867                 :         186 :                          result->representation.length, &result->value.logical);
    2868                 :             : 
    2869                 :         186 :   return result;
    2870                 :             : }
        

Generated by: LCOV version 2.0-1

LCOV profile is generated on x86_64 machine using following configure options: configure --disable-bootstrap --enable-coverage=opt --enable-languages=c,c++,fortran,go,jit,lto,rust,m2 --enable-host-shared. GCC test suite is run with the built compiler.