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

Generated by: LCOV version 1.0

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 --enable-host-shared. GCC test suite is run with the built compiler.