LCOV - code coverage report
Current view: top level - gcc/fortran - simplify.c (source / functions) Hit Total Coverage
Test: gcc.info Lines: 3817 4169 91.6 %
Date: 2020-03-28 11:57:23 Functions: 240 246 97.6 %
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: 0 0 -

           Branch data     Line data    Source code
       1                 :            : /* Simplify intrinsic functions at compile-time.
       2                 :            :    Copyright (C) 2000-2020 Free Software Foundation, Inc.
       3                 :            :    Contributed by Andy Vaught & Katherine Holcomb
       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                 :            : #include "config.h"
      22                 :            : #include "system.h"
      23                 :            : #include "coretypes.h"
      24                 :            : #include "tm.h"               /* For BITS_PER_UNIT.  */
      25                 :            : #include "gfortran.h"
      26                 :            : #include "arith.h"
      27                 :            : #include "intrinsic.h"
      28                 :            : #include "match.h"
      29                 :            : #include "target-memory.h"
      30                 :            : #include "constructor.h"
      31                 :            : #include "version.h"  /* For version_string.  */
      32                 :            : 
      33                 :            : /* Prototypes.  */
      34                 :            : 
      35                 :            : static int min_max_choose (gfc_expr *, gfc_expr *, int, bool back_val = false);
      36                 :            : 
      37                 :            : gfc_expr gfc_bad_expr;
      38                 :            : 
      39                 :            : static gfc_expr *simplify_size (gfc_expr *, gfc_expr *, int);
      40                 :            : 
      41                 :            : 
      42                 :            : /* Note that 'simplification' is not just transforming expressions.
      43                 :            :    For functions that are not simplified at compile time, range
      44                 :            :    checking is done if possible.
      45                 :            : 
      46                 :            :    The return convention is that each simplification function returns:
      47                 :            : 
      48                 :            :      A new expression node corresponding to the simplified arguments.
      49                 :            :      The original arguments are destroyed by the caller, and must not
      50                 :            :      be a part of the new expression.
      51                 :            : 
      52                 :            :      NULL pointer indicating that no simplification was possible and
      53                 :            :      the original expression should remain intact.
      54                 :            : 
      55                 :            :      An expression pointer to gfc_bad_expr (a static placeholder)
      56                 :            :      indicating that some error has prevented simplification.  The
      57                 :            :      error is generated within the function and should be propagated
      58                 :            :      upwards
      59                 :            : 
      60                 :            :    By the time a simplification function gets control, it has been
      61                 :            :    decided that the function call is really supposed to be the
      62                 :            :    intrinsic.  No type checking is strictly necessary, since only
      63                 :            :    valid types will be passed on.  On the other hand, a simplification
      64                 :            :    subroutine may have to look at the type of an argument as part of
      65                 :            :    its processing.
      66                 :            : 
      67                 :            :    Array arguments are only passed to these subroutines that implement
      68                 :            :    the simplification of transformational intrinsics.
      69                 :            : 
      70                 :            :    The functions in this file don't have much comment with them, but
      71                 :            :    everything is reasonably straight-forward.  The Standard, chapter 13
      72                 :            :    is the best comment you'll find for this file anyway.  */
      73                 :            : 
      74                 :            : /* Range checks an expression node.  If all goes well, returns the
      75                 :            :    node, otherwise returns &gfc_bad_expr and frees the node.  */
      76                 :            : 
      77                 :            : static gfc_expr *
      78                 :     323566 : range_check (gfc_expr *result, const char *name)
      79                 :            : {
      80                 :     323566 :   if (result == NULL)
      81                 :            :     return &gfc_bad_expr;
      82                 :            : 
      83                 :     323566 :   if (result->expr_type != EXPR_CONSTANT)
      84                 :            :     return result;
      85                 :            : 
      86                 :     323522 :   switch (gfc_range_check (result))
      87                 :            :     {
      88                 :            :       case ARITH_OK:
      89                 :            :         return result;
      90                 :            : 
      91                 :          3 :       case ARITH_OVERFLOW:
      92                 :          3 :         gfc_error ("Result of %s overflows its kind at %L", name,
      93                 :            :                    &result->where);
      94                 :          3 :         break;
      95                 :            : 
      96                 :          0 :       case ARITH_UNDERFLOW:
      97                 :          0 :         gfc_error ("Result of %s underflows its kind at %L", name,
      98                 :            :                    &result->where);
      99                 :          0 :         break;
     100                 :            : 
     101                 :          0 :       case ARITH_NAN:
     102                 :          0 :         gfc_error ("Result of %s is NaN at %L", name, &result->where);
     103                 :          0 :         break;
     104                 :            : 
     105                 :          0 :       default:
     106                 :          0 :         gfc_error ("Result of %s gives range error for its kind at %L", name,
     107                 :            :                    &result->where);
     108                 :          0 :         break;
     109                 :            :     }
     110                 :            : 
     111                 :          3 :   gfc_free_expr (result);
     112                 :          3 :   return &gfc_bad_expr;
     113                 :            : }
     114                 :            : 
     115                 :            : 
     116                 :            : /* A helper function that gets an optional and possibly missing
     117                 :            :    kind parameter.  Returns the kind, -1 if something went wrong.  */
     118                 :            : 
     119                 :            : static int
     120                 :      99776 : get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
     121                 :            : {
     122                 :      99776 :   int kind;
     123                 :            : 
     124                 :      99776 :   if (k == NULL)
     125                 :            :     return default_kind;
     126                 :            : 
     127                 :      20830 :   if (k->expr_type != EXPR_CONSTANT)
     128                 :            :     {
     129                 :          0 :       gfc_error ("KIND parameter of %s at %L must be an initialization "
     130                 :            :                  "expression", name, &k->where);
     131                 :          0 :       return -1;
     132                 :            :     }
     133                 :            : 
     134                 :      20830 :   if (gfc_extract_int (k, &kind)
     135                 :      20830 :       || gfc_validate_kind (type, kind, true) < 0)
     136                 :            :     {
     137                 :          0 :       gfc_error ("Invalid KIND parameter of %s at %L", name, &k->where);
     138                 :          0 :       return -1;
     139                 :            :     }
     140                 :            : 
     141                 :      20830 :   return kind;
     142                 :            : }
     143                 :            : 
     144                 :            : 
     145                 :            : /* Converts an mpz_t signed variable into an unsigned one, assuming
     146                 :            :    two's complement representations and a binary width of bitsize.
     147                 :            :    The conversion is a no-op unless x is negative; otherwise, it can
     148                 :            :    be accomplished by masking out the high bits.  */
     149                 :            : 
     150                 :            : static void
     151                 :       3107 : convert_mpz_to_unsigned (mpz_t x, int bitsize)
     152                 :            : {
     153                 :       3107 :   mpz_t mask;
     154                 :            : 
     155                 :       3107 :   if (mpz_sgn (x) < 0)
     156                 :            :     {
     157                 :            :       /* Confirm that no bits above the signed range are unset if we
     158                 :            :          are doing range checking.  */
     159                 :        720 :       if (flag_range_check != 0)
     160                 :        720 :         gcc_assert (mpz_scan0 (x, bitsize-1) == ULONG_MAX);
     161                 :            : 
     162                 :        720 :       mpz_init_set_ui (mask, 1);
     163                 :        720 :       mpz_mul_2exp (mask, mask, bitsize);
     164                 :        720 :       mpz_sub_ui (mask, mask, 1);
     165                 :            : 
     166                 :        720 :       mpz_and (x, x, mask);
     167                 :            : 
     168                 :        720 :       mpz_clear (mask);
     169                 :            :     }
     170                 :            :   else
     171                 :            :     {
     172                 :            :       /* Confirm that no bits above the signed range are set if we
     173                 :            :          are doing range checking.  */
     174                 :       2387 :       if (flag_range_check != 0)
     175                 :       2327 :         gcc_assert (mpz_scan1 (x, bitsize-1) == ULONG_MAX);
     176                 :            :     }
     177                 :       3107 : }
     178                 :            : 
     179                 :            : 
     180                 :            : /* Converts an mpz_t unsigned variable into a signed one, assuming
     181                 :            :    two's complement representations and a binary width of bitsize.
     182                 :            :    If the bitsize-1 bit is set, this is taken as a sign bit and
     183                 :            :    the number is converted to the corresponding negative number.  */
     184                 :            : 
     185                 :            : void
     186                 :       8856 : gfc_convert_mpz_to_signed (mpz_t x, int bitsize)
     187                 :            : {
     188                 :       8856 :   mpz_t mask;
     189                 :            : 
     190                 :            :   /* Confirm that no bits above the unsigned range are set if we are
     191                 :            :      doing range checking.  */
     192                 :       8856 :   if (flag_range_check != 0)
     193                 :       8714 :     gcc_assert (mpz_scan1 (x, bitsize) == ULONG_MAX);
     194                 :            : 
     195                 :       8856 :   if (mpz_tstbit (x, bitsize - 1) == 1)
     196                 :            :     {
     197                 :       1787 :       mpz_init_set_ui (mask, 1);
     198                 :       1787 :       mpz_mul_2exp (mask, mask, bitsize);
     199                 :       1787 :       mpz_sub_ui (mask, mask, 1);
     200                 :            : 
     201                 :            :       /* We negate the number by hand, zeroing the high bits, that is
     202                 :            :          make it the corresponding positive number, and then have it
     203                 :            :          negated by GMP, giving the correct representation of the
     204                 :            :          negative number.  */
     205                 :       1787 :       mpz_com (x, x);
     206                 :       1787 :       mpz_add_ui (x, x, 1);
     207                 :       1787 :       mpz_and (x, x, mask);
     208                 :            : 
     209                 :       1787 :       mpz_neg (x, x);
     210                 :            : 
     211                 :       1787 :       mpz_clear (mask);
     212                 :            :     }
     213                 :       8856 : }
     214                 :            : 
     215                 :            : 
     216                 :            : /* Test that the expression is a constant array, simplifying if
     217                 :            :    we are dealing with a parameter array.  */
     218                 :            : 
     219                 :            : static bool
     220                 :      71916 : is_constant_array_expr (gfc_expr *e)
     221                 :            : {
     222                 :      71916 :   gfc_constructor *c;
     223                 :            : 
     224                 :      71916 :   if (e == NULL)
     225                 :            :     return true;
     226                 :            : 
     227                 :      65244 :   if (e->expr_type == EXPR_VARIABLE && e->rank > 0
     228                 :      28177 :       && e->symtree->n.sym->attr.flavor == FL_PARAMETER)
     229                 :        918 :     gfc_simplify_expr (e, 1);
     230                 :            : 
     231                 :      65244 :   if (e->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (e))
     232                 :      54566 :     return false;
     233                 :            : 
     234                 :      10678 :   for (c = gfc_constructor_first (e->value.constructor);
     235                 :     262202 :        c; c = gfc_constructor_next (c))
     236                 :     125813 :     if (c->expr->expr_type != EXPR_CONSTANT
     237                 :        445 :           && c->expr->expr_type != EXPR_STRUCTURE)
     238                 :            :       return false;
     239                 :            : 
     240                 :            :   return true;
     241                 :            : }
     242                 :            : 
     243                 :            : /* Test for a size zero array.  */
     244                 :            : bool
     245                 :      43901 : gfc_is_size_zero_array (gfc_expr *array)
     246                 :            : {
     247                 :            : 
     248                 :      43901 :   if (array->rank == 0)
     249                 :            :     return false;
     250                 :            : 
     251                 :      41807 :   if (array->expr_type == EXPR_VARIABLE && array->rank > 0
     252                 :      13481 :       && array->symtree->n.sym->attr.flavor == FL_PARAMETER
     253                 :       3945 :       && array->shape != NULL)
     254                 :            :     {
     255                 :       8627 :       for (int i = 0; i < array->rank; i++)
     256                 :       5400 :         if (mpz_cmp_si (array->shape[i], 0) <= 0)
     257                 :            :           return true;
     258                 :            : 
     259                 :            :       return false;
     260                 :            :     }
     261                 :            : 
     262                 :      37986 :   if (array->expr_type == EXPR_ARRAY)
     263                 :       2617 :     return array->value.constructor == NULL;
     264                 :            : 
     265                 :            :   return false;
     266                 :            : }
     267                 :            : 
     268                 :            : 
     269                 :            : /* Initialize a transformational result expression with a given value.  */
     270                 :            : 
     271                 :            : static void
     272                 :       2906 : init_result_expr (gfc_expr *e, int init, gfc_expr *array)
     273                 :            : {
     274                 :       2906 :   if (e && e->expr_type == EXPR_ARRAY)
     275                 :            :     {
     276                 :        127 :       gfc_constructor *ctor = gfc_constructor_first (e->value.constructor);
     277                 :        476 :       while (ctor)
     278                 :            :         {
     279                 :        349 :           init_result_expr (ctor->expr, init, array);
     280                 :        349 :           ctor = gfc_constructor_next (ctor);
     281                 :            :         }
     282                 :            :     }
     283                 :       2779 :   else if (e && e->expr_type == EXPR_CONSTANT)
     284                 :            :     {
     285                 :       2779 :       int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
     286                 :       2779 :       HOST_WIDE_INT length;
     287                 :       2779 :       gfc_char_t *string;
     288                 :            : 
     289                 :       2779 :       switch (e->ts.type)
     290                 :            :         {
     291                 :       1638 :           case BT_LOGICAL:
     292                 :       1638 :             e->value.logical = (init ? 1 : 0);
     293                 :       1638 :             break;
     294                 :            : 
     295                 :        773 :           case BT_INTEGER:
     296                 :        773 :             if (init == INT_MIN)
     297                 :        119 :               mpz_set (e->value.integer, gfc_integer_kinds[i].min_int);
     298                 :        654 :             else if (init == INT_MAX)
     299                 :        133 :               mpz_set (e->value.integer, gfc_integer_kinds[i].huge);
     300                 :            :             else
     301                 :        521 :               mpz_set_si (e->value.integer, init);
     302                 :            :             break;
     303                 :            : 
     304                 :        276 :           case BT_REAL:
     305                 :        276 :             if (init == INT_MIN)
     306                 :            :               {
     307                 :         26 :                 mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
     308                 :         26 :                 mpfr_neg (e->value.real, e->value.real, GFC_RND_MODE);
     309                 :            :               }
     310                 :        250 :             else if (init == INT_MAX)
     311                 :         26 :               mpfr_set (e->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
     312                 :            :             else
     313                 :        224 :               mpfr_set_si (e->value.real, init, GFC_RND_MODE);
     314                 :            :             break;
     315                 :            : 
     316                 :         48 :           case BT_COMPLEX:
     317                 :         48 :             mpc_set_si (e->value.complex, init, GFC_MPC_RND_MODE);
     318                 :         48 :             break;
     319                 :            : 
     320                 :         44 :           case BT_CHARACTER:
     321                 :         44 :             if (init == INT_MIN)
     322                 :            :               {
     323                 :         22 :                 gfc_expr *len = gfc_simplify_len (array, NULL);
     324                 :         22 :                 gfc_extract_hwi (len, &length);
     325                 :         22 :                 string = gfc_get_wide_string (length + 1);
     326                 :         22 :                 gfc_wide_memset (string, 0, length);
     327                 :            :               }
     328                 :         22 :             else if (init == INT_MAX)
     329                 :            :               {
     330                 :         22 :                 gfc_expr *len = gfc_simplify_len (array, NULL);
     331                 :         22 :                 gfc_extract_hwi (len, &length);
     332                 :         22 :                 string = gfc_get_wide_string (length + 1);
     333                 :         22 :                 gfc_wide_memset (string, 255, length);
     334                 :            :               }
     335                 :            :             else
     336                 :            :               {
     337                 :          0 :                 length = 0;
     338                 :          0 :                 string = gfc_get_wide_string (1);
     339                 :            :               }
     340                 :            : 
     341                 :         44 :             string[length] = '\0';
     342                 :         44 :             e->value.character.length = length;
     343                 :         44 :             e->value.character.string = string;
     344                 :         44 :             break;
     345                 :            : 
     346                 :          0 :           default:
     347                 :          0 :             gcc_unreachable();
     348                 :       2779 :         }
     349                 :            :     }
     350                 :            :   else
     351                 :          0 :     gcc_unreachable();
     352                 :       2906 : }
     353                 :            : 
     354                 :            : 
     355                 :            : /* Helper function for gfc_simplify_dot_product() and gfc_simplify_matmul;
     356                 :            :    if conj_a is true, the matrix_a is complex conjugated.  */
     357                 :            : 
     358                 :            : static gfc_expr *
     359                 :        338 : compute_dot_product (gfc_expr *matrix_a, int stride_a, int offset_a,
     360                 :            :                      gfc_expr *matrix_b, int stride_b, int offset_b,
     361                 :            :                      bool conj_a)
     362                 :            : {
     363                 :        338 :   gfc_expr *result, *a, *b, *c;
     364                 :            : 
     365                 :            :   /* Set result to an INTEGER(1) 0 for numeric types and .false. for
     366                 :            :      LOGICAL.  Mixed-mode math in the loop will promote result to the
     367                 :            :      correct type and kind.  */
     368                 :        338 :   if (matrix_a->ts.type == BT_LOGICAL)
     369                 :          0 :     result = gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
     370                 :            :   else
     371                 :        338 :     result = gfc_get_int_expr (1, NULL, 0);
     372                 :        338 :   result->where = matrix_a->where;
     373                 :            : 
     374                 :        338 :   a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
     375                 :        338 :   b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
     376                 :       1088 :   while (a && b)
     377                 :            :     {
     378                 :            :       /* Copying of expressions is required as operands are free'd
     379                 :            :          by the gfc_arith routines.  */
     380                 :        750 :       switch (result->ts.type)
     381                 :            :         {
     382                 :          0 :           case BT_LOGICAL:
     383                 :          0 :             result = gfc_or (result,
     384                 :            :                              gfc_and (gfc_copy_expr (a),
     385                 :            :                                       gfc_copy_expr (b)));
     386                 :          0 :             break;
     387                 :            : 
     388                 :        750 :           case BT_INTEGER:
     389                 :        750 :           case BT_REAL:
     390                 :        750 :           case BT_COMPLEX:
     391                 :        750 :             if (conj_a && a->ts.type == BT_COMPLEX)
     392                 :          2 :               c = gfc_simplify_conjg (a);
     393                 :            :             else
     394                 :        748 :               c = gfc_copy_expr (a);
     395                 :        750 :             result = gfc_add (result, gfc_multiply (c, gfc_copy_expr (b)));
     396                 :        750 :             break;
     397                 :            : 
     398                 :          0 :           default:
     399                 :          0 :             gcc_unreachable();
     400                 :            :         }
     401                 :            : 
     402                 :        750 :       offset_a += stride_a;
     403                 :        750 :       a = gfc_constructor_lookup_expr (matrix_a->value.constructor, offset_a);
     404                 :            : 
     405                 :        750 :       offset_b += stride_b;
     406                 :        750 :       b = gfc_constructor_lookup_expr (matrix_b->value.constructor, offset_b);
     407                 :            :     }
     408                 :            : 
     409                 :        338 :   return result;
     410                 :            : }
     411                 :            : 
     412                 :            : 
     413                 :            : /* Build a result expression for transformational intrinsics,
     414                 :            :    depending on DIM.  */
     415                 :            : 
     416                 :            : static gfc_expr *
     417                 :       2407 : transformational_result (gfc_expr *array, gfc_expr *dim, bt type,
     418                 :            :                          int kind, locus* where)
     419                 :            : {
     420                 :       2407 :   gfc_expr *result;
     421                 :       2407 :   int i, nelem;
     422                 :            : 
     423                 :       2407 :   if (!dim || array->rank == 1)
     424                 :       2280 :     return gfc_get_constant_expr (type, kind, where);
     425                 :            : 
     426                 :        127 :   result = gfc_get_array_expr (type, kind, where);
     427                 :        127 :   result->shape = gfc_copy_shape_excluding (array->shape, array->rank, dim);
     428                 :        127 :   result->rank = array->rank - 1;
     429                 :            : 
     430                 :            :   /* gfc_array_size() would count the number of elements in the constructor,
     431                 :            :      we have not built those yet.  */
     432                 :        127 :   nelem = 1;
     433                 :        254 :   for  (i = 0; i < result->rank; ++i)
     434                 :        132 :     nelem *= mpz_get_ui (result->shape[i]);
     435                 :            : 
     436                 :        476 :   for (i = 0; i < nelem; ++i)
     437                 :            :     {
     438                 :        349 :       gfc_constructor_append_expr (&result->value.constructor,
     439                 :            :                                    gfc_get_constant_expr (type, kind, where),
     440                 :            :                                    NULL);
     441                 :            :     }
     442                 :            : 
     443                 :            :   return result;
     444                 :            : }
     445                 :            : 
     446                 :            : 
     447                 :            : typedef gfc_expr* (*transformational_op)(gfc_expr*, gfc_expr*);
     448                 :            : 
     449                 :            : /* Wrapper function, implements 'op1 += 1'. Only called if MASK
     450                 :            :    of COUNT intrinsic is .TRUE..
     451                 :            : 
     452                 :            :    Interface and implementation mimics arith functions as
     453                 :            :    gfc_add, gfc_multiply, etc.  */
     454                 :            : 
     455                 :            : static gfc_expr *
     456                 :        108 : gfc_count (gfc_expr *op1, gfc_expr *op2)
     457                 :            : {
     458                 :        108 :   gfc_expr *result;
     459                 :            : 
     460                 :        108 :   gcc_assert (op1->ts.type == BT_INTEGER);
     461                 :        108 :   gcc_assert (op2->ts.type == BT_LOGICAL);
     462                 :        108 :   gcc_assert (op2->value.logical);
     463                 :            : 
     464                 :        108 :   result = gfc_copy_expr (op1);
     465                 :        108 :   mpz_add_ui (result->value.integer, result->value.integer, 1);
     466                 :            : 
     467                 :        108 :   gfc_free_expr (op1);
     468                 :        108 :   gfc_free_expr (op2);
     469                 :        108 :   return result;
     470                 :            : }
     471                 :            : 
     472                 :            : 
     473                 :            : /* Transforms an ARRAY with operation OP, according to MASK, to a
     474                 :            :    scalar RESULT. E.g. called if
     475                 :            : 
     476                 :            :      REAL, PARAMETER :: array(n, m) = ...
     477                 :            :      REAL, PARAMETER :: s = SUM(array)
     478                 :            : 
     479                 :            :   where OP == gfc_add().  */
     480                 :            : 
     481                 :            : static gfc_expr *
     482                 :       1943 : simplify_transformation_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
     483                 :            :                                    transformational_op op)
     484                 :            : {
     485                 :       1943 :   gfc_expr *a, *m;
     486                 :       1943 :   gfc_constructor *array_ctor, *mask_ctor;
     487                 :            : 
     488                 :            :   /* Shortcut for constant .FALSE. MASK.  */
     489                 :       1943 :   if (mask
     490                 :         98 :       && mask->expr_type == EXPR_CONSTANT
     491                 :         24 :       && !mask->value.logical)
     492                 :            :     return result;
     493                 :            : 
     494                 :       1919 :   array_ctor = gfc_constructor_first (array->value.constructor);
     495                 :       1919 :   mask_ctor = NULL;
     496                 :       1919 :   if (mask && mask->expr_type == EXPR_ARRAY)
     497                 :         74 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
     498                 :            : 
     499                 :      67915 :   while (array_ctor)
     500                 :            :     {
     501                 :      65996 :       a = array_ctor->expr;
     502                 :      65996 :       array_ctor = gfc_constructor_next (array_ctor);
     503                 :            : 
     504                 :            :       /* A constant MASK equals .TRUE. here and can be ignored.  */
     505                 :      65996 :       if (mask_ctor)
     506                 :            :         {
     507                 :        430 :           m = mask_ctor->expr;
     508                 :        430 :           mask_ctor = gfc_constructor_next (mask_ctor);
     509                 :        430 :           if (!m->value.logical)
     510                 :        304 :             continue;
     511                 :            :         }
     512                 :            : 
     513                 :      65692 :       result = op (result, gfc_copy_expr (a));
     514                 :      65692 :       if (!result)
     515                 :            :         return result;
     516                 :            :     }
     517                 :            : 
     518                 :            :   return result;
     519                 :            : }
     520                 :            : 
     521                 :            : /* Transforms an ARRAY with operation OP, according to MASK, to an
     522                 :            :    array RESULT. E.g. called if
     523                 :            : 
     524                 :            :      REAL, PARAMETER :: array(n, m) = ...
     525                 :            :      REAL, PARAMETER :: s(n) = PROD(array, DIM=1)
     526                 :            : 
     527                 :            :    where OP == gfc_multiply().
     528                 :            :    The result might be post processed using post_op.  */
     529                 :            : 
     530                 :            : static gfc_expr *
     531                 :         88 : simplify_transformation_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *dim,
     532                 :            :                                   gfc_expr *mask, transformational_op op,
     533                 :            :                                   transformational_op post_op)
     534                 :            : {
     535                 :         88 :   mpz_t size;
     536                 :         88 :   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
     537                 :         88 :   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
     538                 :         88 :   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
     539                 :            : 
     540                 :         88 :   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
     541                 :            :       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
     542                 :            :       tmpstride[GFC_MAX_DIMENSIONS];
     543                 :            : 
     544                 :            :   /* Shortcut for constant .FALSE. MASK.  */
     545                 :         88 :   if (mask
     546                 :         16 :       && mask->expr_type == EXPR_CONSTANT
     547                 :          0 :       && !mask->value.logical)
     548                 :            :     return result;
     549                 :            : 
     550                 :            :   /* Build an indexed table for array element expressions to minimize
     551                 :            :      linked-list traversal. Masked elements are set to NULL.  */
     552                 :         88 :   gfc_array_size (array, &size);
     553                 :         88 :   arraysize = mpz_get_ui (size);
     554                 :         88 :   mpz_clear (size);
     555                 :            : 
     556                 :         88 :   arrayvec = XCNEWVEC (gfc_expr*, arraysize);
     557                 :            : 
     558                 :         88 :   array_ctor = gfc_constructor_first (array->value.constructor);
     559                 :         88 :   mask_ctor = NULL;
     560                 :         88 :   if (mask && mask->expr_type == EXPR_ARRAY)
     561                 :         16 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
     562                 :            : 
     563                 :        748 :   for (i = 0; i < arraysize; ++i)
     564                 :            :     {
     565                 :        660 :       arrayvec[i] = array_ctor->expr;
     566                 :        660 :       array_ctor = gfc_constructor_next (array_ctor);
     567                 :            : 
     568                 :        660 :       if (mask_ctor)
     569                 :            :         {
     570                 :        156 :           if (!mask_ctor->expr->value.logical)
     571                 :         83 :             arrayvec[i] = NULL;
     572                 :            : 
     573                 :        156 :           mask_ctor = gfc_constructor_next (mask_ctor);
     574                 :            :         }
     575                 :            :     }
     576                 :            : 
     577                 :            :   /* Same for the result expression.  */
     578                 :         88 :   gfc_array_size (result, &size);
     579                 :         88 :   resultsize = mpz_get_ui (size);
     580                 :         88 :   mpz_clear (size);
     581                 :            : 
     582                 :         88 :   resultvec = XCNEWVEC (gfc_expr*, resultsize);
     583                 :         88 :   result_ctor = gfc_constructor_first (result->value.constructor);
     584                 :        336 :   for (i = 0; i < resultsize; ++i)
     585                 :            :     {
     586                 :        248 :       resultvec[i] = result_ctor->expr;
     587                 :        248 :       result_ctor = gfc_constructor_next (result_ctor);
     588                 :            :     }
     589                 :            : 
     590                 :         88 :   gfc_extract_int (dim, &dim_index);
     591                 :         88 :   dim_index -= 1;               /* zero-base index */
     592                 :         88 :   dim_extent = 0;
     593                 :         88 :   dim_stride = 0;
     594                 :            : 
     595                 :        264 :   for (i = 0, n = 0; i < array->rank; ++i)
     596                 :            :     {
     597                 :        176 :       count[i] = 0;
     598                 :        176 :       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
     599                 :        176 :       if (i == dim_index)
     600                 :            :         {
     601                 :         88 :           dim_extent = mpz_get_si (array->shape[i]);
     602                 :         88 :           dim_stride = tmpstride[i];
     603                 :         88 :           continue;
     604                 :            :         }
     605                 :            : 
     606                 :         88 :       extent[n] = mpz_get_si (array->shape[i]);
     607                 :         88 :       sstride[n] = tmpstride[i];
     608                 :         88 :       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
     609                 :         88 :       n += 1;
     610                 :            :     }
     611                 :            : 
     612                 :         88 :   done = resultsize <= 0;
     613                 :         88 :   base = arrayvec;
     614                 :         88 :   dest = resultvec;
     615                 :        336 :   while (!done)
     616                 :            :     {
     617                 :        908 :       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
     618                 :        660 :         if (*src)
     619                 :        577 :           *dest = op (*dest, gfc_copy_expr (*src));
     620                 :            : 
     621                 :        248 :       if (post_op)
     622                 :          0 :         *dest = post_op (*dest, *dest);
     623                 :            : 
     624                 :        248 :       count[0]++;
     625                 :        248 :       base += sstride[0];
     626                 :        248 :       dest += dstride[0];
     627                 :            : 
     628                 :        248 :       n = 0;
     629                 :        336 :       while (!done && count[n] == extent[n])
     630                 :            :         {
     631                 :         88 :           count[n] = 0;
     632                 :         88 :           base -= sstride[n] * extent[n];
     633                 :         88 :           dest -= dstride[n] * extent[n];
     634                 :            : 
     635                 :         88 :           n++;
     636                 :         88 :           if (n < result->rank)
     637                 :            :             {
     638                 :            :               /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
     639                 :            :                  times, we'd warn for the last iteration, because the
     640                 :            :                  array index will have already been incremented to the
     641                 :            :                  array sizes, and we can't tell that this must make
     642                 :            :                  the test against result->rank false, because ranks
     643                 :            :                  must not exceed GFC_MAX_DIMENSIONS.  */
     644                 :          0 :               GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
     645                 :          0 :               count[n]++;
     646                 :          0 :               base += sstride[n];
     647                 :          0 :               dest += dstride[n];
     648                 :          0 :               GCC_DIAGNOSTIC_POP
     649                 :            :             }
     650                 :            :           else
     651                 :            :             done = true;
     652                 :            :        }
     653                 :            :     }
     654                 :            : 
     655                 :            :   /* Place updated expression in result constructor.  */
     656                 :         88 :   result_ctor = gfc_constructor_first (result->value.constructor);
     657                 :        336 :   for (i = 0; i < resultsize; ++i)
     658                 :            :     {
     659                 :        248 :       result_ctor->expr = resultvec[i];
     660                 :        248 :       result_ctor = gfc_constructor_next (result_ctor);
     661                 :            :     }
     662                 :            : 
     663                 :         88 :   free (arrayvec);
     664                 :         88 :   free (resultvec);
     665                 :         88 :   return result;
     666                 :            : }
     667                 :            : 
     668                 :            : 
     669                 :            : static gfc_expr *
     670                 :      37533 : simplify_transformation (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
     671                 :            :                          int init_val, transformational_op op)
     672                 :            : {
     673                 :      37533 :   gfc_expr *result;
     674                 :      37533 :   bool size_zero;
     675                 :            : 
     676                 :      37533 :   size_zero = gfc_is_size_zero_array (array);
     677                 :            : 
     678                 :      72708 :   if (!(is_constant_array_expr (array) || size_zero)
     679                 :      37533 :       || !gfc_is_constant_expr (dim))
     680                 :      35175 :     return NULL;
     681                 :            : 
     682                 :       2358 :   if (mask
     683                 :        242 :       && !is_constant_array_expr (mask)
     684                 :       2540 :       && mask->expr_type != EXPR_CONSTANT)
     685                 :            :     return NULL;
     686                 :            : 
     687                 :       2200 :   result = transformational_result (array, dim, array->ts.type,
     688                 :            :                                     array->ts.kind, &array->where);
     689                 :       2200 :   init_result_expr (result, init_val, array);
     690                 :            : 
     691                 :       2200 :   if (size_zero)
     692                 :            :     return result;
     693                 :            : 
     694                 :       1965 :   return !dim || array->rank == 1 ?
     695                 :       1883 :     simplify_transformation_to_scalar (result, array, mask, op) :
     696                 :         82 :     simplify_transformation_to_array (result, array, dim, mask, op, NULL);
     697                 :            : }
     698                 :            : 
     699                 :            : 
     700                 :            : /********************** Simplification functions *****************************/
     701                 :            : 
     702                 :            : gfc_expr *
     703                 :      15381 : gfc_simplify_abs (gfc_expr *e)
     704                 :            : {
     705                 :      15381 :   gfc_expr *result;
     706                 :            : 
     707                 :      15381 :   if (e->expr_type != EXPR_CONSTANT)
     708                 :            :     return NULL;
     709                 :            : 
     710                 :        910 :   switch (e->ts.type)
     711                 :            :     {
     712                 :         36 :       case BT_INTEGER:
     713                 :         36 :         result = gfc_get_constant_expr (BT_INTEGER, e->ts.kind, &e->where);
     714                 :         36 :         mpz_abs (result->value.integer, e->value.integer);
     715                 :         36 :         return range_check (result, "IABS");
     716                 :            : 
     717                 :        712 :       case BT_REAL:
     718                 :        712 :         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
     719                 :        712 :         mpfr_abs (result->value.real, e->value.real, GFC_RND_MODE);
     720                 :        712 :         return range_check (result, "ABS");
     721                 :            : 
     722                 :        162 :       case BT_COMPLEX:
     723                 :        162 :         gfc_set_model_kind (e->ts.kind);
     724                 :        162 :         result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
     725                 :        162 :         mpc_abs (result->value.real, e->value.complex, GFC_RND_MODE);
     726                 :        162 :         return range_check (result, "CABS");
     727                 :            : 
     728                 :          0 :       default:
     729                 :          0 :         gfc_internal_error ("gfc_simplify_abs(): Bad type");
     730                 :            :     }
     731                 :            : }
     732                 :            : 
     733                 :            : 
     734                 :            : static gfc_expr *
     735                 :      13627 : simplify_achar_char (gfc_expr *e, gfc_expr *k, const char *name, bool ascii)
     736                 :            : {
     737                 :      13627 :   gfc_expr *result;
     738                 :      13627 :   int kind;
     739                 :      13627 :   bool too_large = false;
     740                 :            : 
     741                 :      13627 :   if (e->expr_type != EXPR_CONSTANT)
     742                 :            :     return NULL;
     743                 :            : 
     744                 :       9462 :   kind = get_kind (BT_CHARACTER, k, name, gfc_default_character_kind);
     745                 :       9462 :   if (kind == -1)
     746                 :            :     return &gfc_bad_expr;
     747                 :            : 
     748                 :       9462 :   if (mpz_cmp_si (e->value.integer, 0) < 0)
     749                 :            :     {
     750                 :          8 :       gfc_error ("Argument of %s function at %L is negative", name,
     751                 :            :                  &e->where);
     752                 :          8 :       return &gfc_bad_expr;
     753                 :            :     }
     754                 :            : 
     755                 :       9454 :   if (ascii && warn_surprising && mpz_cmp_si (e->value.integer, 127) > 0)
     756                 :          1 :     gfc_warning (OPT_Wsurprising,
     757                 :            :                  "Argument of %s function at %L outside of range [0,127]",
     758                 :            :                  name, &e->where);
     759                 :            : 
     760                 :       9454 :   if (kind == 1 && mpz_cmp_si (e->value.integer, 255) > 0)
     761                 :            :     too_large = true;
     762                 :       9445 :   else if (kind == 4)
     763                 :            :     {
     764                 :         77 :       mpz_t t;
     765                 :         77 :       mpz_init_set_ui (t, 2);
     766                 :         77 :       mpz_pow_ui (t, t, 32);
     767                 :         77 :       mpz_sub_ui (t, t, 1);
     768                 :         77 :       if (mpz_cmp (e->value.integer, t) > 0)
     769                 :          2 :         too_large = true;
     770                 :         77 :       mpz_clear (t);
     771                 :            :     }
     772                 :            : 
     773                 :         77 :   if (too_large)
     774                 :            :     {
     775                 :         11 :       gfc_error ("Argument of %s function at %L is too large for the "
     776                 :            :                  "collating sequence of kind %d", name, &e->where, kind);
     777                 :         11 :       return &gfc_bad_expr;
     778                 :            :     }
     779                 :            : 
     780                 :       9443 :   result = gfc_get_character_expr (kind, &e->where, NULL, 1);
     781                 :       9443 :   result->value.character.string[0] = mpz_get_ui (e->value.integer);
     782                 :            : 
     783                 :       9443 :   return result;
     784                 :            : }
     785                 :            : 
     786                 :            : 
     787                 :            : 
     788                 :            : /* We use the processor's collating sequence, because all
     789                 :            :    systems that gfortran currently works on are ASCII.  */
     790                 :            : 
     791                 :            : gfc_expr *
     792                 :       9133 : gfc_simplify_achar (gfc_expr *e, gfc_expr *k)
     793                 :            : {
     794                 :       9133 :   return simplify_achar_char (e, k, "ACHAR", true);
     795                 :            : }
     796                 :            : 
     797                 :            : 
     798                 :            : gfc_expr *
     799                 :        302 : gfc_simplify_acos (gfc_expr *x)
     800                 :            : {
     801                 :        302 :   gfc_expr *result;
     802                 :            : 
     803                 :        302 :   if (x->expr_type != EXPR_CONSTANT)
     804                 :            :     return NULL;
     805                 :            : 
     806                 :         94 :   switch (x->ts.type)
     807                 :            :     {
     808                 :         90 :       case BT_REAL:
     809                 :         90 :         if (mpfr_cmp_si (x->value.real, 1) > 0
     810                 :         90 :             || mpfr_cmp_si (x->value.real, -1) < 0)
     811                 :            :           {
     812                 :          0 :             gfc_error ("Argument of ACOS at %L must be between -1 and 1",
     813                 :            :                        &x->where);
     814                 :          0 :             return &gfc_bad_expr;
     815                 :            :           }
     816                 :         90 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
     817                 :         90 :         mpfr_acos (result->value.real, x->value.real, GFC_RND_MODE);
     818                 :         90 :         break;
     819                 :            : 
     820                 :          4 :       case BT_COMPLEX:
     821                 :          4 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
     822                 :          4 :         mpc_acos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
     823                 :          4 :         break;
     824                 :            : 
     825                 :          0 :       default:
     826                 :          0 :         gfc_internal_error ("in gfc_simplify_acos(): Bad type");
     827                 :            :     }
     828                 :            : 
     829                 :         94 :   return range_check (result, "ACOS");
     830                 :            : }
     831                 :            : 
     832                 :            : gfc_expr *
     833                 :        150 : gfc_simplify_acosh (gfc_expr *x)
     834                 :            : {
     835                 :        150 :   gfc_expr *result;
     836                 :            : 
     837                 :        150 :   if (x->expr_type != EXPR_CONSTANT)
     838                 :            :     return NULL;
     839                 :            : 
     840                 :         34 :   switch (x->ts.type)
     841                 :            :     {
     842                 :         30 :       case BT_REAL:
     843                 :         30 :         if (mpfr_cmp_si (x->value.real, 1) < 0)
     844                 :            :           {
     845                 :          0 :             gfc_error ("Argument of ACOSH at %L must not be less than 1",
     846                 :            :                        &x->where);
     847                 :          0 :             return &gfc_bad_expr;
     848                 :            :           }
     849                 :            : 
     850                 :         30 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
     851                 :         30 :         mpfr_acosh (result->value.real, x->value.real, GFC_RND_MODE);
     852                 :         30 :         break;
     853                 :            : 
     854                 :          4 :       case BT_COMPLEX:
     855                 :          4 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
     856                 :          4 :         mpc_acosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
     857                 :          4 :         break;
     858                 :            : 
     859                 :          0 :       default:
     860                 :          0 :         gfc_internal_error ("in gfc_simplify_acosh(): Bad type");
     861                 :            :     }
     862                 :            : 
     863                 :         34 :   return range_check (result, "ACOSH");
     864                 :            : }
     865                 :            : 
     866                 :            : gfc_expr *
     867                 :        715 : gfc_simplify_adjustl (gfc_expr *e)
     868                 :            : {
     869                 :        715 :   gfc_expr *result;
     870                 :        715 :   int count, i, len;
     871                 :        715 :   gfc_char_t ch;
     872                 :            : 
     873                 :        715 :   if (e->expr_type != EXPR_CONSTANT)
     874                 :            :     return NULL;
     875                 :            : 
     876                 :         29 :   len = e->value.character.length;
     877                 :            : 
     878                 :         85 :   for (count = 0, i = 0; i < len; ++i)
     879                 :            :     {
     880                 :         85 :       ch = e->value.character.string[i];
     881                 :         85 :       if (ch != ' ')
     882                 :            :         break;
     883                 :         56 :       ++count;
     884                 :            :     }
     885                 :            : 
     886                 :         29 :   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
     887                 :        441 :   for (i = 0; i < len - count; ++i)
     888                 :        412 :     result->value.character.string[i] = e->value.character.string[count + i];
     889                 :            : 
     890                 :            :   return result;
     891                 :            : }
     892                 :            : 
     893                 :            : 
     894                 :            : gfc_expr *
     895                 :        209 : gfc_simplify_adjustr (gfc_expr *e)
     896                 :            : {
     897                 :        209 :   gfc_expr *result;
     898                 :        209 :   int count, i, len;
     899                 :        209 :   gfc_char_t ch;
     900                 :            : 
     901                 :        209 :   if (e->expr_type != EXPR_CONSTANT)
     902                 :            :     return NULL;
     903                 :            : 
     904                 :         20 :   len = e->value.character.length;
     905                 :            : 
     906                 :        168 :   for (count = 0, i = len - 1; i >= 0; --i)
     907                 :            :     {
     908                 :        168 :       ch = e->value.character.string[i];
     909                 :        168 :       if (ch != ' ')
     910                 :            :         break;
     911                 :        148 :       ++count;
     912                 :            :     }
     913                 :            : 
     914                 :         20 :   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, len);
     915                 :        168 :   for (i = 0; i < count; ++i)
     916                 :        148 :     result->value.character.string[i] = ' ';
     917                 :            : 
     918                 :        250 :   for (i = count; i < len; ++i)
     919                 :        230 :     result->value.character.string[i] = e->value.character.string[i - count];
     920                 :            : 
     921                 :            :   return result;
     922                 :            : }
     923                 :            : 
     924                 :            : 
     925                 :            : gfc_expr *
     926                 :       1190 : gfc_simplify_aimag (gfc_expr *e)
     927                 :            : {
     928                 :       1190 :   gfc_expr *result;
     929                 :            : 
     930                 :       1190 :   if (e->expr_type != EXPR_CONSTANT)
     931                 :            :     return NULL;
     932                 :            : 
     933                 :        144 :   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
     934                 :        144 :   mpfr_set (result->value.real, mpc_imagref (e->value.complex), GFC_RND_MODE);
     935                 :            : 
     936                 :        144 :   return range_check (result, "AIMAG");
     937                 :            : }
     938                 :            : 
     939                 :            : 
     940                 :            : gfc_expr *
     941                 :        465 : gfc_simplify_aint (gfc_expr *e, gfc_expr *k)
     942                 :            : {
     943                 :        465 :   gfc_expr *rtrunc, *result;
     944                 :        465 :   int kind;
     945                 :            : 
     946                 :        465 :   kind = get_kind (BT_REAL, k, "AINT", e->ts.kind);
     947                 :        465 :   if (kind == -1)
     948                 :            :     return &gfc_bad_expr;
     949                 :            : 
     950                 :        465 :   if (e->expr_type != EXPR_CONSTANT)
     951                 :            :     return NULL;
     952                 :            : 
     953                 :         29 :   rtrunc = gfc_copy_expr (e);
     954                 :         29 :   mpfr_trunc (rtrunc->value.real, e->value.real);
     955                 :            : 
     956                 :         29 :   result = gfc_real2real (rtrunc, kind);
     957                 :            : 
     958                 :         29 :   gfc_free_expr (rtrunc);
     959                 :            : 
     960                 :         29 :   return range_check (result, "AINT");
     961                 :            : }
     962                 :            : 
     963                 :            : 
     964                 :            : gfc_expr *
     965                 :       1113 : gfc_simplify_all (gfc_expr *mask, gfc_expr *dim)
     966                 :            : {
     967                 :       1113 :   return simplify_transformation (mask, dim, NULL, true, gfc_and);
     968                 :            : }
     969                 :            : 
     970                 :            : 
     971                 :            : gfc_expr *
     972                 :         42 : gfc_simplify_dint (gfc_expr *e)
     973                 :            : {
     974                 :         42 :   gfc_expr *rtrunc, *result;
     975                 :            : 
     976                 :         42 :   if (e->expr_type != EXPR_CONSTANT)
     977                 :            :     return NULL;
     978                 :            : 
     979                 :         14 :   rtrunc = gfc_copy_expr (e);
     980                 :         14 :   mpfr_trunc (rtrunc->value.real, e->value.real);
     981                 :            : 
     982                 :         14 :   result = gfc_real2real (rtrunc, gfc_default_double_kind);
     983                 :            : 
     984                 :         14 :   gfc_free_expr (rtrunc);
     985                 :            : 
     986                 :         14 :   return range_check (result, "DINT");
     987                 :            : }
     988                 :            : 
     989                 :            : 
     990                 :            : gfc_expr *
     991                 :          2 : gfc_simplify_dreal (gfc_expr *e)
     992                 :            : {
     993                 :          2 :   gfc_expr *result = NULL;
     994                 :            : 
     995                 :          2 :   if (e->expr_type != EXPR_CONSTANT)
     996                 :            :     return NULL;
     997                 :            : 
     998                 :          1 :   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
     999                 :          1 :   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
    1000                 :            : 
    1001                 :          1 :   return range_check (result, "DREAL");
    1002                 :            : }
    1003                 :            : 
    1004                 :            : 
    1005                 :            : gfc_expr *
    1006                 :        111 : gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
    1007                 :            : {
    1008                 :        111 :   gfc_expr *result;
    1009                 :        111 :   int kind;
    1010                 :            : 
    1011                 :        111 :   kind = get_kind (BT_REAL, k, "ANINT", e->ts.kind);
    1012                 :        111 :   if (kind == -1)
    1013                 :            :     return &gfc_bad_expr;
    1014                 :            : 
    1015                 :        111 :   if (e->expr_type != EXPR_CONSTANT)
    1016                 :            :     return NULL;
    1017                 :            : 
    1018                 :         53 :   result = gfc_get_constant_expr (e->ts.type, kind, &e->where);
    1019                 :         53 :   mpfr_round (result->value.real, e->value.real);
    1020                 :            : 
    1021                 :         53 :   return range_check (result, "ANINT");
    1022                 :            : }
    1023                 :            : 
    1024                 :            : 
    1025                 :            : gfc_expr *
    1026                 :         22 : gfc_simplify_and (gfc_expr *x, gfc_expr *y)
    1027                 :            : {
    1028                 :         22 :   gfc_expr *result;
    1029                 :         22 :   int kind;
    1030                 :            : 
    1031                 :         22 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    1032                 :            :     return NULL;
    1033                 :            : 
    1034                 :          7 :   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
    1035                 :            : 
    1036                 :          7 :   switch (x->ts.type)
    1037                 :            :     {
    1038                 :          1 :       case BT_INTEGER:
    1039                 :          1 :         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
    1040                 :          1 :         mpz_and (result->value.integer, x->value.integer, y->value.integer);
    1041                 :          1 :         return range_check (result, "AND");
    1042                 :            : 
    1043                 :          6 :       case BT_LOGICAL:
    1044                 :          6 :         return gfc_get_logical_expr (kind, &x->where,
    1045                 :         12 :                                      x->value.logical && y->value.logical);
    1046                 :            : 
    1047                 :          0 :       default:
    1048                 :          0 :         gcc_unreachable ();
    1049                 :            :     }
    1050                 :            : }
    1051                 :            : 
    1052                 :            : 
    1053                 :            : gfc_expr *
    1054                 :      24881 : gfc_simplify_any (gfc_expr *mask, gfc_expr *dim)
    1055                 :            : {
    1056                 :      24881 :   return simplify_transformation (mask, dim, NULL, false, gfc_or);
    1057                 :            : }
    1058                 :            : 
    1059                 :            : 
    1060                 :            : gfc_expr *
    1061                 :         78 : gfc_simplify_dnint (gfc_expr *e)
    1062                 :            : {
    1063                 :         78 :   gfc_expr *result;
    1064                 :            : 
    1065                 :         78 :   if (e->expr_type != EXPR_CONSTANT)
    1066                 :            :     return NULL;
    1067                 :            : 
    1068                 :         44 :   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &e->where);
    1069                 :         44 :   mpfr_round (result->value.real, e->value.real);
    1070                 :            : 
    1071                 :         44 :   return range_check (result, "DNINT");
    1072                 :            : }
    1073                 :            : 
    1074                 :            : 
    1075                 :            : gfc_expr *
    1076                 :        311 : gfc_simplify_asin (gfc_expr *x)
    1077                 :            : {
    1078                 :        311 :   gfc_expr *result;
    1079                 :            : 
    1080                 :        311 :   if (x->expr_type != EXPR_CONSTANT)
    1081                 :            :     return NULL;
    1082                 :            : 
    1083                 :         71 :   switch (x->ts.type)
    1084                 :            :     {
    1085                 :         67 :       case BT_REAL:
    1086                 :         67 :         if (mpfr_cmp_si (x->value.real, 1) > 0
    1087                 :         67 :             || mpfr_cmp_si (x->value.real, -1) < 0)
    1088                 :            :           {
    1089                 :          0 :             gfc_error ("Argument of ASIN at %L must be between -1 and 1",
    1090                 :            :                        &x->where);
    1091                 :          0 :             return &gfc_bad_expr;
    1092                 :            :           }
    1093                 :         67 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1094                 :         67 :         mpfr_asin (result->value.real, x->value.real, GFC_RND_MODE);
    1095                 :         67 :         break;
    1096                 :            : 
    1097                 :          4 :       case BT_COMPLEX:
    1098                 :          4 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1099                 :          4 :         mpc_asin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1100                 :          4 :         break;
    1101                 :            : 
    1102                 :          0 :       default:
    1103                 :          0 :         gfc_internal_error ("in gfc_simplify_asin(): Bad type");
    1104                 :            :     }
    1105                 :            : 
    1106                 :         71 :   return range_check (result, "ASIN");
    1107                 :            : }
    1108                 :            : 
    1109                 :            : 
    1110                 :            : gfc_expr *
    1111                 :        153 : gfc_simplify_asinh (gfc_expr *x)
    1112                 :            : {
    1113                 :        153 :   gfc_expr *result;
    1114                 :            : 
    1115                 :        153 :   if (x->expr_type != EXPR_CONSTANT)
    1116                 :            :     return NULL;
    1117                 :            : 
    1118                 :         37 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1119                 :            : 
    1120                 :         37 :   switch (x->ts.type)
    1121                 :            :     {
    1122                 :         33 :       case BT_REAL:
    1123                 :         33 :         mpfr_asinh (result->value.real, x->value.real, GFC_RND_MODE);
    1124                 :         33 :         break;
    1125                 :            : 
    1126                 :          4 :       case BT_COMPLEX:
    1127                 :          4 :         mpc_asinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1128                 :          4 :         break;
    1129                 :            : 
    1130                 :          0 :       default:
    1131                 :          0 :         gfc_internal_error ("in gfc_simplify_asinh(): Bad type");
    1132                 :            :     }
    1133                 :            : 
    1134                 :         37 :   return range_check (result, "ASINH");
    1135                 :            : }
    1136                 :            : 
    1137                 :            : 
    1138                 :            : gfc_expr *
    1139                 :        371 : gfc_simplify_atan (gfc_expr *x)
    1140                 :            : {
    1141                 :        371 :   gfc_expr *result;
    1142                 :            : 
    1143                 :        371 :   if (x->expr_type != EXPR_CONSTANT)
    1144                 :            :     return NULL;
    1145                 :            : 
    1146                 :        115 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1147                 :            : 
    1148                 :        115 :   switch (x->ts.type)
    1149                 :            :     {
    1150                 :        111 :       case BT_REAL:
    1151                 :        111 :         mpfr_atan (result->value.real, x->value.real, GFC_RND_MODE);
    1152                 :        111 :         break;
    1153                 :            : 
    1154                 :          4 :       case BT_COMPLEX:
    1155                 :          4 :         mpc_atan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1156                 :          4 :         break;
    1157                 :            : 
    1158                 :          0 :       default:
    1159                 :          0 :         gfc_internal_error ("in gfc_simplify_atan(): Bad type");
    1160                 :            :     }
    1161                 :            : 
    1162                 :        115 :   return range_check (result, "ATAN");
    1163                 :            : }
    1164                 :            : 
    1165                 :            : 
    1166                 :            : gfc_expr *
    1167                 :        150 : gfc_simplify_atanh (gfc_expr *x)
    1168                 :            : {
    1169                 :        150 :   gfc_expr *result;
    1170                 :            : 
    1171                 :        150 :   if (x->expr_type != EXPR_CONSTANT)
    1172                 :            :     return NULL;
    1173                 :            : 
    1174                 :         34 :   switch (x->ts.type)
    1175                 :            :     {
    1176                 :         30 :       case BT_REAL:
    1177                 :         30 :         if (mpfr_cmp_si (x->value.real, 1) >= 0
    1178                 :         30 :             || mpfr_cmp_si (x->value.real, -1) <= 0)
    1179                 :            :           {
    1180                 :          0 :             gfc_error ("Argument of ATANH at %L must be inside the range -1 "
    1181                 :            :                        "to 1", &x->where);
    1182                 :          0 :             return &gfc_bad_expr;
    1183                 :            :           }
    1184                 :         30 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1185                 :         30 :         mpfr_atanh (result->value.real, x->value.real, GFC_RND_MODE);
    1186                 :         30 :         break;
    1187                 :            : 
    1188                 :          4 :       case BT_COMPLEX:
    1189                 :          4 :         result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1190                 :          4 :         mpc_atanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1191                 :          4 :         break;
    1192                 :            : 
    1193                 :          0 :       default:
    1194                 :          0 :         gfc_internal_error ("in gfc_simplify_atanh(): Bad type");
    1195                 :            :     }
    1196                 :            : 
    1197                 :         34 :   return range_check (result, "ATANH");
    1198                 :            : }
    1199                 :            : 
    1200                 :            : 
    1201                 :            : gfc_expr *
    1202                 :        378 : gfc_simplify_atan2 (gfc_expr *y, gfc_expr *x)
    1203                 :            : {
    1204                 :        378 :   gfc_expr *result;
    1205                 :            : 
    1206                 :        378 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    1207                 :            :     return NULL;
    1208                 :            : 
    1209                 :        192 :   if (mpfr_zero_p (y->value.real) && mpfr_zero_p (x->value.real))
    1210                 :            :     {
    1211                 :          0 :       gfc_error ("If first argument of ATAN2 %L is zero, then the "
    1212                 :            :                  "second argument must not be zero", &x->where);
    1213                 :          0 :       return &gfc_bad_expr;
    1214                 :            :     }
    1215                 :            : 
    1216                 :        192 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1217                 :        192 :   mpfr_atan2 (result->value.real, y->value.real, x->value.real, GFC_RND_MODE);
    1218                 :            : 
    1219                 :        192 :   return range_check (result, "ATAN2");
    1220                 :            : }
    1221                 :            : 
    1222                 :            : 
    1223                 :            : gfc_expr *
    1224                 :         48 : gfc_simplify_bessel_j0 (gfc_expr *x)
    1225                 :            : {
    1226                 :         48 :   gfc_expr *result;
    1227                 :            : 
    1228                 :         48 :   if (x->expr_type != EXPR_CONSTANT)
    1229                 :            :     return NULL;
    1230                 :            : 
    1231                 :         14 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1232                 :         14 :   mpfr_j0 (result->value.real, x->value.real, GFC_RND_MODE);
    1233                 :            : 
    1234                 :         14 :   return range_check (result, "BESSEL_J0");
    1235                 :            : }
    1236                 :            : 
    1237                 :            : 
    1238                 :            : gfc_expr *
    1239                 :         46 : gfc_simplify_bessel_j1 (gfc_expr *x)
    1240                 :            : {
    1241                 :         46 :   gfc_expr *result;
    1242                 :            : 
    1243                 :         46 :   if (x->expr_type != EXPR_CONSTANT)
    1244                 :            :     return NULL;
    1245                 :            : 
    1246                 :         12 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1247                 :         12 :   mpfr_j1 (result->value.real, x->value.real, GFC_RND_MODE);
    1248                 :            : 
    1249                 :         12 :   return range_check (result, "BESSEL_J1");
    1250                 :            : }
    1251                 :            : 
    1252                 :            : 
    1253                 :            : gfc_expr *
    1254                 :       1032 : gfc_simplify_bessel_jn (gfc_expr *order, gfc_expr *x)
    1255                 :            : {
    1256                 :       1032 :   gfc_expr *result;
    1257                 :       1032 :   long n;
    1258                 :            : 
    1259                 :       1032 :   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
    1260                 :            :     return NULL;
    1261                 :            : 
    1262                 :        906 :   n = mpz_get_si (order->value.integer);
    1263                 :        906 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1264                 :        906 :   mpfr_jn (result->value.real, n, x->value.real, GFC_RND_MODE);
    1265                 :            : 
    1266                 :        906 :   return range_check (result, "BESSEL_JN");
    1267                 :            : }
    1268                 :            : 
    1269                 :            : 
    1270                 :            : /* Simplify transformational form of JN and YN.  */
    1271                 :            : 
    1272                 :            : static gfc_expr *
    1273                 :         56 : gfc_simplify_bessel_n2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x,
    1274                 :            :                         bool jn)
    1275                 :            : {
    1276                 :         56 :   gfc_expr *result;
    1277                 :         56 :   gfc_expr *e;
    1278                 :         56 :   long n1, n2;
    1279                 :         56 :   int i;
    1280                 :         56 :   mpfr_t x2rev, last1, last2;
    1281                 :            : 
    1282                 :         56 :   if (x->expr_type != EXPR_CONSTANT || order1->expr_type != EXPR_CONSTANT
    1283                 :         49 :       || order2->expr_type != EXPR_CONSTANT)
    1284                 :            :     return NULL;
    1285                 :            : 
    1286                 :         49 :   n1 = mpz_get_si (order1->value.integer);
    1287                 :         49 :   n2 = mpz_get_si (order2->value.integer);
    1288                 :         49 :   result = gfc_get_array_expr (x->ts.type, x->ts.kind, &x->where);
    1289                 :         49 :   result->rank = 1;
    1290                 :         49 :   result->shape = gfc_get_shape (1);
    1291                 :         49 :   mpz_init_set_ui (result->shape[0], MAX (n2-n1+1, 0));
    1292                 :            : 
    1293                 :         49 :   if (n2 < n1)
    1294                 :            :     return result;
    1295                 :            : 
    1296                 :            :   /* Special case: x == 0; it is J0(0.0) == 1, JN(N > 0, 0.0) == 0; and
    1297                 :            :      YN(N, 0.0) = -Inf.  */
    1298                 :            : 
    1299                 :         49 :   if (mpfr_cmp_ui (x->value.real, 0.0) == 0)
    1300                 :            :     {
    1301                 :         12 :       if (!jn && flag_range_check)
    1302                 :            :         {
    1303                 :          0 :           gfc_error ("Result of BESSEL_YN is -INF at %L", &result->where);
    1304                 :          0 :           gfc_free_expr (result);
    1305                 :          0 :           return &gfc_bad_expr;
    1306                 :            :         }
    1307                 :            : 
    1308                 :         12 :       if (jn && n1 == 0)
    1309                 :            :         {
    1310                 :          6 :           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1311                 :          6 :           mpfr_set_ui (e->value.real, 1, GFC_RND_MODE);
    1312                 :          6 :           gfc_constructor_append_expr (&result->value.constructor, e,
    1313                 :            :                                        &x->where);
    1314                 :          6 :           n1++;
    1315                 :            :         }
    1316                 :            : 
    1317                 :        138 :       for (i = n1; i <= n2; i++)
    1318                 :            :         {
    1319                 :        126 :           e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1320                 :        126 :           if (jn)
    1321                 :         60 :             mpfr_set_ui (e->value.real, 0, GFC_RND_MODE);
    1322                 :            :           else
    1323                 :         66 :             mpfr_set_inf (e->value.real, -1);
    1324                 :        126 :           gfc_constructor_append_expr (&result->value.constructor, e,
    1325                 :            :                                        &x->where);
    1326                 :            :         }
    1327                 :            : 
    1328                 :            :       return result;
    1329                 :            :     }
    1330                 :            : 
    1331                 :            :   /* Use the faster but more verbose recurrence algorithm. Bessel functions
    1332                 :            :      are stable for downward recursion and Neumann functions are stable
    1333                 :            :      for upward recursion. It is
    1334                 :            :        x2rev = 2.0/x,
    1335                 :            :        J(N-1, x) = x2rev * N * J(N, x) - J(N+1, x),
    1336                 :            :        Y(N+1, x) = x2rev * N * Y(N, x) - Y(N-1, x).
    1337                 :            :      Cf. http://dlmf.nist.gov/10.74#iv and http://dlmf.nist.gov/10.6#E1  */
    1338                 :            : 
    1339                 :         37 :   gfc_set_model_kind (x->ts.kind);
    1340                 :            : 
    1341                 :            :   /* Get first recursion anchor.  */
    1342                 :            : 
    1343                 :         37 :   mpfr_init (last1);
    1344                 :         37 :   if (jn)
    1345                 :         19 :     mpfr_jn (last1, n2, x->value.real, GFC_RND_MODE);
    1346                 :            :   else
    1347                 :         18 :     mpfr_yn (last1, n1, x->value.real, GFC_RND_MODE);
    1348                 :            : 
    1349                 :         37 :   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1350                 :         37 :   mpfr_set (e->value.real, last1, GFC_RND_MODE);
    1351                 :         55 :   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
    1352                 :            :     {
    1353                 :          0 :       mpfr_clear (last1);
    1354                 :          0 :       gfc_free_expr (e);
    1355                 :          0 :       gfc_free_expr (result);
    1356                 :          0 :       return &gfc_bad_expr;
    1357                 :            :     }
    1358                 :         37 :   gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
    1359                 :            : 
    1360                 :         37 :   if (n1 == n2)
    1361                 :            :     {
    1362                 :          0 :       mpfr_clear (last1);
    1363                 :          0 :       return result;
    1364                 :            :     }
    1365                 :            : 
    1366                 :            :   /* Get second recursion anchor.  */
    1367                 :            : 
    1368                 :         37 :   mpfr_init (last2);
    1369                 :         37 :   if (jn)
    1370                 :         19 :     mpfr_jn (last2, n2-1, x->value.real, GFC_RND_MODE);
    1371                 :            :   else
    1372                 :         18 :     mpfr_yn (last2, n1+1, x->value.real, GFC_RND_MODE);
    1373                 :            : 
    1374                 :         37 :   e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1375                 :         37 :   mpfr_set (e->value.real, last2, GFC_RND_MODE);
    1376                 :         37 :   if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
    1377                 :            :     {
    1378                 :          0 :       mpfr_clear (last1);
    1379                 :          0 :       mpfr_clear (last2);
    1380                 :          0 :       gfc_free_expr (e);
    1381                 :          0 :       gfc_free_expr (result);
    1382                 :          0 :       return &gfc_bad_expr;
    1383                 :            :     }
    1384                 :         37 :   if (jn)
    1385                 :         19 :     gfc_constructor_insert_expr (&result->value.constructor, e, &x->where, -2);
    1386                 :            :   else
    1387                 :         18 :     gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
    1388                 :            : 
    1389                 :         37 :   if (n1 + 1 == n2)
    1390                 :            :     {
    1391                 :          1 :       mpfr_clear (last1);
    1392                 :          1 :       mpfr_clear (last2);
    1393                 :          1 :       return result;
    1394                 :            :     }
    1395                 :            : 
    1396                 :            :   /* Start actual recursion.  */
    1397                 :            : 
    1398                 :         36 :   mpfr_init (x2rev);
    1399                 :         36 :   mpfr_ui_div (x2rev, 2, x->value.real, GFC_RND_MODE);
    1400                 :            : 
    1401                 :        276 :   for (i = 2; i <= n2-n1; i++)
    1402                 :            :     {
    1403                 :        240 :       e = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1404                 :            : 
    1405                 :            :       /* Special case: For YN, if the previous N gave -INF, set
    1406                 :            :          also N+1 to -INF.  */
    1407                 :        240 :       if (!jn && !flag_range_check && mpfr_inf_p (last2))
    1408                 :            :         {
    1409                 :          0 :           mpfr_set_inf (e->value.real, -1);
    1410                 :          0 :           gfc_constructor_append_expr (&result->value.constructor, e,
    1411                 :            :                                        &x->where);
    1412                 :          0 :           continue;
    1413                 :            :         }
    1414                 :            : 
    1415                 :        240 :       mpfr_mul_si (e->value.real, x2rev, jn ? (n2-i+1) : (n1+i-1),
    1416                 :            :                    GFC_RND_MODE);
    1417                 :        240 :       mpfr_mul (e->value.real, e->value.real, last2, GFC_RND_MODE);
    1418                 :        240 :       mpfr_sub (e->value.real, e->value.real, last1, GFC_RND_MODE);
    1419                 :            : 
    1420                 :        240 :       if (range_check (e, jn ? "BESSEL_JN" : "BESSEL_YN") == &gfc_bad_expr)
    1421                 :            :         {
    1422                 :            :           /* Range_check frees "e" in that case.  */
    1423                 :          0 :           e = NULL;
    1424                 :          0 :           goto error;
    1425                 :            :         }
    1426                 :            : 
    1427                 :        240 :       if (jn)
    1428                 :        120 :         gfc_constructor_insert_expr (&result->value.constructor, e, &x->where,
    1429                 :            :                                      -i-1);
    1430                 :            :       else
    1431                 :        120 :         gfc_constructor_append_expr (&result->value.constructor, e, &x->where);
    1432                 :            : 
    1433                 :        240 :       mpfr_set (last1, last2, GFC_RND_MODE);
    1434                 :        240 :       mpfr_set (last2, e->value.real, GFC_RND_MODE);
    1435                 :            :     }
    1436                 :            : 
    1437                 :         36 :   mpfr_clear (last1);
    1438                 :         36 :   mpfr_clear (last2);
    1439                 :         36 :   mpfr_clear (x2rev);
    1440                 :         36 :   return result;
    1441                 :            : 
    1442                 :          0 : error:
    1443                 :          0 :   mpfr_clear (last1);
    1444                 :          0 :   mpfr_clear (last2);
    1445                 :          0 :   mpfr_clear (x2rev);
    1446                 :          0 :   gfc_free_expr (e);
    1447                 :          0 :   gfc_free_expr (result);
    1448                 :          0 :   return &gfc_bad_expr;
    1449                 :            : }
    1450                 :            : 
    1451                 :            : 
    1452                 :            : gfc_expr *
    1453                 :         26 : gfc_simplify_bessel_jn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
    1454                 :            : {
    1455                 :         26 :   return gfc_simplify_bessel_n2 (order1, order2, x, true);
    1456                 :            : }
    1457                 :            : 
    1458                 :            : 
    1459                 :            : gfc_expr *
    1460                 :         46 : gfc_simplify_bessel_y0 (gfc_expr *x)
    1461                 :            : {
    1462                 :         46 :   gfc_expr *result;
    1463                 :            : 
    1464                 :         46 :   if (x->expr_type != EXPR_CONSTANT)
    1465                 :            :     return NULL;
    1466                 :            : 
    1467                 :         12 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1468                 :         12 :   mpfr_y0 (result->value.real, x->value.real, GFC_RND_MODE);
    1469                 :            : 
    1470                 :         12 :   return range_check (result, "BESSEL_Y0");
    1471                 :            : }
    1472                 :            : 
    1473                 :            : 
    1474                 :            : gfc_expr *
    1475                 :         46 : gfc_simplify_bessel_y1 (gfc_expr *x)
    1476                 :            : {
    1477                 :         46 :   gfc_expr *result;
    1478                 :            : 
    1479                 :         46 :   if (x->expr_type != EXPR_CONSTANT)
    1480                 :            :     return NULL;
    1481                 :            : 
    1482                 :         12 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1483                 :         12 :   mpfr_y1 (result->value.real, x->value.real, GFC_RND_MODE);
    1484                 :            : 
    1485                 :         12 :   return range_check (result, "BESSEL_Y1");
    1486                 :            : }
    1487                 :            : 
    1488                 :            : 
    1489                 :            : gfc_expr *
    1490                 :       1644 : gfc_simplify_bessel_yn (gfc_expr *order, gfc_expr *x)
    1491                 :            : {
    1492                 :       1644 :   gfc_expr *result;
    1493                 :       1644 :   long n;
    1494                 :            : 
    1495                 :       1644 :   if (x->expr_type != EXPR_CONSTANT || order->expr_type != EXPR_CONSTANT)
    1496                 :            :     return NULL;
    1497                 :            : 
    1498                 :        900 :   n = mpz_get_si (order->value.integer);
    1499                 :        900 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1500                 :        900 :   mpfr_yn (result->value.real, n, x->value.real, GFC_RND_MODE);
    1501                 :            : 
    1502                 :        900 :   return range_check (result, "BESSEL_YN");
    1503                 :            : }
    1504                 :            : 
    1505                 :            : 
    1506                 :            : gfc_expr *
    1507                 :         30 : gfc_simplify_bessel_yn2 (gfc_expr *order1, gfc_expr *order2, gfc_expr *x)
    1508                 :            : {
    1509                 :         30 :   return gfc_simplify_bessel_n2 (order1, order2, x, false);
    1510                 :            : }
    1511                 :            : 
    1512                 :            : 
    1513                 :            : gfc_expr *
    1514                 :       3599 : gfc_simplify_bit_size (gfc_expr *e)
    1515                 :            : {
    1516                 :       3599 :   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    1517                 :       3599 :   return gfc_get_int_expr (e->ts.kind, &e->where,
    1518                 :       3599 :                            gfc_integer_kinds[i].bit_size);
    1519                 :            : }
    1520                 :            : 
    1521                 :            : 
    1522                 :            : gfc_expr *
    1523                 :        159 : gfc_simplify_btest (gfc_expr *e, gfc_expr *bit)
    1524                 :            : {
    1525                 :        159 :   int b;
    1526                 :            : 
    1527                 :        159 :   if (e->expr_type != EXPR_CONSTANT || bit->expr_type != EXPR_CONSTANT)
    1528                 :            :     return NULL;
    1529                 :            : 
    1530                 :         11 :   if (gfc_extract_int (bit, &b) || b < 0)
    1531                 :          0 :     return gfc_get_logical_expr (gfc_default_logical_kind, &e->where, false);
    1532                 :            : 
    1533                 :         11 :   return gfc_get_logical_expr (gfc_default_logical_kind, &e->where,
    1534                 :         11 :                                mpz_tstbit (e->value.integer, b));
    1535                 :            : }
    1536                 :            : 
    1537                 :            : 
    1538                 :            : static int
    1539                 :       1014 : compare_bitwise (gfc_expr *i, gfc_expr *j)
    1540                 :            : {
    1541                 :       1014 :   mpz_t x, y;
    1542                 :       1014 :   int k, res;
    1543                 :            : 
    1544                 :       1014 :   gcc_assert (i->ts.type == BT_INTEGER);
    1545                 :       1014 :   gcc_assert (j->ts.type == BT_INTEGER);
    1546                 :            : 
    1547                 :       1014 :   mpz_init_set (x, i->value.integer);
    1548                 :       1014 :   k = gfc_validate_kind (i->ts.type, i->ts.kind, false);
    1549                 :       1014 :   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
    1550                 :            : 
    1551                 :       1014 :   mpz_init_set (y, j->value.integer);
    1552                 :       1014 :   k = gfc_validate_kind (j->ts.type, j->ts.kind, false);
    1553                 :       1014 :   convert_mpz_to_unsigned (y, gfc_integer_kinds[k].bit_size);
    1554                 :            : 
    1555                 :       1014 :   res = mpz_cmp (x, y);
    1556                 :       1014 :   mpz_clear (x);
    1557                 :       1014 :   mpz_clear (y);
    1558                 :       1014 :   return res;
    1559                 :            : }
    1560                 :            : 
    1561                 :            : 
    1562                 :            : gfc_expr *
    1563                 :        330 : gfc_simplify_bge (gfc_expr *i, gfc_expr *j)
    1564                 :            : {
    1565                 :        330 :   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
    1566                 :            :     return NULL;
    1567                 :            : 
    1568                 :        276 :   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
    1569                 :        552 :                                compare_bitwise (i, j) >= 0);
    1570                 :            : }
    1571                 :            : 
    1572                 :            : 
    1573                 :            : gfc_expr *
    1574                 :        300 : gfc_simplify_bgt (gfc_expr *i, gfc_expr *j)
    1575                 :            : {
    1576                 :        300 :   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
    1577                 :            :     return NULL;
    1578                 :            : 
    1579                 :        246 :   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
    1580                 :        492 :                                compare_bitwise (i, j) > 0);
    1581                 :            : }
    1582                 :            : 
    1583                 :            : 
    1584                 :            : gfc_expr *
    1585                 :        300 : gfc_simplify_ble (gfc_expr *i, gfc_expr *j)
    1586                 :            : {
    1587                 :        300 :   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
    1588                 :            :     return NULL;
    1589                 :            : 
    1590                 :        246 :   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
    1591                 :        492 :                                compare_bitwise (i, j) <= 0);
    1592                 :            : }
    1593                 :            : 
    1594                 :            : 
    1595                 :            : gfc_expr *
    1596                 :        300 : gfc_simplify_blt (gfc_expr *i, gfc_expr *j)
    1597                 :            : {
    1598                 :        300 :   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT)
    1599                 :            :     return NULL;
    1600                 :            : 
    1601                 :        246 :   return gfc_get_logical_expr (gfc_default_logical_kind, &i->where,
    1602                 :        492 :                                compare_bitwise (i, j) < 0);
    1603                 :            : }
    1604                 :            : 
    1605                 :            : 
    1606                 :            : gfc_expr *
    1607                 :         69 : gfc_simplify_ceiling (gfc_expr *e, gfc_expr *k)
    1608                 :            : {
    1609                 :         69 :   gfc_expr *ceil, *result;
    1610                 :         69 :   int kind;
    1611                 :            : 
    1612                 :         69 :   kind = get_kind (BT_INTEGER, k, "CEILING", gfc_default_integer_kind);
    1613                 :         69 :   if (kind == -1)
    1614                 :            :     return &gfc_bad_expr;
    1615                 :            : 
    1616                 :         69 :   if (e->expr_type != EXPR_CONSTANT)
    1617                 :            :     return NULL;
    1618                 :            : 
    1619                 :          8 :   ceil = gfc_copy_expr (e);
    1620                 :          8 :   mpfr_ceil (ceil->value.real, e->value.real);
    1621                 :            : 
    1622                 :          8 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
    1623                 :          8 :   gfc_mpfr_to_mpz (result->value.integer, ceil->value.real, &e->where);
    1624                 :            : 
    1625                 :          8 :   gfc_free_expr (ceil);
    1626                 :            : 
    1627                 :          8 :   return range_check (result, "CEILING");
    1628                 :            : }
    1629                 :            : 
    1630                 :            : 
    1631                 :            : gfc_expr *
    1632                 :       4494 : gfc_simplify_char (gfc_expr *e, gfc_expr *k)
    1633                 :            : {
    1634                 :       4494 :   return simplify_achar_char (e, k, "CHAR", false);
    1635                 :            : }
    1636                 :            : 
    1637                 :            : 
    1638                 :            : /* Common subroutine for simplifying CMPLX, COMPLEX and DCMPLX.  */
    1639                 :            : 
    1640                 :            : static gfc_expr *
    1641                 :       4884 : simplify_cmplx (const char *name, gfc_expr *x, gfc_expr *y, int kind)
    1642                 :            : {
    1643                 :       4884 :   gfc_expr *result;
    1644                 :            : 
    1645                 :       4884 :   if (x->expr_type != EXPR_CONSTANT
    1646                 :       4026 :       || (y != NULL && y->expr_type != EXPR_CONSTANT))
    1647                 :            :     return NULL;
    1648                 :            : 
    1649                 :       3959 :   result = gfc_get_constant_expr (BT_COMPLEX, kind, &x->where);
    1650                 :            : 
    1651                 :       3959 :   switch (x->ts.type)
    1652                 :            :     {
    1653                 :       2528 :       case BT_INTEGER:
    1654                 :       2528 :         mpc_set_z (result->value.complex, x->value.integer, GFC_MPC_RND_MODE);
    1655                 :       2528 :         break;
    1656                 :            : 
    1657                 :       1431 :       case BT_REAL:
    1658                 :       1431 :         mpc_set_fr (result->value.complex, x->value.real, GFC_RND_MODE);
    1659                 :       1431 :         break;
    1660                 :            : 
    1661                 :          0 :       case BT_COMPLEX:
    1662                 :          0 :         mpc_set (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1663                 :          0 :         break;
    1664                 :            : 
    1665                 :          0 :       default:
    1666                 :          0 :         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (x)");
    1667                 :            :     }
    1668                 :            : 
    1669                 :       3959 :   if (!y)
    1670                 :        206 :     return range_check (result, name);
    1671                 :            : 
    1672                 :       3753 :   switch (y->ts.type)
    1673                 :            :     {
    1674                 :       2444 :       case BT_INTEGER:
    1675                 :       2444 :         mpfr_set_z (mpc_imagref (result->value.complex),
    1676                 :       2444 :                     y->value.integer, GFC_RND_MODE);
    1677                 :       2444 :         break;
    1678                 :            : 
    1679                 :       1309 :       case BT_REAL:
    1680                 :       1309 :         mpfr_set (mpc_imagref (result->value.complex),
    1681                 :            :                   y->value.real, GFC_RND_MODE);
    1682                 :       1309 :         break;
    1683                 :            : 
    1684                 :          0 :       default:
    1685                 :          0 :         gfc_internal_error ("gfc_simplify_dcmplx(): Bad type (y)");
    1686                 :            :     }
    1687                 :            : 
    1688                 :       3753 :   return range_check (result, name);
    1689                 :            : }
    1690                 :            : 
    1691                 :            : 
    1692                 :            : gfc_expr *
    1693                 :       4660 : gfc_simplify_cmplx (gfc_expr *x, gfc_expr *y, gfc_expr *k)
    1694                 :            : {
    1695                 :       4660 :   int kind;
    1696                 :            : 
    1697                 :       4660 :   kind = get_kind (BT_REAL, k, "CMPLX", gfc_default_complex_kind);
    1698                 :       4660 :   if (kind == -1)
    1699                 :            :     return &gfc_bad_expr;
    1700                 :            : 
    1701                 :       4660 :   return simplify_cmplx ("CMPLX", x, y, kind);
    1702                 :            : }
    1703                 :            : 
    1704                 :            : 
    1705                 :            : gfc_expr *
    1706                 :         44 : gfc_simplify_complex (gfc_expr *x, gfc_expr *y)
    1707                 :            : {
    1708                 :         44 :   int kind;
    1709                 :            : 
    1710                 :         44 :   if (x->ts.type == BT_INTEGER && y->ts.type == BT_INTEGER)
    1711                 :         13 :     kind = gfc_default_complex_kind;
    1712                 :         31 :   else if (x->ts.type == BT_REAL || y->ts.type == BT_INTEGER)
    1713                 :         25 :     kind = x->ts.kind;
    1714                 :          6 :   else if (x->ts.type == BT_INTEGER || y->ts.type == BT_REAL)
    1715                 :          6 :     kind = y->ts.kind;
    1716                 :          0 :   else if (x->ts.type == BT_REAL && y->ts.type == BT_REAL)
    1717                 :            :     kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
    1718                 :            :   else
    1719                 :          0 :     gcc_unreachable ();
    1720                 :            : 
    1721                 :         44 :   return simplify_cmplx ("COMPLEX", x, y, kind);
    1722                 :            : }
    1723                 :            : 
    1724                 :            : 
    1725                 :            : gfc_expr *
    1726                 :        488 : gfc_simplify_conjg (gfc_expr *e)
    1727                 :            : {
    1728                 :        488 :   gfc_expr *result;
    1729                 :            : 
    1730                 :        488 :   if (e->expr_type != EXPR_CONSTANT)
    1731                 :            :     return NULL;
    1732                 :            : 
    1733                 :         47 :   result = gfc_copy_expr (e);
    1734                 :         47 :   mpc_conj (result->value.complex, result->value.complex, GFC_MPC_RND_MODE);
    1735                 :            : 
    1736                 :         47 :   return range_check (result, "CONJG");
    1737                 :            : }
    1738                 :            : 
    1739                 :            : /* Return the simplification of the constant expression in icall, or NULL
    1740                 :            :    if the expression is not constant.  */
    1741                 :            : 
    1742                 :            : static gfc_expr *
    1743                 :        318 : simplify_trig_call (gfc_expr *icall)
    1744                 :            : {
    1745                 :        318 :   gfc_isym_id func = icall->value.function.isym->id;
    1746                 :        318 :   gfc_expr *x = icall->value.function.actual->expr;
    1747                 :            : 
    1748                 :            :   /* The actual simplifiers will return NULL for non-constant x.  */
    1749                 :        318 :   switch (func)
    1750                 :            :     {
    1751                 :         42 :     case GFC_ISYM_ACOS:
    1752                 :         42 :       return gfc_simplify_acos (x);
    1753                 :         48 :     case GFC_ISYM_ASIN:
    1754                 :         48 :       return gfc_simplify_asin (x);
    1755                 :         48 :     case GFC_ISYM_ATAN:
    1756                 :         48 :       return gfc_simplify_atan (x);
    1757                 :         48 :     case GFC_ISYM_COS:
    1758                 :         48 :       return gfc_simplify_cos (x);
    1759                 :         36 :     case GFC_ISYM_COTAN:
    1760                 :         36 :       return gfc_simplify_cotan (x);
    1761                 :         48 :     case GFC_ISYM_SIN:
    1762                 :         48 :       return gfc_simplify_sin (x);
    1763                 :         48 :     case GFC_ISYM_TAN:
    1764                 :         48 :       return gfc_simplify_tan (x);
    1765                 :          0 :     default:
    1766                 :          0 :       gfc_internal_error ("in simplify_trig_call(): Bad intrinsic");
    1767                 :            :     }
    1768                 :            : }
    1769                 :            : 
    1770                 :            : /* Convert a floating-point number from radians to degrees.  */
    1771                 :            : 
    1772                 :            : static void
    1773                 :         54 : degrees_f (mpfr_t x, mpfr_rnd_t rnd_mode)
    1774                 :            : {
    1775                 :         54 :   mpfr_t tmp;
    1776                 :         54 :   mpfr_init (tmp);
    1777                 :            : 
    1778                 :            :   /* Set x = x * 180.  */
    1779                 :         54 :   mpfr_mul_ui (x, x, 180, rnd_mode);
    1780                 :            : 
    1781                 :            :   /* Set x = x / pi.  */
    1782                 :         54 :   mpfr_const_pi (tmp, rnd_mode);
    1783                 :         54 :   mpfr_div (x, x, tmp, rnd_mode);
    1784                 :            : 
    1785                 :         54 :   mpfr_clear (tmp);
    1786                 :         54 : }
    1787                 :            : 
    1788                 :            : /* Convert a floating-point number from degrees to radians.  */
    1789                 :            : 
    1790                 :            : static void
    1791                 :         48 : radians_f (mpfr_t x, mpfr_rnd_t rnd_mode)
    1792                 :            : {
    1793                 :         48 :   mpfr_t tmp;
    1794                 :         48 :   mpfr_init (tmp);
    1795                 :            : 
    1796                 :            :   /* Set x = x % 360 to avoid offsets with large angles.  */
    1797                 :         48 :   mpfr_set_ui (tmp, 360, rnd_mode);
    1798                 :         48 :   mpfr_fmod (tmp, x, tmp, rnd_mode);
    1799                 :            : 
    1800                 :            :   /* Set x = x * pi.  */
    1801                 :         48 :   mpfr_const_pi (tmp, rnd_mode);
    1802                 :         48 :   mpfr_mul (x, x, tmp, rnd_mode);
    1803                 :            : 
    1804                 :            :   /* Set x = x / 180.  */
    1805                 :         48 :   mpfr_div_ui (x, x, 180, rnd_mode);
    1806                 :            : 
    1807                 :         48 :   mpfr_clear (tmp);
    1808                 :         48 : }
    1809                 :            : 
    1810                 :            : 
    1811                 :            : /* Convert argument to radians before calling a trig function.  */
    1812                 :            : 
    1813                 :            : gfc_expr *
    1814                 :        180 : gfc_simplify_trigd (gfc_expr *icall)
    1815                 :            : {
    1816                 :        180 :   gfc_expr *arg;
    1817                 :            : 
    1818                 :        180 :   arg = icall->value.function.actual->expr;
    1819                 :            : 
    1820                 :        180 :   if (arg->ts.type != BT_REAL)
    1821                 :          0 :     gfc_internal_error ("in gfc_simplify_trigd(): Bad type");
    1822                 :            : 
    1823                 :        180 :   if (arg->expr_type == EXPR_CONSTANT)
    1824                 :            :     /* Convert constant to radians before passing off to simplifier.  */
    1825                 :         48 :     radians_f (arg->value.real, GFC_RND_MODE);
    1826                 :            : 
    1827                 :            :   /* Let the usual simplifier take over - we just simplified the arg.  */
    1828                 :        180 :   return simplify_trig_call (icall);
    1829                 :            : }
    1830                 :            : 
    1831                 :            : /* Convert result of an inverse trig function to degrees.  */
    1832                 :            : 
    1833                 :            : gfc_expr *
    1834                 :        138 : gfc_simplify_atrigd (gfc_expr *icall)
    1835                 :            : {
    1836                 :        138 :   gfc_expr *result;
    1837                 :            : 
    1838                 :        138 :   if (icall->value.function.actual->expr->ts.type != BT_REAL)
    1839                 :          0 :     gfc_internal_error ("in gfc_simplify_atrigd(): Bad type");
    1840                 :            : 
    1841                 :            :   /* See if another simplifier has work to do first.  */
    1842                 :        138 :   result = simplify_trig_call (icall);
    1843                 :            : 
    1844                 :        138 :   if (result && result->expr_type == EXPR_CONSTANT)
    1845                 :            :     {
    1846                 :            :       /* Convert constant to degrees after passing off to actual simplifier.  */
    1847                 :         42 :       degrees_f (result->value.real, GFC_RND_MODE);
    1848                 :         42 :       return result;
    1849                 :            :     }
    1850                 :            : 
    1851                 :            :   /* Let gfc_resolve_atrigd take care of the non-constant case.  */
    1852                 :            :   return NULL;
    1853                 :            : }
    1854                 :            : 
    1855                 :            : /* Convert the result of atan2 to degrees.  */
    1856                 :            : 
    1857                 :            : gfc_expr *
    1858                 :         48 : gfc_simplify_atan2d (gfc_expr *y, gfc_expr *x)
    1859                 :            : {
    1860                 :         48 :   gfc_expr *result;
    1861                 :            : 
    1862                 :         48 :   if (x->ts.type != BT_REAL || y->ts.type != BT_REAL)
    1863                 :          0 :     gfc_internal_error ("in gfc_simplify_atan2d(): Bad type");
    1864                 :            : 
    1865                 :         48 :   if (x->expr_type == EXPR_CONSTANT && y->expr_type == EXPR_CONSTANT)
    1866                 :            :     {
    1867                 :         12 :       result = gfc_simplify_atan2 (y, x);
    1868                 :         12 :       if (result != NULL)
    1869                 :            :         {
    1870                 :         12 :           degrees_f (result->value.real, GFC_RND_MODE);
    1871                 :         12 :           return result;
    1872                 :            :         }
    1873                 :            :     }
    1874                 :            : 
    1875                 :            :   /* Let gfc_resolve_atan2d take care of the non-constant case.  */
    1876                 :            :   return NULL;
    1877                 :            : }
    1878                 :            : 
    1879                 :            : gfc_expr *
    1880                 :        635 : gfc_simplify_cos (gfc_expr *x)
    1881                 :            : {
    1882                 :        635 :   gfc_expr *result;
    1883                 :            : 
    1884                 :        635 :   if (x->expr_type != EXPR_CONSTANT)
    1885                 :            :     return NULL;
    1886                 :            : 
    1887                 :        170 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1888                 :            : 
    1889                 :        170 :   switch (x->ts.type)
    1890                 :            :     {
    1891                 :        113 :       case BT_REAL:
    1892                 :        113 :         mpfr_cos (result->value.real, x->value.real, GFC_RND_MODE);
    1893                 :        113 :         break;
    1894                 :            : 
    1895                 :         57 :       case BT_COMPLEX:
    1896                 :         57 :         gfc_set_model_kind (x->ts.kind);
    1897                 :         57 :         mpc_cos (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1898                 :         57 :         break;
    1899                 :            : 
    1900                 :          0 :       default:
    1901                 :          0 :         gfc_internal_error ("in gfc_simplify_cos(): Bad type");
    1902                 :            :     }
    1903                 :            : 
    1904                 :        170 :   return range_check (result, "COS");
    1905                 :            : }
    1906                 :            : 
    1907                 :            : 
    1908                 :            : gfc_expr *
    1909                 :        170 : gfc_simplify_cosh (gfc_expr *x)
    1910                 :            : {
    1911                 :        170 :   gfc_expr *result;
    1912                 :            : 
    1913                 :        170 :   if (x->expr_type != EXPR_CONSTANT)
    1914                 :            :     return NULL;
    1915                 :            : 
    1916                 :         47 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    1917                 :            : 
    1918                 :         47 :   switch (x->ts.type)
    1919                 :            :     {
    1920                 :         43 :       case BT_REAL:
    1921                 :         43 :         mpfr_cosh (result->value.real, x->value.real, GFC_RND_MODE);
    1922                 :         43 :         break;
    1923                 :            : 
    1924                 :          4 :       case BT_COMPLEX:
    1925                 :          4 :         mpc_cosh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    1926                 :          4 :         break;
    1927                 :            : 
    1928                 :          0 :       default:
    1929                 :          0 :         gcc_unreachable ();
    1930                 :            :     }
    1931                 :            : 
    1932                 :         47 :   return range_check (result, "COSH");
    1933                 :            : }
    1934                 :            : 
    1935                 :            : 
    1936                 :            : gfc_expr *
    1937                 :        403 : gfc_simplify_count (gfc_expr *mask, gfc_expr *dim, gfc_expr *kind)
    1938                 :            : {
    1939                 :        403 :   gfc_expr *result;
    1940                 :        403 :   bool size_zero;
    1941                 :            : 
    1942                 :        403 :   size_zero = gfc_is_size_zero_array (mask);
    1943                 :            : 
    1944                 :        751 :   if (!(is_constant_array_expr (mask) || size_zero)
    1945                 :         55 :       || !gfc_is_constant_expr (dim)
    1946                 :        458 :       || !gfc_is_constant_expr (kind))
    1947                 :        348 :     return NULL;
    1948                 :            : 
    1949                 :         55 :   result = transformational_result (mask, dim,
    1950                 :            :                                     BT_INTEGER,
    1951                 :            :                                     get_kind (BT_INTEGER, kind, "COUNT",
    1952                 :            :                                               gfc_default_integer_kind),
    1953                 :            :                                     &mask->where);
    1954                 :            : 
    1955                 :         55 :   init_result_expr (result, 0, NULL);
    1956                 :            : 
    1957                 :         55 :   if (size_zero)
    1958                 :            :     return result;
    1959                 :            : 
    1960                 :            :   /* Passing MASK twice, once as data array, once as mask.
    1961                 :            :      Whenever gfc_count is called, '1' is added to the result.  */
    1962                 :         30 :   return !dim || mask->rank == 1 ?
    1963                 :         24 :     simplify_transformation_to_scalar (result, mask, mask, gfc_count) :
    1964                 :          6 :     simplify_transformation_to_array (result, mask, dim, mask, gfc_count, NULL);
    1965                 :            : }
    1966                 :            : 
    1967                 :            : /* Simplification routine for cshift. This works by copying the array
    1968                 :            :    expressions into a one-dimensional array, shuffling the values into another
    1969                 :            :    one-dimensional array and creating the new array expression from this.  The
    1970                 :            :    shuffling part is basically taken from the library routine.  */
    1971                 :            : 
    1972                 :            : gfc_expr *
    1973                 :        915 : gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim)
    1974                 :            : {
    1975                 :        915 :   gfc_expr *result;
    1976                 :        915 :   int which;
    1977                 :        915 :   gfc_expr **arrayvec, **resultvec;
    1978                 :        915 :   gfc_expr **rptr, **sptr;
    1979                 :        915 :   mpz_t size;
    1980                 :        915 :   size_t arraysize, shiftsize, i;
    1981                 :        915 :   gfc_constructor *array_ctor, *shift_ctor;
    1982                 :        915 :   ssize_t *shiftvec, *hptr;
    1983                 :        915 :   ssize_t shift_val, len;
    1984                 :        915 :   ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    1985                 :            :     hs_ex[GFC_MAX_DIMENSIONS + 1],
    1986                 :            :     hstride[GFC_MAX_DIMENSIONS], sstride[GFC_MAX_DIMENSIONS],
    1987                 :            :     a_extent[GFC_MAX_DIMENSIONS], a_stride[GFC_MAX_DIMENSIONS],
    1988                 :            :     h_extent[GFC_MAX_DIMENSIONS],
    1989                 :            :     ss_ex[GFC_MAX_DIMENSIONS + 1];
    1990                 :        915 :   ssize_t rsoffset;
    1991                 :        915 :   int d, n;
    1992                 :        915 :   bool continue_loop;
    1993                 :        915 :   gfc_expr **src, **dest;
    1994                 :            : 
    1995                 :        915 :   if (!is_constant_array_expr (array))
    1996                 :            :     return NULL;
    1997                 :            : 
    1998                 :         68 :   if (shift->rank > 0)
    1999                 :          3 :     gfc_simplify_expr (shift, 1);
    2000                 :            : 
    2001                 :         68 :   if (!gfc_is_constant_expr (shift))
    2002                 :            :     return NULL;
    2003                 :            : 
    2004                 :            :   /* Make dim zero-based.  */
    2005                 :         68 :   if (dim)
    2006                 :            :     {
    2007                 :         19 :       if (!gfc_is_constant_expr (dim))
    2008                 :            :         return NULL;
    2009                 :          7 :       which = mpz_get_si (dim->value.integer) - 1;
    2010                 :            :     }
    2011                 :            :   else
    2012                 :            :     which = 0;
    2013                 :            : 
    2014                 :         56 :   gfc_array_size (array, &size);
    2015                 :         56 :   arraysize = mpz_get_ui (size);
    2016                 :         56 :   mpz_clear (size);
    2017                 :            : 
    2018                 :         56 :   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
    2019                 :         56 :   result->shape = gfc_copy_shape (array->shape, array->rank);
    2020                 :         56 :   result->rank = array->rank;
    2021                 :         56 :   result->ts.u.derived = array->ts.u.derived;
    2022                 :            : 
    2023                 :         56 :   if (arraysize == 0)
    2024                 :            :     return result;
    2025                 :            : 
    2026                 :         55 :   arrayvec = XCNEWVEC (gfc_expr *, arraysize);
    2027                 :         55 :   array_ctor = gfc_constructor_first (array->value.constructor);
    2028                 :        834 :   for (i = 0; i < arraysize; i++)
    2029                 :            :     {
    2030                 :        779 :       arrayvec[i] = array_ctor->expr;
    2031                 :        779 :       array_ctor = gfc_constructor_next (array_ctor);
    2032                 :            :     }
    2033                 :            : 
    2034                 :         55 :   resultvec = XCNEWVEC (gfc_expr *, arraysize);
    2035                 :            : 
    2036                 :         55 :   extent[0] = 1;
    2037                 :         55 :   count[0] = 0;
    2038                 :            : 
    2039                 :        131 :   for (d=0; d < array->rank; d++)
    2040                 :            :     {
    2041                 :         76 :       a_extent[d] = mpz_get_si (array->shape[d]);
    2042                 :         76 :       a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
    2043                 :            :     }
    2044                 :            : 
    2045                 :         55 :   if (shift->rank > 0)
    2046                 :            :     {
    2047                 :          3 :       gfc_array_size (shift, &size);
    2048                 :          3 :       shiftsize = mpz_get_ui (size);
    2049                 :          3 :       mpz_clear (size);
    2050                 :          3 :       shiftvec = XCNEWVEC (ssize_t, shiftsize);
    2051                 :          3 :       shift_ctor = gfc_constructor_first (shift->value.constructor);
    2052                 :          9 :       for (d = 0; d < shift->rank; d++)
    2053                 :            :         {
    2054                 :          6 :           h_extent[d] = mpz_get_si (shift->shape[d]);
    2055                 :          6 :           hstride[d] = d == 0 ? 1 : hstride[d-1] * h_extent[d-1];
    2056                 :            :         }
    2057                 :            :     }
    2058                 :            :   else
    2059                 :            :     shiftvec = NULL;
    2060                 :            : 
    2061                 :            :   /* Shut up compiler */
    2062                 :         55 :   len = 1;
    2063                 :         55 :   rsoffset = 1;
    2064                 :            : 
    2065                 :         55 :   n = 0;
    2066                 :        131 :   for (d=0; d < array->rank; d++)
    2067                 :            :     {
    2068                 :         76 :       if (d == which)
    2069                 :            :         {
    2070                 :         55 :           rsoffset = a_stride[d];
    2071                 :         55 :           len = a_extent[d];
    2072                 :            :         }
    2073                 :            :       else
    2074                 :            :         {
    2075                 :         21 :           count[n] = 0;
    2076                 :         21 :           extent[n] = a_extent[d];
    2077                 :         21 :           sstride[n] = a_stride[d];
    2078                 :         21 :           ss_ex[n] = sstride[n] * extent[n];
    2079                 :         21 :           if (shiftvec)
    2080                 :          6 :             hs_ex[n] = hstride[n] * extent[n];
    2081                 :         21 :           n++;
    2082                 :            :         }
    2083                 :            :     }
    2084                 :         55 :   ss_ex[n] = 0;
    2085                 :         55 :   hs_ex[n] = 0;
    2086                 :            : 
    2087                 :         55 :   if (shiftvec)
    2088                 :            :     {
    2089                 :         50 :       for (i = 0; i < shiftsize; i++)
    2090                 :            :         {
    2091                 :         47 :           ssize_t val;
    2092                 :         47 :           val = mpz_get_si (shift_ctor->expr->value.integer);
    2093                 :         47 :           val = val % len;
    2094                 :         47 :           if (val < 0)
    2095                 :         12 :             val += len;
    2096                 :         47 :           shiftvec[i] = val;
    2097                 :         47 :           shift_ctor = gfc_constructor_next (shift_ctor);
    2098                 :            :         }
    2099                 :            :       shift_val = 0;
    2100                 :            :     }
    2101                 :            :   else
    2102                 :            :     {
    2103                 :         52 :       shift_val = mpz_get_si (shift->value.integer);
    2104                 :         52 :       shift_val = shift_val % len;
    2105                 :         52 :       if (shift_val < 0)
    2106                 :          6 :         shift_val += len;
    2107                 :            :     }
    2108                 :            : 
    2109                 :         55 :   continue_loop = true;
    2110                 :         55 :   d = array->rank;
    2111                 :         55 :   rptr = resultvec;
    2112                 :         55 :   sptr = arrayvec;
    2113                 :         55 :   hptr = shiftvec;
    2114                 :            : 
    2115                 :        256 :   while (continue_loop)
    2116                 :            :     {
    2117                 :        201 :       ssize_t sh;
    2118                 :        201 :       if (shiftvec)
    2119                 :         47 :         sh = *hptr;
    2120                 :            :       else
    2121                 :            :         sh = shift_val;
    2122                 :            : 
    2123                 :        201 :       src = &sptr[sh * rsoffset];
    2124                 :        201 :       dest = rptr;
    2125                 :        735 :       for (n = 0; n < len - sh; n++)
    2126                 :            :         {
    2127                 :        534 :           *dest = *src;
    2128                 :        534 :           dest += rsoffset;
    2129                 :        534 :           src += rsoffset;
    2130                 :            :         }
    2131                 :            :       src = sptr;
    2132                 :        446 :       for ( n = 0; n < sh; n++)
    2133                 :            :         {
    2134                 :        245 :           *dest = *src;
    2135                 :        245 :           dest += rsoffset;
    2136                 :        245 :           src += rsoffset;
    2137                 :            :         }
    2138                 :        201 :       rptr += sstride[0];
    2139                 :        201 :       sptr += sstride[0];
    2140                 :        201 :       if (shiftvec)
    2141                 :         47 :         hptr += hstride[0];
    2142                 :        201 :       count[0]++;
    2143                 :        201 :       n = 0;
    2144                 :        244 :       while (count[n] == extent[n])
    2145                 :            :         {
    2146                 :         98 :           count[n] = 0;
    2147                 :         98 :           rptr -= ss_ex[n];
    2148                 :         98 :           sptr -= ss_ex[n];
    2149                 :         98 :           if (shiftvec)
    2150                 :         17 :             hptr -= hs_ex[n];
    2151                 :         98 :           n++;
    2152                 :         98 :           if (n >= d - 1)
    2153                 :            :             {
    2154                 :            :               continue_loop = false;
    2155                 :            :               break;
    2156                 :            :             }
    2157                 :            :           else
    2158                 :            :             {
    2159                 :         43 :               count[n]++;
    2160                 :         43 :               rptr += sstride[n];
    2161                 :         43 :               sptr += sstride[n];
    2162                 :         43 :               if (shiftvec)
    2163                 :         14 :                 hptr += hstride[n];
    2164                 :            :             }
    2165                 :            :         }
    2166                 :            :     }
    2167                 :            : 
    2168                 :        834 :   for (i = 0; i < arraysize; i++)
    2169                 :            :     {
    2170                 :        779 :       gfc_constructor_append_expr (&result->value.constructor,
    2171                 :        779 :                                    gfc_copy_expr (resultvec[i]),
    2172                 :            :                                    NULL);
    2173                 :            :     }
    2174                 :            :   return result;
    2175                 :            : }
    2176                 :            : 
    2177                 :            : 
    2178                 :            : gfc_expr *
    2179                 :        180 : gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y)
    2180                 :            : {
    2181                 :        180 :   return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind);
    2182                 :            : }
    2183                 :            : 
    2184                 :            : 
    2185                 :            : gfc_expr *
    2186                 :        457 : gfc_simplify_dble (gfc_expr *e)
    2187                 :            : {
    2188                 :        457 :   gfc_expr *result = NULL;
    2189                 :        457 :   int tmp1, tmp2;
    2190                 :            : 
    2191                 :        457 :   if (e->expr_type != EXPR_CONSTANT)
    2192                 :            :     return NULL;
    2193                 :            : 
    2194                 :            :   /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
    2195                 :            :      warnings.  */
    2196                 :        118 :   tmp1 = warn_conversion;
    2197                 :        118 :   tmp2 = warn_conversion_extra;
    2198                 :        118 :   warn_conversion = warn_conversion_extra = 0;
    2199                 :            : 
    2200                 :        118 :   result = gfc_convert_constant (e, BT_REAL, gfc_default_double_kind);
    2201                 :            : 
    2202                 :        118 :   warn_conversion = tmp1;
    2203                 :        118 :   warn_conversion_extra = tmp2;
    2204                 :            : 
    2205                 :        118 :   if (result == &gfc_bad_expr)
    2206                 :            :     return &gfc_bad_expr;
    2207                 :            : 
    2208                 :        118 :   return range_check (result, "DBLE");
    2209                 :            : }
    2210                 :            : 
    2211                 :            : 
    2212                 :            : gfc_expr *
    2213                 :         21 : gfc_simplify_digits (gfc_expr *x)
    2214                 :            : {
    2215                 :         21 :   int i, digits;
    2216                 :            : 
    2217                 :         21 :   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
    2218                 :            : 
    2219                 :         21 :   switch (x->ts.type)
    2220                 :            :     {
    2221                 :          0 :       case BT_INTEGER:
    2222                 :          0 :         digits = gfc_integer_kinds[i].digits;
    2223                 :          0 :         break;
    2224                 :            : 
    2225                 :         21 :       case BT_REAL:
    2226                 :         21 :       case BT_COMPLEX:
    2227                 :         21 :         digits = gfc_real_kinds[i].digits;
    2228                 :         21 :         break;
    2229                 :            : 
    2230                 :          0 :       default:
    2231                 :          0 :         gcc_unreachable ();
    2232                 :            :     }
    2233                 :            : 
    2234                 :         21 :   return gfc_get_int_expr (gfc_default_integer_kind, NULL, digits);
    2235                 :            : }
    2236                 :            : 
    2237                 :            : 
    2238                 :            : gfc_expr *
    2239                 :        228 : gfc_simplify_dim (gfc_expr *x, gfc_expr *y)
    2240                 :            : {
    2241                 :        228 :   gfc_expr *result;
    2242                 :        228 :   int kind;
    2243                 :            : 
    2244                 :        228 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    2245                 :            :     return NULL;
    2246                 :            : 
    2247                 :         78 :   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
    2248                 :         78 :   result = gfc_get_constant_expr (x->ts.type, kind, &x->where);
    2249                 :            : 
    2250                 :         78 :   switch (x->ts.type)
    2251                 :            :     {
    2252                 :         36 :       case BT_INTEGER:
    2253                 :         36 :         if (mpz_cmp (x->value.integer, y->value.integer) > 0)
    2254                 :         15 :           mpz_sub (result->value.integer, x->value.integer, y->value.integer);
    2255                 :            :         else
    2256                 :         21 :           mpz_set_ui (result->value.integer, 0);
    2257                 :            : 
    2258                 :            :         break;
    2259                 :            : 
    2260                 :         42 :       case BT_REAL:
    2261                 :         42 :         if (mpfr_cmp (x->value.real, y->value.real) > 0)
    2262                 :         30 :           mpfr_sub (result->value.real, x->value.real, y->value.real,
    2263                 :            :                     GFC_RND_MODE);
    2264                 :            :         else
    2265                 :         12 :           mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    2266                 :            : 
    2267                 :            :         break;
    2268                 :            : 
    2269                 :          0 :       default:
    2270                 :          0 :         gfc_internal_error ("gfc_simplify_dim(): Bad type");
    2271                 :            :     }
    2272                 :            : 
    2273                 :         78 :   return range_check (result, "DIM");
    2274                 :            : }
    2275                 :            : 
    2276                 :            : 
    2277                 :            : gfc_expr*
    2278                 :        201 : gfc_simplify_dot_product (gfc_expr *vector_a, gfc_expr *vector_b)
    2279                 :            : {
    2280                 :            :   /* If vector_a is a zero-sized array, the result is 0 for INTEGER,
    2281                 :            :      REAL, and COMPLEX types and .false. for LOGICAL.  */
    2282                 :        201 :   if (vector_a->shape && mpz_get_si (vector_a->shape[0]) == 0)
    2283                 :            :     {
    2284                 :         30 :       if (vector_a->ts.type == BT_LOGICAL)
    2285                 :          6 :         return gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
    2286                 :            :       else
    2287                 :         24 :         return gfc_get_int_expr (gfc_default_integer_kind, NULL, 0);
    2288                 :            :     }
    2289                 :            : 
    2290                 :        171 :   if (!is_constant_array_expr (vector_a)
    2291                 :        171 :       || !is_constant_array_expr (vector_b))
    2292                 :        143 :     return NULL;
    2293                 :            : 
    2294                 :         28 :   return compute_dot_product (vector_a, 1, 0, vector_b, 1, 0, true);
    2295                 :            : }
    2296                 :            : 
    2297                 :            : 
    2298                 :            : gfc_expr *
    2299                 :         20 : gfc_simplify_dprod (gfc_expr *x, gfc_expr *y)
    2300                 :            : {
    2301                 :         20 :   gfc_expr *a1, *a2, *result;
    2302                 :            : 
    2303                 :         20 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    2304                 :            :     return NULL;
    2305                 :            : 
    2306                 :          6 :   a1 = gfc_real2real (x, gfc_default_double_kind);
    2307                 :          6 :   a2 = gfc_real2real (y, gfc_default_double_kind);
    2308                 :            : 
    2309                 :          6 :   result = gfc_get_constant_expr (BT_REAL, gfc_default_double_kind, &x->where);
    2310                 :          6 :   mpfr_mul (result->value.real, a1->value.real, a2->value.real, GFC_RND_MODE);
    2311                 :            : 
    2312                 :          6 :   gfc_free_expr (a2);
    2313                 :          6 :   gfc_free_expr (a1);
    2314                 :            : 
    2315                 :          6 :   return range_check (result, "DPROD");
    2316                 :            : }
    2317                 :            : 
    2318                 :            : 
    2319                 :            : static gfc_expr *
    2320                 :       1532 : simplify_dshift (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg,
    2321                 :            :                       bool right)
    2322                 :            : {
    2323                 :       1532 :   gfc_expr *result;
    2324                 :       1532 :   int i, k, size, shift;
    2325                 :            : 
    2326                 :       1532 :   if (arg1->expr_type != EXPR_CONSTANT || arg2->expr_type != EXPR_CONSTANT
    2327                 :       1464 :       || shiftarg->expr_type != EXPR_CONSTANT)
    2328                 :            :     return NULL;
    2329                 :            : 
    2330                 :       1464 :   k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
    2331                 :       1464 :   size = gfc_integer_kinds[k].bit_size;
    2332                 :            : 
    2333                 :       1464 :   gfc_extract_int (shiftarg, &shift);
    2334                 :            : 
    2335                 :            :   /* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT).  */
    2336                 :       1464 :   if (right)
    2337                 :        732 :     shift = size - shift;
    2338                 :            : 
    2339                 :       1464 :   result = gfc_get_constant_expr (BT_INTEGER, arg1->ts.kind, &arg1->where);
    2340                 :       1464 :   mpz_set_ui (result->value.integer, 0);
    2341                 :            : 
    2342                 :      37560 :   for (i = 0; i < shift; i++)
    2343                 :      36096 :     if (mpz_tstbit (arg2->value.integer, size - shift + i))
    2344                 :      15006 :       mpz_setbit (result->value.integer, i);
    2345                 :            : 
    2346                 :      37560 :   for (i = 0; i < size - shift; i++)
    2347                 :      36096 :     if (mpz_tstbit (arg1->value.integer, i))
    2348                 :      14400 :       mpz_setbit (result->value.integer, shift + i);
    2349                 :            : 
    2350                 :            :   /* Convert to a signed value.  */
    2351                 :       1464 :   gfc_convert_mpz_to_signed (result->value.integer, size);
    2352                 :            : 
    2353                 :       1464 :   return result;
    2354                 :            : }
    2355                 :            : 
    2356                 :            : 
    2357                 :            : gfc_expr *
    2358                 :        766 : gfc_simplify_dshiftr (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
    2359                 :            : {
    2360                 :        766 :   return simplify_dshift (arg1, arg2, shiftarg, true);
    2361                 :            : }
    2362                 :            : 
    2363                 :            : 
    2364                 :            : gfc_expr *
    2365                 :        766 : gfc_simplify_dshiftl (gfc_expr *arg1, gfc_expr *arg2, gfc_expr *shiftarg)
    2366                 :            : {
    2367                 :        766 :   return simplify_dshift (arg1, arg2, shiftarg, false);
    2368                 :            : }
    2369                 :            : 
    2370                 :            : 
    2371                 :            : gfc_expr *
    2372                 :       1507 : gfc_simplify_eoshift (gfc_expr *array, gfc_expr *shift, gfc_expr *boundary,
    2373                 :            :                    gfc_expr *dim)
    2374                 :            : {
    2375                 :       1507 :   bool temp_boundary;
    2376                 :       1507 :   gfc_expr *bnd;
    2377                 :       1507 :   gfc_expr *result;
    2378                 :       1507 :   int which;
    2379                 :       1507 :   gfc_expr **arrayvec, **resultvec;
    2380                 :       1507 :   gfc_expr **rptr, **sptr;
    2381                 :       1507 :   mpz_t size;
    2382                 :       1507 :   size_t arraysize, i;
    2383                 :       1507 :   gfc_constructor *array_ctor, *shift_ctor, *bnd_ctor;
    2384                 :       1507 :   ssize_t shift_val, len;
    2385                 :       1507 :   ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    2386                 :            :     sstride[GFC_MAX_DIMENSIONS], a_extent[GFC_MAX_DIMENSIONS],
    2387                 :            :     a_stride[GFC_MAX_DIMENSIONS], ss_ex[GFC_MAX_DIMENSIONS + 1];
    2388                 :       1507 :   ssize_t rsoffset;
    2389                 :       1507 :   int d, n;
    2390                 :       1507 :   bool continue_loop;
    2391                 :       1507 :   gfc_expr **src, **dest;
    2392                 :       1507 :   size_t s_len;
    2393                 :            : 
    2394                 :       1507 :   if (!is_constant_array_expr (array))
    2395                 :            :     return NULL;
    2396                 :            : 
    2397                 :         47 :   if (shift->rank > 0)
    2398                 :          7 :     gfc_simplify_expr (shift, 1);
    2399                 :            : 
    2400                 :         47 :   if (!gfc_is_constant_expr (shift))
    2401                 :            :     return NULL;
    2402                 :            : 
    2403                 :         47 :   if (boundary)
    2404                 :            :     {
    2405                 :         23 :       if (boundary->rank > 0)
    2406                 :          6 :         gfc_simplify_expr (boundary, 1);
    2407                 :            : 
    2408                 :         23 :       if (!gfc_is_constant_expr (boundary))
    2409                 :            :           return NULL;
    2410                 :            :     }
    2411                 :            : 
    2412                 :         35 :   if (dim)
    2413                 :            :     {
    2414                 :         19 :       if (!gfc_is_constant_expr (dim))
    2415                 :            :         return NULL;
    2416                 :         13 :       which = mpz_get_si (dim->value.integer) - 1;
    2417                 :            :     }
    2418                 :            :   else
    2419                 :            :     which = 0;
    2420                 :            : 
    2421                 :         29 :   s_len = 0;
    2422                 :         29 :   if (boundary == NULL)
    2423                 :            :     {
    2424                 :         22 :       temp_boundary = true;
    2425                 :         22 :       switch (array->ts.type)
    2426                 :            :         {
    2427                 :            : 
    2428                 :         17 :         case BT_INTEGER:
    2429                 :         17 :           bnd = gfc_get_int_expr (array->ts.kind, NULL, 0);
    2430                 :         17 :           break;
    2431                 :            : 
    2432                 :          0 :         case BT_LOGICAL:
    2433                 :          0 :           bnd = gfc_get_logical_expr (array->ts.kind, NULL, 0);
    2434                 :          0 :           break;
    2435                 :            : 
    2436                 :          2 :         case BT_REAL:
    2437                 :          2 :           bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
    2438                 :          2 :           mpfr_set_ui (bnd->value.real, 0, GFC_RND_MODE);
    2439                 :          2 :           break;
    2440                 :            : 
    2441                 :          1 :         case BT_COMPLEX:
    2442                 :          1 :           bnd = gfc_get_constant_expr (array->ts.type, array->ts.kind, &gfc_current_locus);
    2443                 :          1 :           mpc_set_ui (bnd->value.complex, 0, GFC_RND_MODE);
    2444                 :          1 :           break;
    2445                 :            : 
    2446                 :          2 :         case BT_CHARACTER:
    2447                 :          2 :           s_len = mpz_get_ui (array->ts.u.cl->length->value.integer);
    2448                 :          2 :           bnd = gfc_get_character_expr (array->ts.kind, &gfc_current_locus, NULL, s_len);
    2449                 :          2 :           break;
    2450                 :            : 
    2451                 :          0 :         default:
    2452                 :          0 :           gcc_unreachable();
    2453                 :            : 
    2454                 :            :         }
    2455                 :            :     }
    2456                 :            :   else
    2457                 :            :     {
    2458                 :            :       temp_boundary = false;
    2459                 :            :       bnd = boundary;
    2460                 :            :     }
    2461                 :            : 
    2462                 :         29 :   gfc_array_size (array, &size);
    2463                 :         29 :   arraysize = mpz_get_ui (size);
    2464                 :         29 :   mpz_clear (size);
    2465                 :            : 
    2466                 :         29 :   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
    2467                 :         29 :   result->shape = gfc_copy_shape (array->shape, array->rank);
    2468                 :         29 :   result->rank = array->rank;
    2469                 :         29 :   result->ts = array->ts;
    2470                 :            : 
    2471                 :         29 :   if (arraysize == 0)
    2472                 :          1 :     goto final;
    2473                 :            : 
    2474                 :         28 :   arrayvec = XCNEWVEC (gfc_expr *, arraysize);
    2475                 :         28 :   array_ctor = gfc_constructor_first (array->value.constructor);
    2476                 :        412 :   for (i = 0; i < arraysize; i++)
    2477                 :            :     {
    2478                 :        384 :       arrayvec[i] = array_ctor->expr;
    2479                 :        384 :       array_ctor = gfc_constructor_next (array_ctor);
    2480                 :            :     }
    2481                 :            : 
    2482                 :         28 :   resultvec = XCNEWVEC (gfc_expr *, arraysize);
    2483                 :            : 
    2484                 :         28 :   extent[0] = 1;
    2485                 :         28 :   count[0] = 0;
    2486                 :            : 
    2487                 :         80 :   for (d=0; d < array->rank; d++)
    2488                 :            :     {
    2489                 :         52 :       a_extent[d] = mpz_get_si (array->shape[d]);
    2490                 :         52 :       a_stride[d] = d == 0 ? 1 : a_stride[d-1] * a_extent[d-1];
    2491                 :            :     }
    2492                 :            : 
    2493                 :         28 :   if (shift->rank > 0)
    2494                 :            :     {
    2495                 :          7 :       shift_ctor = gfc_constructor_first (shift->value.constructor);
    2496                 :          7 :       shift_val = 0;
    2497                 :            :     }
    2498                 :            :   else
    2499                 :            :     {
    2500                 :         21 :       shift_ctor = NULL;
    2501                 :         21 :       shift_val = mpz_get_si (shift->value.integer);
    2502                 :            :     }
    2503                 :            : 
    2504                 :         28 :   if (bnd->rank > 0)
    2505                 :          4 :     bnd_ctor = gfc_constructor_first (bnd->value.constructor);
    2506                 :            :   else
    2507                 :            :     bnd_ctor = NULL;
    2508                 :            : 
    2509                 :            :   /* Shut up compiler */
    2510                 :         28 :   len = 1;
    2511                 :         28 :   rsoffset = 1;
    2512                 :            : 
    2513                 :         28 :   n = 0;
    2514                 :         80 :   for (d=0; d < array->rank; d++)
    2515                 :            :     {
    2516                 :         52 :       if (d == which)
    2517                 :            :         {
    2518                 :         28 :           rsoffset = a_stride[d];
    2519                 :         28 :           len = a_extent[d];
    2520                 :            :         }
    2521                 :            :       else
    2522                 :            :         {
    2523                 :         24 :           count[n] = 0;
    2524                 :         24 :           extent[n] = a_extent[d];
    2525                 :         24 :           sstride[n] = a_stride[d];
    2526                 :         24 :           ss_ex[n] = sstride[n] * extent[n];
    2527                 :         24 :           n++;
    2528                 :            :         }
    2529                 :            :     }
    2530                 :         28 :   ss_ex[n] = 0;
    2531                 :            : 
    2532                 :         28 :   continue_loop = true;
    2533                 :         28 :   d = array->rank;
    2534                 :         28 :   rptr = resultvec;
    2535                 :         28 :   sptr = arrayvec;
    2536                 :            : 
    2537                 :        136 :   while (continue_loop)
    2538                 :            :     {
    2539                 :        108 :       ssize_t sh, delta;
    2540                 :            : 
    2541                 :        108 :       if (shift_ctor)
    2542                 :         42 :         sh = mpz_get_si (shift_ctor->expr->value.integer);
    2543                 :            :       else
    2544                 :            :         sh = shift_val;
    2545                 :            : 
    2546                 :        108 :       if (( sh >= 0 ? sh : -sh ) > len)
    2547                 :            :         {
    2548                 :            :           delta = len;
    2549                 :            :           sh = len;
    2550                 :            :         }
    2551                 :            :       else
    2552                 :         94 :         delta = (sh >= 0) ? sh: -sh;
    2553                 :            : 
    2554                 :        108 :       if (sh > 0)
    2555                 :            :         {
    2556                 :         63 :           src = &sptr[delta * rsoffset];
    2557                 :         63 :           dest = rptr;
    2558                 :            :         }
    2559                 :            :       else
    2560                 :            :         {
    2561                 :         45 :           src = sptr;
    2562                 :         45 :           dest = &rptr[delta * rsoffset];
    2563                 :            :         }
    2564                 :            : 
    2565                 :        321 :       for (n = 0; n < len - delta; n++)
    2566                 :            :         {
    2567                 :        213 :           *dest = *src;
    2568                 :        213 :           dest += rsoffset;
    2569                 :        213 :           src += rsoffset;
    2570                 :            :         }
    2571                 :            : 
    2572                 :        108 :       if (sh < 0)
    2573                 :         39 :         dest = rptr;
    2574                 :            : 
    2575                 :        108 :       n = delta;
    2576                 :            : 
    2577                 :        108 :       if (bnd_ctor)
    2578                 :            :         {
    2579                 :         73 :           while (n--)
    2580                 :            :             {
    2581                 :         47 :               *dest = gfc_copy_expr (bnd_ctor->expr);
    2582                 :         47 :               dest += rsoffset;
    2583                 :            :             }
    2584                 :            :         }
    2585                 :            :       else
    2586                 :            :         {
    2587                 :        206 :           while (n--)
    2588                 :            :             {
    2589                 :        124 :               *dest = gfc_copy_expr (bnd);
    2590                 :        124 :               dest += rsoffset;
    2591                 :            :             }
    2592                 :            :         }
    2593                 :        108 :       rptr += sstride[0];
    2594                 :        108 :       sptr += sstride[0];
    2595                 :        108 :       if (shift_ctor)
    2596                 :         42 :         shift_ctor =  gfc_constructor_next (shift_ctor);
    2597                 :            : 
    2598                 :        108 :       if (bnd_ctor)
    2599                 :         26 :         bnd_ctor = gfc_constructor_next (bnd_ctor);
    2600                 :            : 
    2601                 :        108 :       count[0]++;
    2602                 :        108 :       n = 0;
    2603                 :        131 :       while (count[n] == extent[n])
    2604                 :            :         {
    2605                 :         51 :           count[n] = 0;
    2606                 :         51 :           rptr -= ss_ex[n];
    2607                 :         51 :           sptr -= ss_ex[n];
    2608                 :         51 :           n++;
    2609                 :         51 :           if (n >= d - 1)
    2610                 :            :             {
    2611                 :            :               continue_loop = false;
    2612                 :            :               break;
    2613                 :            :             }
    2614                 :            :           else
    2615                 :            :             {
    2616                 :         23 :               count[n]++;
    2617                 :         23 :               rptr += sstride[n];
    2618                 :         23 :               sptr += sstride[n];
    2619                 :            :             }
    2620                 :            :         }
    2621                 :            :     }
    2622                 :            : 
    2623                 :        412 :   for (i = 0; i < arraysize; i++)
    2624                 :            :     {
    2625                 :        384 :       gfc_constructor_append_expr (&result->value.constructor,
    2626                 :        384 :                                    gfc_copy_expr (resultvec[i]),
    2627                 :            :                                    NULL);
    2628                 :            :     }
    2629                 :            : 
    2630                 :         28 :  final:
    2631                 :         29 :   if (temp_boundary)
    2632                 :         22 :     gfc_free_expr (bnd);
    2633                 :            : 
    2634                 :            :   return result;
    2635                 :            : }
    2636                 :            : 
    2637                 :            : gfc_expr *
    2638                 :        252 : gfc_simplify_erf (gfc_expr *x)
    2639                 :            : {
    2640                 :        252 :   gfc_expr *result;
    2641                 :            : 
    2642                 :        252 :   if (x->expr_type != EXPR_CONSTANT)
    2643                 :            :     return NULL;
    2644                 :            : 
    2645                 :        110 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    2646                 :        110 :   mpfr_erf (result->value.real, x->value.real, GFC_RND_MODE);
    2647                 :            : 
    2648                 :        110 :   return range_check (result, "ERF");
    2649                 :            : }
    2650                 :            : 
    2651                 :            : 
    2652                 :            : gfc_expr *
    2653                 :        289 : gfc_simplify_erfc (gfc_expr *x)
    2654                 :            : {
    2655                 :        289 :   gfc_expr *result;
    2656                 :            : 
    2657                 :        289 :   if (x->expr_type != EXPR_CONSTANT)
    2658                 :            :     return NULL;
    2659                 :            : 
    2660                 :        111 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    2661                 :        111 :   mpfr_erfc (result->value.real, x->value.real, GFC_RND_MODE);
    2662                 :            : 
    2663                 :        111 :   return range_check (result, "ERFC");
    2664                 :            : }
    2665                 :            : 
    2666                 :            : 
    2667                 :            : /* Helper functions to simplify ERFC_SCALED(x) = ERFC(x) * EXP(X**2).  */
    2668                 :            : 
    2669                 :            : #define MAX_ITER 200
    2670                 :            : #define ARG_LIMIT 12
    2671                 :            : 
    2672                 :            : /* Calculate ERFC_SCALED directly by its definition:
    2673                 :            : 
    2674                 :            :      ERFC_SCALED(x) = ERFC(x) * EXP(X**2)
    2675                 :            : 
    2676                 :            :    using a large precision for intermediate results.  This is used for all
    2677                 :            :    but large values of the argument.  */
    2678                 :            : static void
    2679                 :         89 : fullprec_erfc_scaled (mpfr_t res, mpfr_t arg)
    2680                 :            : {
    2681                 :         89 :   mpfr_prec_t prec;
    2682                 :         89 :   mpfr_t a, b;
    2683                 :            : 
    2684                 :         89 :   prec = mpfr_get_default_prec ();
    2685                 :         89 :   mpfr_set_default_prec (10 * prec);
    2686                 :            : 
    2687                 :         89 :   mpfr_init (a);
    2688                 :         89 :   mpfr_init (b);
    2689                 :            : 
    2690                 :         89 :   mpfr_set (a, arg, GFC_RND_MODE);
    2691                 :         89 :   mpfr_sqr (b, a, GFC_RND_MODE);
    2692                 :         89 :   mpfr_exp (b, b, GFC_RND_MODE);
    2693                 :         89 :   mpfr_erfc (a, a, GFC_RND_MODE);
    2694                 :         89 :   mpfr_mul (a, a, b, GFC_RND_MODE);
    2695                 :            : 
    2696                 :         89 :   mpfr_set (res, a, GFC_RND_MODE);
    2697                 :         89 :   mpfr_set_default_prec (prec);
    2698                 :            : 
    2699                 :         89 :   mpfr_clear (a);
    2700                 :         89 :   mpfr_clear (b);
    2701                 :         89 : }
    2702                 :            : 
    2703                 :            : /* Calculate ERFC_SCALED using a power series expansion in 1/arg:
    2704                 :            : 
    2705                 :            :     ERFC_SCALED(x) = 1 / (x * sqrt(pi))
    2706                 :            :                      * (1 + Sum_n (-1)**n * (1 * 3 * 5 * ... * (2n-1))
    2707                 :            :                                           / (2 * x**2)**n)
    2708                 :            : 
    2709                 :            :   This is used for large values of the argument.  Intermediate calculations
    2710                 :            :   are performed with twice the precision.  We don't do a fixed number of
    2711                 :            :   iterations of the sum, but stop when it has converged to the required
    2712                 :            :   precision.  */
    2713                 :            : static void
    2714                 :         35 : asympt_erfc_scaled (mpfr_t res, mpfr_t arg)
    2715                 :            : {
    2716                 :         35 :   mpfr_t sum, x, u, v, w, oldsum, sumtrunc;
    2717                 :         35 :   mpz_t num;
    2718                 :         35 :   mpfr_prec_t prec;
    2719                 :         35 :   unsigned i;
    2720                 :            : 
    2721                 :         35 :   prec = mpfr_get_default_prec ();
    2722                 :         35 :   mpfr_set_default_prec (2 * prec);
    2723                 :            : 
    2724                 :         35 :   mpfr_init (sum);
    2725                 :         35 :   mpfr_init (x);
    2726                 :         35 :   mpfr_init (u);
    2727                 :         35 :   mpfr_init (v);
    2728                 :         35 :   mpfr_init (w);
    2729                 :         35 :   mpz_init (num);
    2730                 :            : 
    2731                 :         35 :   mpfr_init (oldsum);
    2732                 :         35 :   mpfr_init (sumtrunc);
    2733                 :         35 :   mpfr_set_prec (oldsum, prec);
    2734                 :         35 :   mpfr_set_prec (sumtrunc, prec);
    2735                 :            : 
    2736                 :         35 :   mpfr_set (x, arg, GFC_RND_MODE);
    2737                 :         35 :   mpfr_set_ui (sum, 1, GFC_RND_MODE);
    2738                 :         35 :   mpz_set_ui (num, 1);
    2739                 :            : 
    2740                 :         35 :   mpfr_set (u, x, GFC_RND_MODE);
    2741                 :         35 :   mpfr_sqr (u, u, GFC_RND_MODE);
    2742                 :         35 :   mpfr_mul_ui (u, u, 2, GFC_RND_MODE);
    2743                 :         35 :   mpfr_pow_si (u, u, -1, GFC_RND_MODE);
    2744                 :            : 
    2745                 :        687 :   for (i = 1; i < MAX_ITER; i++)
    2746                 :            :   {
    2747                 :        687 :     mpfr_set (oldsum, sum, GFC_RND_MODE);
    2748                 :            : 
    2749                 :        687 :     mpz_mul_ui (num, num, 2 * i - 1);
    2750                 :        687 :     mpz_neg (num, num);
    2751                 :            : 
    2752                 :        687 :     mpfr_set (w, u, GFC_RND_MODE);
    2753                 :        687 :     mpfr_pow_ui (w, w, i, GFC_RND_MODE);
    2754                 :            : 
    2755                 :        687 :     mpfr_set_z (v, num, GFC_RND_MODE);
    2756                 :        687 :     mpfr_mul (v, v, w, GFC_RND_MODE);
    2757                 :            : 
    2758                 :        687 :     mpfr_add (sum, sum, v, GFC_RND_MODE);
    2759                 :            : 
    2760                 :        687 :     mpfr_set (sumtrunc, sum, GFC_RND_MODE);
    2761                 :        687 :     if (mpfr_cmp (sumtrunc, oldsum) == 0)
    2762                 :            :       break;
    2763                 :            :   }
    2764                 :            : 
    2765                 :            :   /* We should have converged by now; otherwise, ARG_LIMIT is probably
    2766                 :            :      set too low.  */
    2767                 :         35 :   gcc_assert (i < MAX_ITER);
    2768                 :            : 
    2769                 :            :   /* Divide by x * sqrt(Pi).  */
    2770                 :         35 :   mpfr_const_pi (u, GFC_RND_MODE);
    2771                 :         35 :   mpfr_sqrt (u, u, GFC_RND_MODE);
    2772                 :         35 :   mpfr_mul (u, u, x, GFC_RND_MODE);
    2773                 :         35 :   mpfr_div (sum, sum, u, GFC_RND_MODE);
    2774                 :            : 
    2775                 :         35 :   mpfr_set (res, sum, GFC_RND_MODE);
    2776                 :         35 :   mpfr_set_default_prec (prec);
    2777                 :            : 
    2778                 :         35 :   mpfr_clears (sum, x, u, v, w, oldsum, sumtrunc, NULL);
    2779                 :         35 :   mpz_clear (num);
    2780                 :         35 : }
    2781                 :            : 
    2782                 :            : 
    2783                 :            : gfc_expr *
    2784                 :        246 : gfc_simplify_erfc_scaled (gfc_expr *x)
    2785                 :            : {
    2786                 :        246 :   gfc_expr *result;
    2787                 :            : 
    2788                 :        246 :   if (x->expr_type != EXPR_CONSTANT)
    2789                 :            :     return NULL;
    2790                 :            : 
    2791                 :        124 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    2792                 :        124 :   if (mpfr_cmp_d (x->value.real, ARG_LIMIT) >= 0)
    2793                 :         35 :     asympt_erfc_scaled (result->value.real, x->value.real);
    2794                 :            :   else
    2795                 :         89 :     fullprec_erfc_scaled (result->value.real, x->value.real);
    2796                 :            : 
    2797                 :        124 :   return range_check (result, "ERFC_SCALED");
    2798                 :            : }
    2799                 :            : 
    2800                 :            : #undef MAX_ITER
    2801                 :            : #undef ARG_LIMIT
    2802                 :            : 
    2803                 :            : 
    2804                 :            : gfc_expr *
    2805                 :       3580 : gfc_simplify_epsilon (gfc_expr *e)
    2806                 :            : {
    2807                 :       3580 :   gfc_expr *result;
    2808                 :       3580 :   int i;
    2809                 :            : 
    2810                 :       3580 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    2811                 :            : 
    2812                 :       3580 :   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
    2813                 :       3580 :   mpfr_set (result->value.real, gfc_real_kinds[i].epsilon, GFC_RND_MODE);
    2814                 :            : 
    2815                 :       3580 :   return range_check (result, "EPSILON");
    2816                 :            : }
    2817                 :            : 
    2818                 :            : 
    2819                 :            : gfc_expr *
    2820                 :       1052 : gfc_simplify_exp (gfc_expr *x)
    2821                 :            : {
    2822                 :       1052 :   gfc_expr *result;
    2823                 :            : 
    2824                 :       1052 :   if (x->expr_type != EXPR_CONSTANT)
    2825                 :            :     return NULL;
    2826                 :            : 
    2827                 :        139 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    2828                 :            : 
    2829                 :        139 :   switch (x->ts.type)
    2830                 :            :     {
    2831                 :         82 :       case BT_REAL:
    2832                 :         82 :         mpfr_exp (result->value.real, x->value.real, GFC_RND_MODE);
    2833                 :         82 :         break;
    2834                 :            : 
    2835                 :         57 :       case BT_COMPLEX:
    2836                 :         57 :         gfc_set_model_kind (x->ts.kind);
    2837                 :         57 :         mpc_exp (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    2838                 :         57 :         break;
    2839                 :            : 
    2840                 :          0 :       default:
    2841                 :          0 :         gfc_internal_error ("in gfc_simplify_exp(): Bad type");
    2842                 :            :     }
    2843                 :            : 
    2844                 :        139 :   return range_check (result, "EXP");
    2845                 :            : }
    2846                 :            : 
    2847                 :            : 
    2848                 :            : gfc_expr *
    2849                 :        768 : gfc_simplify_exponent (gfc_expr *x)
    2850                 :            : {
    2851                 :        768 :   long int val;
    2852                 :        768 :   gfc_expr *result;
    2853                 :            : 
    2854                 :        768 :   if (x->expr_type != EXPR_CONSTANT)
    2855                 :            :     return NULL;
    2856                 :            : 
    2857                 :        150 :   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    2858                 :            :                                   &x->where);
    2859                 :            : 
    2860                 :            :   /* EXPONENT(inf) = EXPONENT(nan) = HUGE(0) */
    2861                 :        150 :   if (mpfr_inf_p (x->value.real) || mpfr_nan_p (x->value.real))
    2862                 :            :     {
    2863                 :         18 :       int i = gfc_validate_kind (BT_INTEGER, gfc_default_integer_kind, false);
    2864                 :         18 :       mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
    2865                 :         18 :       return result;
    2866                 :            :     }
    2867                 :            : 
    2868                 :            :   /* EXPONENT(+/- 0.0) = 0  */
    2869                 :        132 :   if (mpfr_zero_p (x->value.real))
    2870                 :            :     {
    2871                 :         12 :       mpz_set_ui (result->value.integer, 0);
    2872                 :         12 :       return result;
    2873                 :            :     }
    2874                 :            : 
    2875                 :        120 :   gfc_set_model (x->value.real);
    2876                 :            : 
    2877                 :        120 :   val = (long int) mpfr_get_exp (x->value.real);
    2878                 :        120 :   mpz_set_si (result->value.integer, val);
    2879                 :            : 
    2880                 :        120 :   return range_check (result, "EXPONENT");
    2881                 :            : }
    2882                 :            : 
    2883                 :            : 
    2884                 :            : gfc_expr *
    2885                 :         60 : gfc_simplify_failed_or_stopped_images (gfc_expr *team ATTRIBUTE_UNUSED,
    2886                 :            :                                        gfc_expr *kind)
    2887                 :            : {
    2888                 :         60 :   if (flag_coarray == GFC_FCOARRAY_NONE)
    2889                 :            :     {
    2890                 :          0 :       gfc_current_locus = *gfc_current_intrinsic_where;
    2891                 :          0 :       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    2892                 :            :       return &gfc_bad_expr;
    2893                 :            :     }
    2894                 :            : 
    2895                 :         60 :   if (flag_coarray == GFC_FCOARRAY_SINGLE)
    2896                 :            :     {
    2897                 :         12 :       gfc_expr *result;
    2898                 :         12 :       int actual_kind;
    2899                 :         12 :       if (kind)
    2900                 :          8 :         gfc_extract_int (kind, &actual_kind);
    2901                 :            :       else
    2902                 :          4 :         actual_kind = gfc_default_integer_kind;
    2903                 :            : 
    2904                 :         12 :       result = gfc_get_array_expr (BT_INTEGER, actual_kind, &gfc_current_locus);
    2905                 :         12 :       result->rank = 1;
    2906                 :         12 :       return result;
    2907                 :            :     }
    2908                 :            : 
    2909                 :            :   /* For fcoarray = lib no simplification is possible, because it is not known
    2910                 :            :      what images failed or are stopped at compile time.  */
    2911                 :            :   return NULL;
    2912                 :            : }
    2913                 :            : 
    2914                 :            : 
    2915                 :            : gfc_expr *
    2916                 :          0 : gfc_simplify_get_team (gfc_expr *level ATTRIBUTE_UNUSED)
    2917                 :            : {
    2918                 :          0 :   if (flag_coarray == GFC_FCOARRAY_NONE)
    2919                 :            :     {
    2920                 :          0 :       gfc_current_locus = *gfc_current_intrinsic_where;
    2921                 :          0 :       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    2922                 :            :       return &gfc_bad_expr;
    2923                 :            :     }
    2924                 :            : 
    2925                 :          0 :   if (flag_coarray == GFC_FCOARRAY_SINGLE)
    2926                 :            :     {
    2927                 :          0 :       gfc_expr *result;
    2928                 :          0 :       result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus);
    2929                 :          0 :       result->rank = 0;
    2930                 :          0 :       return result;
    2931                 :            :     }
    2932                 :            : 
    2933                 :            :   /* For fcoarray = lib no simplification is possible, because it is not known
    2934                 :            :      what images failed or are stopped at compile time.  */
    2935                 :            :   return NULL;
    2936                 :            : }
    2937                 :            : 
    2938                 :            : 
    2939                 :            : gfc_expr *
    2940                 :        764 : gfc_simplify_float (gfc_expr *a)
    2941                 :            : {
    2942                 :        764 :   gfc_expr *result;
    2943                 :            : 
    2944                 :        764 :   if (a->expr_type != EXPR_CONSTANT)
    2945                 :            :     return NULL;
    2946                 :            : 
    2947                 :        492 :   result = gfc_int2real (a, gfc_default_real_kind);
    2948                 :            : 
    2949                 :        492 :   return range_check (result, "FLOAT");
    2950                 :            : }
    2951                 :            : 
    2952                 :            : 
    2953                 :            : static bool
    2954                 :       1714 : is_last_ref_vtab (gfc_expr *e)
    2955                 :            : {
    2956                 :       1714 :   gfc_ref *ref;
    2957                 :       1714 :   gfc_component *comp = NULL;
    2958                 :            : 
    2959                 :       1714 :   if (e->expr_type != EXPR_VARIABLE)
    2960                 :            :     return false;
    2961                 :            : 
    2962                 :       2188 :   for (ref = e->ref; ref; ref = ref->next)
    2963                 :        492 :     if (ref->type == REF_COMPONENT)
    2964                 :         96 :       comp = ref->u.c.component;
    2965                 :            : 
    2966                 :       1696 :   if (!e->ref || !comp)
    2967                 :       1600 :     return e->symtree->n.sym->attr.vtab;
    2968                 :            : 
    2969                 :         96 :   if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
    2970                 :         66 :     return true;
    2971                 :            : 
    2972                 :            :   return false;
    2973                 :            : }
    2974                 :            : 
    2975                 :            : 
    2976                 :            : gfc_expr *
    2977                 :        376 : gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
    2978                 :            : {
    2979                 :            :   /* Avoid simplification of resolved symbols.  */
    2980                 :        376 :   if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
    2981                 :            :     return NULL;
    2982                 :            : 
    2983                 :        240 :   if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
    2984                 :         27 :     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    2985                 :         27 :                                  gfc_type_is_extension_of (mold->ts.u.derived,
    2986                 :         27 :                                                            a->ts.u.derived));
    2987                 :            : 
    2988                 :        213 :   if (UNLIMITED_POLY (a) || UNLIMITED_POLY (mold))
    2989                 :            :     return NULL;
    2990                 :            : 
    2991                 :            :   /* Return .false. if the dynamic type can never be an extension.  */
    2992                 :         89 :   if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
    2993                 :         25 :        && !gfc_type_is_extension_of
    2994                 :         25 :                         (mold->ts.u.derived->components->ts.u.derived,
    2995                 :         25 :                          a->ts.u.derived->components->ts.u.derived)
    2996                 :          5 :        && !gfc_type_is_extension_of
    2997                 :          5 :                         (a->ts.u.derived->components->ts.u.derived,
    2998                 :          5 :                          mold->ts.u.derived->components->ts.u.derived))
    2999                 :        113 :       || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
    3000                 :         27 :           && !gfc_type_is_extension_of
    3001                 :         28 :                         (mold->ts.u.derived->components->ts.u.derived,
    3002                 :            :                          a->ts.u.derived))
    3003                 :        224 :       || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
    3004                 :         64 :           && !gfc_type_is_extension_of
    3005                 :         64 :                         (mold->ts.u.derived,
    3006                 :         64 :                          a->ts.u.derived->components->ts.u.derived)
    3007                 :         19 :           && !gfc_type_is_extension_of
    3008                 :         19 :                         (a->ts.u.derived->components->ts.u.derived,
    3009                 :            :                          mold->ts.u.derived)))
    3010                 :         13 :     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
    3011                 :            : 
    3012                 :            :   /* Return .true. if the dynamic type is guaranteed to be an extension.  */
    3013                 :         81 :   if (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
    3014                 :        163 :       && gfc_type_is_extension_of (mold->ts.u.derived,
    3015                 :         60 :                                    a->ts.u.derived->components->ts.u.derived))
    3016                 :         45 :     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
    3017                 :            : 
    3018                 :            :   return NULL;
    3019                 :            : }
    3020                 :            : 
    3021                 :            : 
    3022                 :            : gfc_expr *
    3023                 :        549 : gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
    3024                 :            : {
    3025                 :            :   /* Avoid simplification of resolved symbols.  */
    3026                 :        549 :   if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
    3027                 :            :     return NULL;
    3028                 :            : 
    3029                 :            :   /* Return .false. if the dynamic type can never be the
    3030                 :            :      same.  */
    3031                 :        447 :   if (((a->ts.type == BT_CLASS && gfc_expr_attr (a).class_ok)
    3032                 :        103 :        || (b->ts.type == BT_CLASS && gfc_expr_attr (b).class_ok))
    3033                 :        530 :       && !gfc_type_compatible (&a->ts, &b->ts)
    3034                 :        579 :       && !gfc_type_compatible (&b->ts, &a->ts))
    3035                 :          6 :     return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
    3036                 :            : 
    3037                 :        543 :   if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
    3038                 :            :      return NULL;
    3039                 :            : 
    3040                 :         18 :   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    3041                 :         18 :                                gfc_compare_derived_types (a->ts.u.derived,
    3042                 :         18 :                                                           b->ts.u.derived));
    3043                 :            : }
    3044                 :            : 
    3045                 :            : 
    3046                 :            : gfc_expr *
    3047                 :        290 : gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
    3048                 :            : {
    3049                 :        290 :   gfc_expr *result;
    3050                 :        290 :   mpfr_t floor;
    3051                 :        290 :   int kind;
    3052                 :            : 
    3053                 :        290 :   kind = get_kind (BT_INTEGER, k, "FLOOR", gfc_default_integer_kind);
    3054                 :        290 :   if (kind == -1)
    3055                 :          0 :     gfc_internal_error ("gfc_simplify_floor(): Bad kind");
    3056                 :            : 
    3057                 :        290 :   if (e->expr_type != EXPR_CONSTANT)
    3058                 :            :     return NULL;
    3059                 :            : 
    3060                 :         24 :   mpfr_init2 (floor, mpfr_get_prec (e->value.real));
    3061                 :         24 :   mpfr_floor (floor, e->value.real);
    3062                 :            : 
    3063                 :         24 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
    3064                 :         24 :   gfc_mpfr_to_mpz (result->value.integer, floor, &e->where);
    3065                 :            : 
    3066                 :         24 :   mpfr_clear (floor);
    3067                 :            : 
    3068                 :         24 :   return range_check (result, "FLOOR");
    3069                 :            : }
    3070                 :            : 
    3071                 :            : 
    3072                 :            : gfc_expr *
    3073                 :        180 : gfc_simplify_fraction (gfc_expr *x)
    3074                 :            : {
    3075                 :        180 :   gfc_expr *result;
    3076                 :        180 :   mpfr_exp_t e;
    3077                 :            : 
    3078                 :        180 :   if (x->expr_type != EXPR_CONSTANT)
    3079                 :            :     return NULL;
    3080                 :            : 
    3081                 :         84 :   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
    3082                 :            : 
    3083                 :            :   /* FRACTION(inf) = NaN.  */
    3084                 :         84 :   if (mpfr_inf_p (x->value.real))
    3085                 :            :     {
    3086                 :         12 :       mpfr_set_nan (result->value.real);
    3087                 :         12 :       return result;
    3088                 :            :     }
    3089                 :            : 
    3090                 :            :   /* mpfr_frexp() correctly handles zeros and NaNs.  */
    3091                 :         72 :   mpfr_frexp (&e, result->value.real, x->value.real, GFC_RND_MODE);
    3092                 :            : 
    3093                 :         72 :   return range_check (result, "FRACTION");
    3094                 :            : }
    3095                 :            : 
    3096                 :            : 
    3097                 :            : gfc_expr *
    3098                 :        153 : gfc_simplify_gamma (gfc_expr *x)
    3099                 :            : {
    3100                 :        153 :   gfc_expr *result;
    3101                 :            : 
    3102                 :        153 :   if (x->expr_type != EXPR_CONSTANT)
    3103                 :            :     return NULL;
    3104                 :            : 
    3105                 :         54 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    3106                 :         54 :   mpfr_gamma (result->value.real, x->value.real, GFC_RND_MODE);
    3107                 :            : 
    3108                 :         54 :   return range_check (result, "GAMMA");
    3109                 :            : }
    3110                 :            : 
    3111                 :            : 
    3112                 :            : gfc_expr *
    3113                 :       5412 : gfc_simplify_huge (gfc_expr *e)
    3114                 :            : {
    3115                 :       5412 :   gfc_expr *result;
    3116                 :       5412 :   int i;
    3117                 :            : 
    3118                 :       5412 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    3119                 :       5412 :   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    3120                 :            : 
    3121                 :       5412 :   switch (e->ts.type)
    3122                 :            :     {
    3123                 :       4158 :       case BT_INTEGER:
    3124                 :       4158 :         mpz_set (result->value.integer, gfc_integer_kinds[i].huge);
    3125                 :       4158 :         break;
    3126                 :            : 
    3127                 :       1254 :       case BT_REAL:
    3128                 :       1254 :         mpfr_set (result->value.real, gfc_real_kinds[i].huge, GFC_RND_MODE);
    3129                 :       1254 :         break;
    3130                 :            : 
    3131                 :          0 :       default:
    3132                 :          0 :         gcc_unreachable ();
    3133                 :            :     }
    3134                 :            : 
    3135                 :       5412 :   return result;
    3136                 :            : }
    3137                 :            : 
    3138                 :            : 
    3139                 :            : gfc_expr *
    3140                 :         24 : gfc_simplify_hypot (gfc_expr *x, gfc_expr *y)
    3141                 :            : {
    3142                 :         24 :   gfc_expr *result;
    3143                 :            : 
    3144                 :         24 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3145                 :            :     return NULL;
    3146                 :            : 
    3147                 :         12 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    3148                 :         12 :   mpfr_hypot (result->value.real, x->value.real, y->value.real, GFC_RND_MODE);
    3149                 :         12 :   return range_check (result, "HYPOT");
    3150                 :            : }
    3151                 :            : 
    3152                 :            : 
    3153                 :            : /* We use the processor's collating sequence, because all
    3154                 :            :    systems that gfortran currently works on are ASCII.  */
    3155                 :            : 
    3156                 :            : gfc_expr *
    3157                 :       8006 : gfc_simplify_iachar (gfc_expr *e, gfc_expr *kind)
    3158                 :            : {
    3159                 :       8006 :   gfc_expr *result;
    3160                 :       8006 :   gfc_char_t index;
    3161                 :       8006 :   int k;
    3162                 :            : 
    3163                 :       8006 :   if (e->expr_type != EXPR_CONSTANT)
    3164                 :            :     return NULL;
    3165                 :            : 
    3166                 :       4752 :   if (e->value.character.length != 1)
    3167                 :            :     {
    3168                 :          0 :       gfc_error ("Argument of IACHAR at %L must be of length one", &e->where);
    3169                 :          0 :       return &gfc_bad_expr;
    3170                 :            :     }
    3171                 :            : 
    3172                 :       4752 :   index = e->value.character.string[0];
    3173                 :            : 
    3174                 :       4752 :   if (warn_surprising && index > 127)
    3175                 :          1 :     gfc_warning (OPT_Wsurprising,
    3176                 :            :                  "Argument of IACHAR function at %L outside of range 0..127",
    3177                 :            :                  &e->where);
    3178                 :            : 
    3179                 :       4752 :   k = get_kind (BT_INTEGER, kind, "IACHAR", gfc_default_integer_kind);
    3180                 :       4752 :   if (k == -1)
    3181                 :            :     return &gfc_bad_expr;
    3182                 :            : 
    3183                 :       4752 :   result = gfc_get_int_expr (k, &e->where, index);
    3184                 :            : 
    3185                 :       4752 :   return range_check (result, "IACHAR");
    3186                 :            : }
    3187                 :            : 
    3188                 :            : 
    3189                 :            : static gfc_expr *
    3190                 :         24 : do_bit_and (gfc_expr *result, gfc_expr *e)
    3191                 :            : {
    3192                 :         24 :   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
    3193                 :         24 :   gcc_assert (result->ts.type == BT_INTEGER
    3194                 :            :               && result->expr_type == EXPR_CONSTANT);
    3195                 :            : 
    3196                 :         24 :   mpz_and (result->value.integer, result->value.integer, e->value.integer);
    3197                 :         24 :   return result;
    3198                 :            : }
    3199                 :            : 
    3200                 :            : 
    3201                 :            : gfc_expr *
    3202                 :        108 : gfc_simplify_iall (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
    3203                 :            : {
    3204                 :        108 :   return simplify_transformation (array, dim, mask, -1, do_bit_and);
    3205                 :            : }
    3206                 :            : 
    3207                 :            : 
    3208                 :            : static gfc_expr *
    3209                 :         24 : do_bit_ior (gfc_expr *result, gfc_expr *e)
    3210                 :            : {
    3211                 :         24 :   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
    3212                 :         24 :   gcc_assert (result->ts.type == BT_INTEGER
    3213                 :            :               && result->expr_type == EXPR_CONSTANT);
    3214                 :            : 
    3215                 :         24 :   mpz_ior (result->value.integer, result->value.integer, e->value.integer);
    3216                 :         24 :   return result;
    3217                 :            : }
    3218                 :            : 
    3219                 :            : 
    3220                 :            : gfc_expr *
    3221                 :        109 : gfc_simplify_iany (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
    3222                 :            : {
    3223                 :        109 :   return simplify_transformation (array, dim, mask, 0, do_bit_ior);
    3224                 :            : }
    3225                 :            : 
    3226                 :            : 
    3227                 :            : gfc_expr *
    3228                 :       1231 : gfc_simplify_iand (gfc_expr *x, gfc_expr *y)
    3229                 :            : {
    3230                 :       1231 :   gfc_expr *result;
    3231                 :            : 
    3232                 :       1231 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3233                 :            :     return NULL;
    3234                 :            : 
    3235                 :        263 :   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
    3236                 :        263 :   mpz_and (result->value.integer, x->value.integer, y->value.integer);
    3237                 :            : 
    3238                 :        263 :   return range_check (result, "IAND");
    3239                 :            : }
    3240                 :            : 
    3241                 :            : 
    3242                 :            : gfc_expr *
    3243                 :        208 : gfc_simplify_ibclr (gfc_expr *x, gfc_expr *y)
    3244                 :            : {
    3245                 :        208 :   gfc_expr *result;
    3246                 :        208 :   int k, pos;
    3247                 :            : 
    3248                 :        208 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3249                 :            :     return NULL;
    3250                 :            : 
    3251                 :         34 :   gfc_extract_int (y, &pos);
    3252                 :            : 
    3253                 :         34 :   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
    3254                 :            : 
    3255                 :         34 :   result = gfc_copy_expr (x);
    3256                 :            : 
    3257                 :         34 :   convert_mpz_to_unsigned (result->value.integer,
    3258                 :            :                            gfc_integer_kinds[k].bit_size);
    3259                 :            : 
    3260                 :         34 :   mpz_clrbit (result->value.integer, pos);
    3261                 :            : 
    3262                 :         34 :   gfc_convert_mpz_to_signed (result->value.integer,
    3263                 :            :                          gfc_integer_kinds[k].bit_size);
    3264                 :            : 
    3265                 :         34 :   return result;
    3266                 :            : }
    3267                 :            : 
    3268                 :            : 
    3269                 :            : gfc_expr *
    3270                 :         34 : gfc_simplify_ibits (gfc_expr *x, gfc_expr *y, gfc_expr *z)
    3271                 :            : {
    3272                 :         34 :   gfc_expr *result;
    3273                 :         34 :   int pos, len;
    3274                 :         34 :   int i, k, bitsize;
    3275                 :         34 :   int *bits;
    3276                 :            : 
    3277                 :         34 :   if (x->expr_type != EXPR_CONSTANT
    3278                 :          4 :       || y->expr_type != EXPR_CONSTANT
    3279                 :          4 :       || z->expr_type != EXPR_CONSTANT)
    3280                 :            :     return NULL;
    3281                 :            : 
    3282                 :          4 :   gfc_extract_int (y, &pos);
    3283                 :          4 :   gfc_extract_int (z, &len);
    3284                 :            : 
    3285                 :          4 :   k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
    3286                 :            : 
    3287                 :          4 :   bitsize = gfc_integer_kinds[k].bit_size;
    3288                 :            : 
    3289                 :          4 :   if (pos + len > bitsize)
    3290                 :            :     {
    3291                 :          0 :       gfc_error ("Sum of second and third arguments of IBITS exceeds "
    3292                 :            :                  "bit size at %L", &y->where);
    3293                 :          0 :       return &gfc_bad_expr;
    3294                 :            :     }
    3295                 :            : 
    3296                 :          4 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    3297                 :          4 :   convert_mpz_to_unsigned (result->value.integer,
    3298                 :            :                            gfc_integer_kinds[k].bit_size);
    3299                 :            : 
    3300                 :          4 :   bits = XCNEWVEC (int, bitsize);
    3301                 :            : 
    3302                 :        164 :   for (i = 0; i < bitsize; i++)
    3303                 :        160 :     bits[i] = 0;
    3304                 :            : 
    3305                 :         24 :   for (i = 0; i < len; i++)
    3306                 :         20 :     bits[i] = mpz_tstbit (x->value.integer, i + pos);
    3307                 :            : 
    3308                 :        164 :   for (i = 0; i < bitsize; i++)
    3309                 :            :     {
    3310                 :        160 :       if (bits[i] == 0)
    3311                 :        160 :         mpz_clrbit (result->value.integer, i);
    3312                 :          0 :       else if (bits[i] == 1)
    3313                 :          0 :         mpz_setbit (result->value.integer, i);
    3314                 :            :       else
    3315                 :          0 :         gfc_internal_error ("IBITS: Bad bit");
    3316                 :            :     }
    3317                 :            : 
    3318                 :          4 :   free (bits);
    3319                 :            : 
    3320                 :          4 :   gfc_convert_mpz_to_signed (result->value.integer,
    3321                 :            :                          gfc_integer_kinds[k].bit_size);
    3322                 :            : 
    3323                 :          4 :   return result;
    3324                 :            : }
    3325                 :            : 
    3326                 :            : 
    3327                 :            : gfc_expr *
    3328                 :        178 : gfc_simplify_ibset (gfc_expr *x, gfc_expr *y)
    3329                 :            : {
    3330                 :        178 :   gfc_expr *result;
    3331                 :        178 :   int k, pos;
    3332                 :            : 
    3333                 :        178 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3334                 :            :     return NULL;
    3335                 :            : 
    3336                 :         34 :   gfc_extract_int (y, &pos);
    3337                 :            : 
    3338                 :         34 :   k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
    3339                 :            : 
    3340                 :         34 :   result = gfc_copy_expr (x);
    3341                 :            : 
    3342                 :         34 :   convert_mpz_to_unsigned (result->value.integer,
    3343                 :            :                            gfc_integer_kinds[k].bit_size);
    3344                 :            : 
    3345                 :         34 :   mpz_setbit (result->value.integer, pos);
    3346                 :            : 
    3347                 :         34 :   gfc_convert_mpz_to_signed (result->value.integer,
    3348                 :            :                          gfc_integer_kinds[k].bit_size);
    3349                 :            : 
    3350                 :         34 :   return result;
    3351                 :            : }
    3352                 :            : 
    3353                 :            : 
    3354                 :            : gfc_expr *
    3355                 :       2832 : gfc_simplify_ichar (gfc_expr *e, gfc_expr *kind)
    3356                 :            : {
    3357                 :       2832 :   gfc_expr *result;
    3358                 :       2832 :   gfc_char_t index;
    3359                 :       2832 :   int k;
    3360                 :            : 
    3361                 :       2832 :   if (e->expr_type != EXPR_CONSTANT)
    3362                 :            :     return NULL;
    3363                 :            : 
    3364                 :       1848 :   if (e->value.character.length != 1)
    3365                 :            :     {
    3366                 :          2 :       gfc_error ("Argument of ICHAR at %L must be of length one", &e->where);
    3367                 :          2 :       return &gfc_bad_expr;
    3368                 :            :     }
    3369                 :            : 
    3370                 :       1846 :   index = e->value.character.string[0];
    3371                 :            : 
    3372                 :       1846 :   k = get_kind (BT_INTEGER, kind, "ICHAR", gfc_default_integer_kind);
    3373                 :       1846 :   if (k == -1)
    3374                 :            :     return &gfc_bad_expr;
    3375                 :            : 
    3376                 :       1846 :   result = gfc_get_int_expr (k, &e->where, index);
    3377                 :            : 
    3378                 :       1846 :   return range_check (result, "ICHAR");
    3379                 :            : }
    3380                 :            : 
    3381                 :            : 
    3382                 :            : gfc_expr *
    3383                 :       1239 : gfc_simplify_ieor (gfc_expr *x, gfc_expr *y)
    3384                 :            : {
    3385                 :       1239 :   gfc_expr *result;
    3386                 :            : 
    3387                 :       1239 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3388                 :            :     return NULL;
    3389                 :            : 
    3390                 :         29 :   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
    3391                 :         29 :   mpz_xor (result->value.integer, x->value.integer, y->value.integer);
    3392                 :            : 
    3393                 :         29 :   return range_check (result, "IEOR");
    3394                 :            : }
    3395                 :            : 
    3396                 :            : 
    3397                 :            : gfc_expr *
    3398                 :        891 : gfc_simplify_index (gfc_expr *x, gfc_expr *y, gfc_expr *b, gfc_expr *kind)
    3399                 :            : {
    3400                 :        891 :   gfc_expr *result;
    3401                 :        891 :   int back, len, lensub;
    3402                 :        891 :   int i, j, k, count, index = 0, start;
    3403                 :            : 
    3404                 :        891 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT
    3405                 :        261 :       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
    3406                 :            :     return NULL;
    3407                 :            : 
    3408                 :        249 :   if (b != NULL && b->value.logical != 0)
    3409                 :            :     back = 1;
    3410                 :            :   else
    3411                 :        168 :     back = 0;
    3412                 :            : 
    3413                 :        249 :   k = get_kind (BT_INTEGER, kind, "INDEX", gfc_default_integer_kind);
    3414                 :        249 :   if (k == -1)
    3415                 :            :     return &gfc_bad_expr;
    3416                 :            : 
    3417                 :        249 :   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
    3418                 :            : 
    3419                 :        249 :   len = x->value.character.length;
    3420                 :        249 :   lensub = y->value.character.length;
    3421                 :            : 
    3422                 :        249 :   if (len < lensub)
    3423                 :            :     {
    3424                 :         12 :       mpz_set_si (result->value.integer, 0);
    3425                 :         12 :       return result;
    3426                 :            :     }
    3427                 :            : 
    3428                 :        237 :   if (back == 0)
    3429                 :            :     {
    3430                 :        156 :       if (lensub == 0)
    3431                 :            :         {
    3432                 :         12 :           mpz_set_si (result->value.integer, 1);
    3433                 :         12 :           return result;
    3434                 :            :         }
    3435                 :        144 :       else if (lensub == 1)
    3436                 :            :         {
    3437                 :        183 :           for (i = 0; i < len; i++)
    3438                 :            :             {
    3439                 :        315 :               for (j = 0; j < lensub; j++)
    3440                 :            :                 {
    3441                 :        183 :                   if (y->value.character.string[j]
    3442                 :        183 :                       == x->value.character.string[i])
    3443                 :            :                     {
    3444                 :         51 :                       index = i + 1;
    3445                 :         51 :                       goto done;
    3446                 :            :                     }
    3447                 :            :                 }
    3448                 :            :             }
    3449                 :            :         }
    3450                 :            :       else
    3451                 :            :         {
    3452                 :        546 :           for (i = 0; i < len; i++)
    3453                 :            :             {
    3454                 :       1893 :               for (j = 0; j < lensub; j++)
    3455                 :            :                 {
    3456                 :       1440 :                   if (y->value.character.string[j]
    3457                 :       1440 :                       == x->value.character.string[i])
    3458                 :            :                     {
    3459                 :        768 :                       start = i;
    3460                 :            :                       count = 0;
    3461                 :            : 
    3462                 :        768 :                       for (k = 0; k < lensub; k++)
    3463                 :            :                         {
    3464                 :        639 :                           if (y->value.character.string[k]
    3465                 :        639 :                               == x->value.character.string[k + start])
    3466                 :        543 :                             count++;
    3467                 :            :                         }
    3468                 :            : 
    3469                 :        129 :                       if (count == lensub)
    3470                 :            :                         {
    3471                 :         81 :                           index = start + 1;
    3472                 :         81 :                           goto done;
    3473                 :            :                         }
    3474                 :            :                     }
    3475                 :            :                 }
    3476                 :            :             }
    3477                 :            :         }
    3478                 :            : 
    3479                 :            :     }
    3480                 :            :   else
    3481                 :            :     {
    3482                 :         81 :       if (lensub == 0)
    3483                 :            :         {
    3484                 :         12 :           mpz_set_si (result->value.integer, len + 1);
    3485                 :         12 :           return result;
    3486                 :            :         }
    3487                 :         69 :       else if (lensub == 1)
    3488                 :            :         {
    3489                 :         36 :           for (i = 0; i < len; i++)
    3490                 :            :             {
    3491                 :         63 :               for (j = 0; j < lensub; j++)
    3492                 :            :                 {
    3493                 :         36 :                   if (y->value.character.string[j]
    3494                 :         36 :                       == x->value.character.string[len - i])
    3495                 :            :                     {
    3496                 :          9 :                       index = len - i + 1;
    3497                 :          9 :                       goto done;
    3498                 :            :                     }
    3499                 :            :                 }
    3500                 :            :             }
    3501                 :            :         }
    3502                 :            :       else
    3503                 :            :         {
    3504                 :        612 :           for (i = 0; i < len; i++)
    3505                 :            :             {
    3506                 :       2256 :               for (j = 0; j < lensub; j++)
    3507                 :            :                 {
    3508                 :       1704 :                   if (y->value.character.string[j]
    3509                 :       1704 :                       == x->value.character.string[len - i])
    3510                 :            :                     {
    3511                 :        222 :                       start = len - i;
    3512                 :        222 :                       if (start <= len - lensub)
    3513                 :            :                         {
    3514                 :            :                           count = 0;
    3515                 :        672 :                           for (k = 0; k < lensub; k++)
    3516                 :        504 :                             if (y->value.character.string[k]
    3517                 :        504 :                                 == x->value.character.string[k + start])
    3518                 :        192 :                               count++;
    3519                 :            : 
    3520                 :        168 :                           if (count == lensub)
    3521                 :            :                             {
    3522                 :         48 :                               index = start + 1;
    3523                 :         48 :                               goto done;
    3524                 :            :                             }
    3525                 :            :                         }
    3526                 :            :                       else
    3527                 :            :                         {
    3528                 :         54 :                           continue;
    3529                 :            :                         }
    3530                 :            :                     }
    3531                 :            :                 }
    3532                 :            :             }
    3533                 :            :         }
    3534                 :            :     }
    3535                 :            : 
    3536                 :         12 : done:
    3537                 :        213 :   mpz_set_si (result->value.integer, index);
    3538                 :        213 :   return range_check (result, "INDEX");
    3539                 :            : }
    3540                 :            : 
    3541                 :            : 
    3542                 :            : static gfc_expr *
    3543                 :       3441 : simplify_intconv (gfc_expr *e, int kind, const char *name)
    3544                 :            : {
    3545                 :       3441 :   gfc_expr *result = NULL;
    3546                 :       3441 :   int tmp1, tmp2;
    3547                 :            : 
    3548                 :            :   /* Convert BOZ to integer, and return without range checking.  */
    3549                 :       3441 :   if (e->ts.type == BT_BOZ)
    3550                 :            :     {
    3551                 :       1316 :       if (!gfc_boz2int (e, kind))
    3552                 :            :         return NULL;
    3553                 :       1316 :       result = gfc_copy_expr (e);
    3554                 :       1316 :       return result;
    3555                 :            :     }
    3556                 :            : 
    3557                 :       2125 :   if (e->expr_type != EXPR_CONSTANT)
    3558                 :            :     return NULL;
    3559                 :            : 
    3560                 :            :   /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
    3561                 :            :      warnings.  */
    3562                 :        869 :   tmp1 = warn_conversion;
    3563                 :        869 :   tmp2 = warn_conversion_extra;
    3564                 :        869 :   warn_conversion = warn_conversion_extra = 0;
    3565                 :            : 
    3566                 :        869 :   result = gfc_convert_constant (e, BT_INTEGER, kind);
    3567                 :            : 
    3568                 :        869 :   warn_conversion = tmp1;
    3569                 :        869 :   warn_conversion_extra = tmp2;
    3570                 :            : 
    3571                 :        869 :   if (result == &gfc_bad_expr)
    3572                 :            :     return &gfc_bad_expr;
    3573                 :            : 
    3574                 :        869 :   return range_check (result, name);
    3575                 :            : }
    3576                 :            : 
    3577                 :            : 
    3578                 :            : gfc_expr *
    3579                 :       3388 : gfc_simplify_int (gfc_expr *e, gfc_expr *k)
    3580                 :            : {
    3581                 :       3388 :   int kind;
    3582                 :            : 
    3583                 :       3388 :   kind = get_kind (BT_INTEGER, k, "INT", gfc_default_integer_kind);
    3584                 :       3388 :   if (kind == -1)
    3585                 :            :     return &gfc_bad_expr;
    3586                 :            : 
    3587                 :       3388 :   return simplify_intconv (e, kind, "INT");
    3588                 :            : }
    3589                 :            : 
    3590                 :            : gfc_expr *
    3591                 :         30 : gfc_simplify_int2 (gfc_expr *e)
    3592                 :            : {
    3593                 :         30 :   return simplify_intconv (e, 2, "INT2");
    3594                 :            : }
    3595                 :            : 
    3596                 :            : 
    3597                 :            : gfc_expr *
    3598                 :         23 : gfc_simplify_int8 (gfc_expr *e)
    3599                 :            : {
    3600                 :         23 :   return simplify_intconv (e, 8, "INT8");
    3601                 :            : }
    3602                 :            : 
    3603                 :            : 
    3604                 :            : gfc_expr *
    3605                 :          0 : gfc_simplify_long (gfc_expr *e)
    3606                 :            : {
    3607                 :          0 :   return simplify_intconv (e, 4, "LONG");
    3608                 :            : }
    3609                 :            : 
    3610                 :            : 
    3611                 :            : gfc_expr *
    3612                 :        804 : gfc_simplify_ifix (gfc_expr *e)
    3613                 :            : {
    3614                 :        804 :   gfc_expr *rtrunc, *result;
    3615                 :            : 
    3616                 :        804 :   if (e->expr_type != EXPR_CONSTANT)
    3617                 :            :     return NULL;
    3618                 :            : 
    3619                 :        104 :   rtrunc = gfc_copy_expr (e);
    3620                 :        104 :   mpfr_trunc (rtrunc->value.real, e->value.real);
    3621                 :            : 
    3622                 :        104 :   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    3623                 :            :                                   &e->where);
    3624                 :        104 :   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
    3625                 :            : 
    3626                 :        104 :   gfc_free_expr (rtrunc);
    3627                 :            : 
    3628                 :        104 :   return range_check (result, "IFIX");
    3629                 :            : }
    3630                 :            : 
    3631                 :            : 
    3632                 :            : gfc_expr *
    3633                 :        422 : gfc_simplify_idint (gfc_expr *e)
    3634                 :            : {
    3635                 :        422 :   gfc_expr *rtrunc, *result;
    3636                 :            : 
    3637                 :        422 :   if (e->expr_type != EXPR_CONSTANT)
    3638                 :            :     return NULL;
    3639                 :            : 
    3640                 :         40 :   rtrunc = gfc_copy_expr (e);
    3641                 :         40 :   mpfr_trunc (rtrunc->value.real, e->value.real);
    3642                 :            : 
    3643                 :         40 :   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    3644                 :            :                                   &e->where);
    3645                 :         40 :   gfc_mpfr_to_mpz (result->value.integer, rtrunc->value.real, &e->where);
    3646                 :            : 
    3647                 :         40 :   gfc_free_expr (rtrunc);
    3648                 :            : 
    3649                 :         40 :   return range_check (result, "IDINT");
    3650                 :            : }
    3651                 :            : 
    3652                 :            : 
    3653                 :            : gfc_expr *
    3654                 :       3831 : gfc_simplify_ior (gfc_expr *x, gfc_expr *y)
    3655                 :            : {
    3656                 :       3831 :   gfc_expr *result;
    3657                 :            : 
    3658                 :       3831 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    3659                 :            :     return NULL;
    3660                 :            : 
    3661                 :       3013 :   result = gfc_get_constant_expr (BT_INTEGER, x->ts.kind, &x->where);
    3662                 :       3013 :   mpz_ior (result->value.integer, x->value.integer, y->value.integer);
    3663                 :            : 
    3664                 :       3013 :   return range_check (result, "IOR");
    3665                 :            : }
    3666                 :            : 
    3667                 :            : 
    3668                 :            : static gfc_expr *
    3669                 :         24 : do_bit_xor (gfc_expr *result, gfc_expr *e)
    3670                 :            : {
    3671                 :         24 :   gcc_assert (e->ts.type == BT_INTEGER && e->expr_type == EXPR_CONSTANT);
    3672                 :         24 :   gcc_assert (result->ts.type == BT_INTEGER
    3673                 :            :               && result->expr_type == EXPR_CONSTANT);
    3674                 :            : 
    3675                 :         24 :   mpz_xor (result->value.integer, result->value.integer, e->value.integer);
    3676                 :         24 :   return result;
    3677                 :            : }
    3678                 :            : 
    3679                 :            : 
    3680                 :            : gfc_expr *
    3681                 :        109 : gfc_simplify_iparity (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
    3682                 :            : {
    3683                 :        109 :   return simplify_transformation (array, dim, mask, 0, do_bit_xor);
    3684                 :            : }
    3685                 :            : 
    3686                 :            : 
    3687                 :            : gfc_expr *
    3688                 :         40 : gfc_simplify_is_iostat_end (gfc_expr *x)
    3689                 :            : {
    3690                 :         40 :   if (x->expr_type != EXPR_CONSTANT)
    3691                 :            :     return NULL;
    3692                 :            : 
    3693                 :         28 :   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
    3694                 :         28 :                                mpz_cmp_si (x->value.integer,
    3695                 :         28 :                                            LIBERROR_END) == 0);
    3696                 :            : }
    3697                 :            : 
    3698                 :            : 
    3699                 :            : gfc_expr *
    3700                 :         52 : gfc_simplify_is_iostat_eor (gfc_expr *x)
    3701                 :            : {
    3702                 :         52 :   if (x->expr_type != EXPR_CONSTANT)
    3703                 :            :     return NULL;
    3704                 :            : 
    3705                 :         16 :   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
    3706                 :         16 :                                mpz_cmp_si (x->value.integer,
    3707                 :         16 :                                            LIBERROR_EOR) == 0);
    3708                 :            : }
    3709                 :            : 
    3710                 :            : 
    3711                 :            : gfc_expr *
    3712                 :       1136 : gfc_simplify_isnan (gfc_expr *x)
    3713                 :            : {
    3714                 :       1136 :   if (x->expr_type != EXPR_CONSTANT)
    3715                 :            :     return NULL;
    3716                 :            : 
    3717                 :        194 :   return gfc_get_logical_expr (gfc_default_logical_kind, &x->where,
    3718                 :        194 :                                mpfr_nan_p (x->value.real));
    3719                 :            : }
    3720                 :            : 
    3721                 :            : 
    3722                 :            : /* Performs a shift on its first argument.  Depending on the last
    3723                 :            :    argument, the shift can be arithmetic, i.e. with filling from the
    3724                 :            :    left like in the SHIFTA intrinsic.  */
    3725                 :            : static gfc_expr *
    3726                 :       8386 : simplify_shift (gfc_expr *e, gfc_expr *s, const char *name,
    3727                 :            :                 bool arithmetic, int direction)
    3728                 :            : {
    3729                 :       8386 :   gfc_expr *result;
    3730                 :       8386 :   int ashift, *bits, i, k, bitsize, shift;
    3731                 :            : 
    3732                 :       8386 :   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
    3733                 :            :     return NULL;
    3734                 :            : 
    3735                 :       7587 :   gfc_extract_int (s, &shift);
    3736                 :            : 
    3737                 :       7587 :   k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
    3738                 :       7587 :   bitsize = gfc_integer_kinds[k].bit_size;
    3739                 :            : 
    3740                 :       7587 :   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    3741                 :            : 
    3742                 :       7587 :   if (shift == 0)
    3743                 :            :     {
    3744                 :       1194 :       mpz_set (result->value.integer, e->value.integer);
    3745                 :       1194 :       return result;
    3746                 :            :     }
    3747                 :            : 
    3748                 :       6393 :   if (direction > 0 && shift < 0)
    3749                 :            :     {
    3750                 :            :       /* Left shift, as in SHIFTL.  */
    3751                 :          0 :       gfc_error ("Second argument of %s is negative at %L", name, &e->where);
    3752                 :          0 :       return &gfc_bad_expr;
    3753                 :            :     }
    3754                 :       6393 :   else if (direction < 0)
    3755                 :            :     {
    3756                 :            :       /* Right shift, as in SHIFTR or SHIFTA.  */
    3757                 :       2778 :       if (shift < 0)
    3758                 :            :         {
    3759                 :          0 :           gfc_error ("Second argument of %s is negative at %L",
    3760                 :            :                      name, &e->where);
    3761                 :          0 :           return &gfc_bad_expr;
    3762                 :            :         }
    3763                 :            : 
    3764                 :       2778 :       shift = -shift;
    3765                 :            :     }
    3766                 :            : 
    3767                 :       6393 :   ashift = (shift >= 0 ? shift : -shift);
    3768                 :            : 
    3769                 :       6393 :   if (ashift > bitsize)
    3770                 :            :     {
    3771                 :          0 :       gfc_error ("Magnitude of second argument of %s exceeds bit size "
    3772                 :            :                  "at %L", name, &e->where);
    3773                 :          0 :       return &gfc_bad_expr;
    3774                 :            :     }
    3775                 :            : 
    3776                 :       6393 :   bits = XCNEWVEC (int, bitsize);
    3777                 :            : 
    3778                 :     314793 :   for (i = 0; i < bitsize; i++)
    3779                 :     308400 :     bits[i] = mpz_tstbit (e->value.integer, i);
    3780                 :            : 
    3781                 :       6393 :   if (shift > 0)
    3782                 :            :     {
    3783                 :            :       /* Left shift.  */
    3784                 :      85308 :       for (i = 0; i < shift; i++)
    3785                 :      81837 :         mpz_clrbit (result->value.integer, i);
    3786                 :            : 
    3787                 :      83586 :       for (i = 0; i < bitsize - shift; i++)
    3788                 :            :         {
    3789                 :      80115 :           if (bits[i] == 0)
    3790                 :      51522 :             mpz_clrbit (result->value.integer, i + shift);
    3791                 :            :           else
    3792                 :      28593 :             mpz_setbit (result->value.integer, i + shift);
    3793                 :            :         }
    3794                 :            :     }
    3795                 :            :   else
    3796                 :            :     {
    3797                 :            :       /* Right shift.  */
    3798                 :       2922 :       if (arithmetic && bits[bitsize - 1])
    3799                 :        456 :         for (i = bitsize - 1; i >= bitsize - ashift; i--)
    3800                 :        414 :           mpz_setbit (result->value.integer, i);
    3801                 :            :       else
    3802                 :      75126 :         for (i = bitsize - 1; i >= bitsize - ashift; i--)
    3803                 :      72246 :           mpz_clrbit (result->value.integer, i);
    3804                 :            : 
    3805                 :      76710 :       for (i = bitsize - 1; i >= ashift; i--)
    3806                 :            :         {
    3807                 :      73788 :           if (bits[i] == 0)
    3808                 :      45390 :             mpz_clrbit (result->value.integer, i - ashift);
    3809                 :            :           else
    3810                 :      28398 :             mpz_setbit (result->value.integer, i - ashift);
    3811                 :            :         }
    3812                 :            :     }
    3813                 :            : 
    3814                 :       6393 :   gfc_convert_mpz_to_signed (result->value.integer, bitsize);
    3815                 :       6393 :   free (bits);
    3816                 :            : 
    3817                 :       6393 :   return result;
    3818                 :            : }
    3819                 :            : 
    3820                 :            : 
    3821                 :            : gfc_expr *
    3822                 :       1588 : gfc_simplify_ishft (gfc_expr *e, gfc_expr *s)
    3823                 :            : {
    3824                 :       1588 :   return simplify_shift (e, s, "ISHFT", false, 0);
    3825                 :            : }
    3826                 :            : 
    3827                 :            : 
    3828                 :            : gfc_expr *
    3829                 :        102 : gfc_simplify_lshift (gfc_expr *e, gfc_expr *s)
    3830                 :            : {
    3831                 :        102 :   return simplify_shift (e, s, "LSHIFT", false, 1);
    3832                 :            : }
    3833                 :            : 
    3834                 :            : 
    3835                 :            : gfc_expr *
    3836                 :         42 : gfc_simplify_rshift (gfc_expr *e, gfc_expr *s)
    3837                 :            : {
    3838                 :         42 :   return simplify_shift (e, s, "RSHIFT", true, -1);
    3839                 :            : }
    3840                 :            : 
    3841                 :            : 
    3842                 :            : gfc_expr *
    3843                 :        270 : gfc_simplify_shifta (gfc_expr *e, gfc_expr *s)
    3844                 :            : {
    3845                 :        270 :   return simplify_shift (e, s, "SHIFTA", true, -1);
    3846                 :            : }
    3847                 :            : 
    3848                 :            : 
    3849                 :            : gfc_expr *
    3850                 :       3246 : gfc_simplify_shiftl (gfc_expr *e, gfc_expr *s)
    3851                 :            : {
    3852                 :       3246 :   return simplify_shift (e, s, "SHIFTL", false, 1);
    3853                 :            : }
    3854                 :            : 
    3855                 :            : 
    3856                 :            : gfc_expr *
    3857                 :       3138 : gfc_simplify_shiftr (gfc_expr *e, gfc_expr *s)
    3858                 :            : {
    3859                 :       3138 :   return simplify_shift (e, s, "SHIFTR", false, -1);
    3860                 :            : }
    3861                 :            : 
    3862                 :            : 
    3863                 :            : gfc_expr *
    3864                 :       1097 : gfc_simplify_ishftc (gfc_expr *e, gfc_expr *s, gfc_expr *sz)
    3865                 :            : {
    3866                 :       1097 :   gfc_expr *result;
    3867                 :       1097 :   int shift, ashift, isize, ssize, delta, k;
    3868                 :       1097 :   int i, *bits;
    3869                 :            : 
    3870                 :       1097 :   if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
    3871                 :            :     return NULL;
    3872                 :            : 
    3873                 :        405 :   gfc_extract_int (s, &shift);
    3874                 :            : 
    3875                 :        405 :   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    3876                 :        405 :   isize = gfc_integer_kinds[k].bit_size;
    3877                 :            : 
    3878                 :        405 :   if (sz != NULL)
    3879                 :            :     {
    3880                 :        213 :       if (sz->expr_type != EXPR_CONSTANT)
    3881                 :            :         return NULL;
    3882                 :            : 
    3883                 :        213 :       gfc_extract_int (sz, &ssize);
    3884                 :            :     }
    3885                 :            :   else
    3886                 :        192 :     ssize = isize;
    3887                 :            : 
    3888                 :        405 :   if (shift >= 0)
    3889                 :            :     ashift = shift;
    3890                 :            :   else
    3891                 :            :     ashift = -shift;
    3892                 :            : 
    3893                 :        405 :   if (ashift > ssize)
    3894                 :            :     {
    3895                 :          4 :       if (sz == NULL)
    3896                 :          2 :         gfc_error ("Magnitude of second argument of ISHFTC exceeds "
    3897                 :            :                    "BIT_SIZE of first argument at %C");
    3898                 :            :       else
    3899                 :          2 :         gfc_error ("Absolute value of SHIFT shall be less than or equal "
    3900                 :            :                    "to SIZE at %C");
    3901                 :          4 :       return &gfc_bad_expr;
    3902                 :            :     }
    3903                 :            : 
    3904                 :        401 :   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    3905                 :            : 
    3906                 :        401 :   mpz_set (result->value.integer, e->value.integer);
    3907                 :            : 
    3908                 :        401 :   if (shift == 0)
    3909                 :            :     return result;
    3910                 :            : 
    3911                 :        365 :   convert_mpz_to_unsigned (result->value.integer, isize);
    3912                 :            : 
    3913                 :        365 :   bits = XCNEWVEC (int, ssize);
    3914                 :            : 
    3915                 :       6219 :   for (i = 0; i < ssize; i++)
    3916                 :       5854 :     bits[i] = mpz_tstbit (e->value.integer, i);
    3917                 :            : 
    3918                 :        365 :   delta = ssize - ashift;
    3919                 :            : 
    3920                 :        365 :   if (shift > 0)
    3921                 :            :     {
    3922                 :       3642 :       for (i = 0; i < delta; i++)
    3923                 :            :         {
    3924                 :       3373 :           if (bits[i] == 0)
    3925                 :       2244 :             mpz_clrbit (result->value.integer, i + shift);
    3926                 :            :           else
    3927                 :       1129 :             mpz_setbit (result->value.integer, i + shift);
    3928                 :            :         }
    3929                 :            : 
    3930                 :       1070 :       for (i = delta; i < ssize; i++)
    3931                 :            :         {
    3932                 :        801 :           if (bits[i] == 0)
    3933                 :        657 :             mpz_clrbit (result->value.integer, i - delta);
    3934                 :            :           else
    3935                 :        144 :             mpz_setbit (result->value.integer, i - delta);
    3936                 :            :         }
    3937                 :            :     }
    3938                 :            :   else
    3939                 :            :     {
    3940                 :        288 :       for (i = 0; i < ashift; i++)
    3941                 :            :         {
    3942                 :        192 :           if (bits[i] == 0)
    3943                 :         90 :             mpz_clrbit (result->value.integer, i + delta);
    3944                 :            :           else
    3945                 :        102 :             mpz_setbit (result->value.integer, i + delta);
    3946                 :            :         }
    3947                 :            : 
    3948                 :       1584 :       for (i = ashift; i < ssize; i++)
    3949                 :            :         {
    3950                 :       1488 :           if (bits[i] == 0)
    3951                 :        624 :             mpz_clrbit (result->value.integer, i + shift);
    3952                 :            :           else
    3953                 :        864 :             mpz_setbit (result->value.integer, i + shift);
    3954                 :            :         }
    3955                 :            :     }
    3956                 :            : 
    3957                 :        365 :   gfc_convert_mpz_to_signed (result->value.integer, isize);
    3958                 :            : 
    3959                 :        365 :   free (bits);
    3960                 :        365 :   return result;
    3961                 :            : }
    3962                 :            : 
    3963                 :            : 
    3964                 :            : gfc_expr *
    3965                 :       1607 : gfc_simplify_kind (gfc_expr *e)
    3966                 :            : {
    3967                 :       1607 :   return gfc_get_int_expr (gfc_default_integer_kind, NULL, e->ts.kind);
    3968                 :            : }
    3969                 :            : 
    3970                 :            : 
    3971                 :            : static gfc_expr *
    3972                 :      10685 : simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
    3973                 :            :                     gfc_array_spec *as, gfc_ref *ref, bool coarray)
    3974                 :            : {
    3975                 :      10685 :   gfc_expr *l, *u, *result;
    3976                 :      10685 :   int k;
    3977                 :            : 
    3978                 :      18130 :   k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
    3979                 :            :                 gfc_default_integer_kind);
    3980                 :      10685 :   if (k == -1)
    3981                 :            :     return &gfc_bad_expr;
    3982                 :            : 
    3983                 :      10685 :   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
    3984                 :            : 
    3985                 :            :   /* For non-variables, LBOUND(expr, DIM=n) = 1 and
    3986                 :            :      UBOUND(expr, DIM=n) = SIZE(expr, DIM=n).  */
    3987                 :      10685 :   if (!coarray && array->expr_type != EXPR_VARIABLE)
    3988                 :            :     {
    3989                 :       1402 :       if (upper)
    3990                 :            :         {
    3991                 :        770 :           gfc_expr* dim = result;
    3992                 :        770 :           mpz_set_si (dim->value.integer, d);
    3993                 :            : 
    3994                 :        770 :           result = simplify_size (array, dim, k);
    3995                 :        770 :           gfc_free_expr (dim);
    3996                 :        770 :           if (!result)
    3997                 :        339 :             goto returnNull;
    3998                 :            :         }
    3999                 :            :       else
    4000                 :        632 :         mpz_set_si (result->value.integer, 1);
    4001                 :            : 
    4002                 :       1063 :       goto done;
    4003                 :            :     }
    4004                 :            : 
    4005                 :            :   /* Otherwise, we have a variable expression.  */
    4006                 :       9283 :   gcc_assert (array->expr_type == EXPR_VARIABLE);
    4007                 :       9283 :   gcc_assert (as);
    4008                 :            : 
    4009                 :       9283 :   if (!gfc_resolve_array_spec (as, 0))
    4010                 :            :     return NULL;
    4011                 :            : 
    4012                 :            :   /* The last dimension of an assumed-size array is special.  */
    4013                 :       9283 :   if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
    4014                 :       9239 :       || (coarray && d == as->rank + as->corank
    4015                 :        424 :           && (!upper || flag_coarray == GFC_FCOARRAY_SINGLE)))
    4016                 :            :     {
    4017                 :        428 :       if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
    4018                 :            :         {
    4019                 :        280 :           gfc_free_expr (result);
    4020                 :        280 :           return gfc_copy_expr (as->lower[d-1]);
    4021                 :            :         }
    4022                 :            : 
    4023                 :        148 :       goto returnNull;
    4024                 :            :     }
    4025                 :            : 
    4026                 :       8855 :   result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
    4027                 :            : 
    4028                 :            :   /* Then, we need to know the extent of the given dimension.  */
    4029                 :       8855 :   if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
    4030                 :            :     {
    4031                 :       8437 :       gfc_expr *declared_bound;
    4032                 :       8437 :       int empty_bound;
    4033                 :       8437 :       bool constant_lbound, constant_ubound;
    4034                 :            : 
    4035                 :       8437 :       l = as->lower[d-1];
    4036                 :       8437 :       u = as->upper[d-1];
    4037                 :            : 
    4038                 :       8437 :       gcc_assert (l != NULL);
    4039                 :            : 
    4040                 :       8437 :       constant_lbound = l->expr_type == EXPR_CONSTANT;
    4041                 :       8437 :       constant_ubound = u && u->expr_type == EXPR_CONSTANT;
    4042                 :            : 
    4043                 :       8437 :       empty_bound = upper ? 0 : 1;
    4044                 :       8437 :       declared_bound = upper ? u : l;
    4045                 :            : 
    4046                 :       8437 :       if ((!upper && !constant_lbound)
    4047                 :       7758 :           || (upper && !constant_ubound))
    4048                 :       1662 :         goto returnNull;
    4049                 :            : 
    4050                 :       6775 :       if (!coarray)
    4051                 :            :         {
    4052                 :            :           /* For {L,U}BOUND, the value depends on whether the array
    4053                 :            :              is empty.  We can nevertheless simplify if the declared bound
    4054                 :            :              has the same value as that of an empty array, in which case
    4055                 :            :              the result isn't dependent on the array emptyness.  */
    4056                 :       6225 :           if (mpz_cmp_si (declared_bound->value.integer, empty_bound) == 0)
    4057                 :       3260 :             mpz_set_si (result->value.integer, empty_bound);
    4058                 :       2965 :           else if (!constant_lbound || !constant_ubound)
    4059                 :            :             /* Array emptyness can't be determined, we can't simplify.  */
    4060                 :       1441 :             goto returnNull;
    4061                 :       1524 :           else if (mpz_cmp (l->value.integer, u->value.integer) > 0)
    4062                 :         97 :             mpz_set_si (result->value.integer, empty_bound);
    4063                 :            :           else
    4064                 :       1427 :             mpz_set (result->value.integer, declared_bound->value.integer);
    4065                 :            :         }
    4066                 :            :       else
    4067                 :        550 :         mpz_set (result->value.integer, declared_bound->value.integer);
    4068                 :            :     }
    4069                 :            :   else
    4070                 :            :     {
    4071                 :        418 :       if (upper)
    4072                 :            :         {
    4073                 :        216 :           if (!gfc_ref_dimen_size (&ref->u.ar, d - 1, &result->value.integer, NULL))
    4074                 :         72 :             goto returnNull;
    4075                 :            :         }
    4076                 :            :       else
    4077                 :        202 :         mpz_set_si (result->value.integer, (long int) 1);
    4078                 :            :     }
    4079                 :            : 
    4080                 :       6743 : done:
    4081                 :       6743 :   return range_check (result, upper ? "UBOUND" : "LBOUND");
    4082                 :            : 
    4083                 :       3662 : returnNull:
    4084                 :       3662 :   gfc_free_expr (result);
    4085                 :       3662 :   return NULL;
    4086                 :            : }
    4087                 :            : 
    4088                 :            : 
    4089                 :            : static gfc_expr *
    4090                 :      24739 : simplify_bound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
    4091                 :            : {
    4092                 :      24739 :   gfc_ref *ref;
    4093                 :      24739 :   gfc_array_spec *as;
    4094                 :      24739 :   int d;
    4095                 :            : 
    4096                 :      24739 :   if (array->ts.type == BT_CLASS)
    4097                 :            :     return NULL;
    4098                 :            : 
    4099                 :      23629 :   if (array->expr_type != EXPR_VARIABLE)
    4100                 :            :     {
    4101                 :       1224 :       as = NULL;
    4102                 :       1224 :       ref = NULL;
    4103                 :       1224 :       goto done;
    4104                 :            :     }
    4105                 :            : 
    4106                 :            :   /* Follow any component references.  */
    4107                 :      22405 :   as = array->symtree->n.sym->as;
    4108                 :      23125 :   for (ref = array->ref; ref; ref = ref->next)
    4109                 :            :     {
    4110                 :      23125 :       switch (ref->type)
    4111                 :            :         {
    4112                 :      22537 :         case REF_ARRAY:
    4113                 :      22537 :           switch (ref->u.ar.type)
    4114                 :            :             {
    4115                 :        132 :             case AR_ELEMENT:
    4116                 :        132 :               as = NULL;
    4117                 :        132 :               continue;
    4118                 :            : 
    4119                 :      21610 :             case AR_FULL:
    4120                 :            :               /* We're done because 'as' has already been set in the
    4121                 :            :                  previous iteration.  */
    4122                 :      21610 :               goto done;
    4123                 :            : 
    4124                 :            :             case AR_UNKNOWN:
    4125                 :            :               return NULL;
    4126                 :            : 
    4127                 :        795 :             case AR_SECTION:
    4128                 :        795 :               as = ref->u.ar.as;
    4129                 :        795 :               goto done;
    4130                 :            :             }
    4131                 :            : 
    4132                 :          0 :           gcc_unreachable ();
    4133                 :            : 
    4134                 :        588 :         case REF_COMPONENT:
    4135                 :        588 :           as = ref->u.c.component->as;
    4136                 :        588 :           continue;
    4137                 :            : 
    4138                 :          0 :         case REF_SUBSTRING:
    4139                 :          0 :         case REF_INQUIRY:
    4140                 :          0 :           continue;
    4141                 :            :         }
    4142                 :            :     }
    4143                 :            : 
    4144                 :          0 :   gcc_unreachable ();
    4145                 :            : 
    4146                 :      23629 :  done:
    4147                 :            : 
    4148                 :      23629 :   if (as && (as->type == AS_DEFERRED || as->type == AS_ASSUMED_RANK
    4149                 :       8692 :              || (as->type == AS_ASSUMED_SHAPE && upper)))
    4150                 :            :     return NULL;
    4151                 :            : 
    4152                 :       8568 :   gcc_assert (!as
    4153                 :            :               || (as->type != AS_DEFERRED
    4154                 :            :                   && array->expr_type == EXPR_VARIABLE
    4155                 :            :                   && !gfc_expr_attr (array).allocatable
    4156                 :            :                   && !gfc_expr_attr (array).pointer));
    4157                 :            : 
    4158                 :       8568 :   if (dim == NULL)
    4159                 :            :     {
    4160                 :            :       /* Multi-dimensional bounds.  */
    4161                 :       1384 :       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
    4162                 :       1384 :       gfc_expr *e;
    4163                 :       1384 :       int k;
    4164                 :            : 
    4165                 :            :       /* UBOUND(ARRAY) is not valid for an assumed-size array.  */
    4166                 :       1384 :       if (upper && as && as->type == AS_ASSUMED_SIZE)
    4167                 :            :         {
    4168                 :            :           /* An error message will be emitted in
    4169                 :            :              check_assumed_size_reference (resolve.c).  */
    4170                 :            :           return &gfc_bad_expr;
    4171                 :            :         }
    4172                 :            : 
    4173                 :            :       /* Simplify the bounds for each dimension.  */
    4174                 :       3390 :       for (d = 0; d < array->rank; d++)
    4175                 :            :         {
    4176                 :       2331 :           bounds[d] = simplify_bound_dim (array, kind, d + 1, upper, as, ref,
    4177                 :            :                                           false);
    4178                 :       2331 :           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
    4179                 :            :             {
    4180                 :            :               int j;
    4181                 :            : 
    4182                 :        360 :               for (j = 0; j < d; j++)
    4183                 :         36 :                 gfc_free_expr (bounds[j]);
    4184                 :            :               return bounds[d];
    4185                 :            :             }
    4186                 :            :         }
    4187                 :            : 
    4188                 :            :       /* Allocate the result expression.  */
    4189                 :       1656 :       k = get_kind (BT_INTEGER, kind, upper ? "UBOUND" : "LBOUND",
    4190                 :            :                     gfc_default_integer_kind);
    4191                 :       1059 :       if (k == -1)
    4192                 :            :         return &gfc_bad_expr;
    4193                 :            : 
    4194                 :       1059 :       e = gfc_get_array_expr (BT_INTEGER, k, &array->where);
    4195                 :            : 
    4196                 :            :       /* The result is a rank 1 array; its size is the rank of the first
    4197                 :            :          argument to {L,U}BOUND.  */
    4198                 :       1059 :       e->rank = 1;
    4199                 :       1059 :       e->shape = gfc_get_shape (1);
    4200                 :       1059 :       mpz_init_set_ui (e->shape[0], array->rank);
    4201                 :            : 
    4202                 :            :       /* Create the constructor for this array.  */
    4203                 :       3030 :       for (d = 0; d < array->rank; d++)
    4204                 :       1971 :         gfc_constructor_append_expr (&e->value.constructor,
    4205                 :            :                                      bounds[d], &e->where);
    4206                 :            : 
    4207                 :            :       return e;
    4208                 :            :     }
    4209                 :            :   else
    4210                 :            :     {
    4211                 :            :       /* A DIM argument is specified.  */
    4212                 :       7184 :       if (dim->expr_type != EXPR_CONSTANT)
    4213                 :            :         return NULL;
    4214                 :            : 
    4215                 :       7184 :       d = mpz_get_si (dim->value.integer);
    4216                 :            : 
    4217                 :       7184 :       if ((d < 1 || d > array->rank)
    4218                 :       7184 :           || (d == array->rank && as && as->type == AS_ASSUMED_SIZE && upper))
    4219                 :            :         {
    4220                 :          0 :           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
    4221                 :          0 :           return &gfc_bad_expr;
    4222                 :            :         }
    4223                 :            : 
    4224                 :       7184 :       if (as && as->type == AS_ASSUMED_RANK)
    4225                 :            :         return NULL;
    4226                 :            : 
    4227                 :       7184 :       return simplify_bound_dim (array, kind, d, upper, as, ref, false);
    4228                 :            :     }
    4229                 :            : }
    4230                 :            : 
    4231                 :            : 
    4232                 :            : static gfc_expr *
    4233                 :       1416 : simplify_cobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind, int upper)
    4234                 :            : {
    4235                 :       1416 :   gfc_ref *ref;
    4236                 :       1416 :   gfc_array_spec *as;
    4237                 :       1416 :   int d;
    4238                 :            : 
    4239                 :       1416 :   if (array->expr_type != EXPR_VARIABLE)
    4240                 :            :     return NULL;
    4241                 :            : 
    4242                 :            :   /* Follow any component references.  */
    4243                 :        120 :   as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
    4244                 :       1535 :        ? array->ts.u.derived->components->as
    4245                 :       1297 :        : array->symtree->n.sym->as;
    4246                 :       1595 :   for (ref = array->ref; ref; ref = ref->next)
    4247                 :            :     {
    4248                 :       1594 :       switch (ref->type)
    4249                 :            :         {
    4250                 :       1415 :         case REF_ARRAY:
    4251                 :       1415 :           switch (ref->u.ar.type)
    4252                 :            :             {
    4253                 :        319 :             case AR_ELEMENT:
    4254                 :        319 :               if (ref->u.ar.as->corank > 0)
    4255                 :            :                 {
    4256                 :        319 :                   gcc_assert (as == ref->u.ar.as);
    4257                 :        319 :                   goto done;
    4258                 :            :                 }
    4259                 :          0 :               as = NULL;
    4260                 :          0 :               continue;
    4261                 :            : 
    4262                 :       1096 :             case AR_FULL:
    4263                 :            :               /* We're done because 'as' has already been set in the
    4264                 :            :                  previous iteration.  */
    4265                 :       1096 :               goto done;
    4266                 :            : 
    4267                 :            :             case AR_UNKNOWN:
    4268                 :            :               return NULL;
    4269                 :            : 
    4270                 :          0 :             case AR_SECTION:
    4271                 :          0 :               as = ref->u.ar.as;
    4272                 :          0 :               goto done;
    4273                 :            :             }
    4274                 :            : 
    4275                 :          0 :           gcc_unreachable ();
    4276                 :            : 
    4277                 :        179 :         case REF_COMPONENT:
    4278                 :        179 :           as = ref->u.c.component->as;
    4279                 :        179 :           continue;
    4280                 :            : 
    4281                 :          0 :         case REF_SUBSTRING:
    4282                 :          0 :         case REF_INQUIRY:
    4283                 :          0 :           continue;
    4284                 :            :         }
    4285                 :            :     }
    4286                 :            : 
    4287                 :          1 :   if (!as)
    4288                 :          0 :     gcc_unreachable ();
    4289                 :            : 
    4290                 :          1 :  done:
    4291                 :            : 
    4292                 :       1416 :   if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
    4293                 :            :     return NULL;
    4294                 :            : 
    4295                 :        728 :   if (dim == NULL)
    4296                 :            :     {
    4297                 :            :       /* Multi-dimensional cobounds.  */
    4298                 :            :       gfc_expr *bounds[GFC_MAX_DIMENSIONS];
    4299                 :            :       gfc_expr *e;
    4300                 :            :       int k;
    4301                 :            : 
    4302                 :            :       /* Simplify the cobounds for each dimension.  */
    4303                 :        679 :       for (d = 0; d < as->corank; d++)
    4304                 :            :         {
    4305                 :        590 :           bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
    4306                 :            :                                           upper, as, ref, true);
    4307                 :        590 :           if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
    4308                 :            :             {
    4309                 :            :               int j;
    4310                 :            : 
    4311                 :        264 :               for (j = 0; j < d; j++)
    4312                 :        118 :                 gfc_free_expr (bounds[j]);
    4313                 :            :               return bounds[d];
    4314                 :            :             }
    4315                 :            :         }
    4316                 :            : 
    4317                 :            :       /* Allocate the result expression.  */
    4318                 :         89 :       e = gfc_get_expr ();
    4319                 :         89 :       e->where = array->where;
    4320                 :         89 :       e->expr_type = EXPR_ARRAY;
    4321                 :         89 :       e->ts.type = BT_INTEGER;
    4322                 :        156 :       k = get_kind (BT_INTEGER, kind, upper ? "UCOBOUND" : "LCOBOUND",
    4323                 :            :                     gfc_default_integer_kind);
    4324                 :         89 :       if (k == -1)
    4325                 :            :         {
    4326                 :          0 :           gfc_free_expr (e);
    4327                 :          0 :           return &gfc_bad_expr;
    4328                 :            :         }
    4329                 :         89 :       e->ts.kind = k;
    4330                 :            : 
    4331                 :            :       /* The result is a rank 1 array; its size is the rank of the first
    4332                 :            :          argument to {L,U}COBOUND.  */
    4333                 :         89 :       e->rank = 1;
    4334                 :         89 :       e->shape = gfc_get_shape (1);
    4335                 :         89 :       mpz_init_set_ui (e->shape[0], as->corank);
    4336                 :            : 
    4337                 :            :       /* Create the constructor for this array.  */
    4338                 :        415 :       for (d = 0; d < as->corank; d++)
    4339                 :        326 :         gfc_constructor_append_expr (&e->value.constructor,
    4340                 :            :                                      bounds[d], &e->where);
    4341                 :            :       return e;
    4342                 :            :     }
    4343                 :            :   else
    4344                 :            :     {
    4345                 :            :       /* A DIM argument is specified.  */
    4346                 :        493 :       if (dim->expr_type != EXPR_CONSTANT)
    4347                 :            :         return NULL;
    4348                 :            : 
    4349                 :        353 :       d = mpz_get_si (dim->value.integer);
    4350                 :            : 
    4351                 :        353 :       if (d < 1 || d > as->corank)
    4352                 :            :         {
    4353                 :          0 :           gfc_error ("DIM argument at %L is out of bounds", &dim->where);
    4354                 :          0 :           return &gfc_bad_expr;
    4355                 :            :         }
    4356                 :            : 
    4357                 :        353 :       return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
    4358                 :            :     }
    4359                 :            : }
    4360                 :            : 
    4361                 :            : 
    4362                 :            : gfc_expr *
    4363                 :      15655 : gfc_simplify_lbound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
    4364                 :            : {
    4365                 :      15655 :   return simplify_bound (array, dim, kind, 0);
    4366                 :            : }
    4367                 :            : 
    4368                 :            : 
    4369                 :            : gfc_expr *
    4370                 :        491 : gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
    4371                 :            : {
    4372                 :        491 :   return simplify_cobound (array, dim, kind, 0);
    4373                 :            : }
    4374                 :            : 
    4375                 :            : gfc_expr *
    4376                 :        798 : gfc_simplify_leadz (gfc_expr *e)
    4377                 :            : {
    4378                 :        798 :   unsigned long lz, bs;
    4379                 :        798 :   int i;
    4380                 :            : 
    4381                 :        798 :   if (e->expr_type != EXPR_CONSTANT)
    4382                 :            :     return NULL;
    4383                 :            : 
    4384                 :        258 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    4385                 :        258 :   bs = gfc_integer_kinds[i].bit_size;
    4386                 :        258 :   if (mpz_cmp_si (e->value.integer, 0) == 0)
    4387                 :            :     lz = bs;
    4388                 :        222 :   else if (mpz_cmp_si (e->value.integer, 0) < 0)
    4389                 :            :     lz = 0;
    4390                 :            :   else
    4391                 :        132 :     lz = bs - mpz_sizeinbase (e->value.integer, 2);
    4392                 :            : 
    4393                 :        258 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, lz);
    4394                 :            : }
    4395                 :            : 
    4396                 :            : 
    4397                 :            : gfc_expr *
    4398                 :      10503 : gfc_simplify_len (gfc_expr *e, gfc_expr *kind)
    4399                 :            : {
    4400                 :      10503 :   gfc_expr *result;
    4401                 :      10503 :   int k = get_kind (BT_INTEGER, kind, "LEN", gfc_default_integer_kind);
    4402                 :            : 
    4403                 :      10503 :   if (k == -1)
    4404                 :            :     return &gfc_bad_expr;
    4405                 :            : 
    4406                 :      10503 :   if (e->expr_type == EXPR_CONSTANT)
    4407                 :            :     {
    4408                 :        454 :       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
    4409                 :        454 :       mpz_set_si (result->value.integer, e->value.character.length);
    4410                 :        454 :       return range_check (result, "LEN");
    4411                 :            :     }
    4412                 :      10049 :   else if (e->ts.u.cl != NULL && e->ts.u.cl->length != NULL
    4413                 :       3169 :            && e->ts.u.cl->length->expr_type == EXPR_CONSTANT
    4414                 :       1422 :            && e->ts.u.cl->length->ts.type == BT_INTEGER)
    4415                 :            :     {
    4416                 :       1422 :       result = gfc_get_constant_expr (BT_INTEGER, k, &e->where);
    4417                 :       1422 :       mpz_set (result->value.integer, e->ts.u.cl->length->value.integer);
    4418                 :       1422 :       return range_check (result, "LEN");
    4419                 :            :     }
    4420                 :       8627 :   else if (e->expr_type == EXPR_VARIABLE && e->ts.type == BT_CHARACTER
    4421                 :       7069 :            && e->symtree->n.sym
    4422                 :       7069 :            && e->symtree->n.sym->ts.type != BT_DERIVED
    4423                 :       6875 :            && e->symtree->n.sym->assoc && e->symtree->n.sym->assoc->target
    4424                 :        343 :            && e->symtree->n.sym->assoc->target->ts.type == BT_DERIVED
    4425                 :        163 :            && e->symtree->n.sym->assoc->target->symtree->n.sym
    4426                 :        163 :            && UNLIMITED_POLY (e->symtree->n.sym->assoc->target->symtree->n.sym))
    4427                 :            : 
    4428                 :            :     /* The expression in assoc->target points to a ref to the _data component
    4429                 :            :        of the unlimited polymorphic entity.  To get the _len component the last
    4430                 :            :        _data ref needs to be stripped and a ref to the _len component added.  */
    4431                 :        163 :     return gfc_get_len_component (e->symtree->n.sym->assoc->target, k);
    4432                 :            :   else
    4433                 :            :     return NULL;
    4434                 :            : }
    4435                 :            : 
    4436                 :            : 
    4437                 :            : gfc_expr *
    4438                 :       2679 : gfc_simplify_len_trim (gfc_expr *e, gfc_expr *kind)
    4439                 :            : {
    4440                 :       2679 :   gfc_expr *result;
    4441                 :       2679 :   size_t count, len, i;
    4442                 :       2679 :   int k = get_kind (BT_INTEGER, kind, "LEN_TRIM", gfc_default_integer_kind);
    4443                 :            : 
    4444                 :       2679 :   if (k == -1)
    4445                 :            :     return &gfc_bad_expr;
    4446                 :            : 
    4447                 :       2679 :   if (e->expr_type != EXPR_CONSTANT)
    4448                 :            :     return NULL;
    4449                 :            : 
    4450                 :        150 :   len = e->value.character.length;
    4451                 :        735 :   for (count = 0, i = 1; i <= len; i++)
    4452                 :        723 :     if (e->value.character.string[len - i] == ' ')
    4453                 :        585 :       count++;
    4454                 :            :     else
    4455                 :            :       break;
    4456                 :            : 
    4457                 :        150 :   result = gfc_get_int_expr (k, &e->where, len - count);
    4458                 :        150 :   return range_check (result, "LEN_TRIM");
    4459                 :            : }
    4460                 :            : 
    4461                 :            : gfc_expr *
    4462                 :         46 : gfc_simplify_lgamma (gfc_expr *x)
    4463                 :            : {
    4464                 :         46 :   gfc_expr *result;
    4465                 :         46 :   int sg;
    4466                 :            : 
    4467                 :         46 :   if (x->expr_type != EXPR_CONSTANT)
    4468                 :            :     return NULL;
    4469                 :            : 
    4470                 :         42 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    4471                 :         42 :   mpfr_lgamma (result->value.real, &sg, x->value.real, GFC_RND_MODE);
    4472                 :            : 
    4473                 :         42 :   return range_check (result, "LGAMMA");
    4474                 :            : }
    4475                 :            : 
    4476                 :            : 
    4477                 :            : gfc_expr *
    4478                 :         43 : gfc_simplify_lge (gfc_expr *a, gfc_expr *b)
    4479                 :            : {
    4480                 :         43 :   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
    4481                 :            :     return NULL;
    4482                 :            : 
    4483                 :          1 :   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    4484                 :          2 :                                gfc_compare_string (a, b) >= 0);
    4485                 :            : }
    4486                 :            : 
    4487                 :            : 
    4488                 :            : gfc_expr *
    4489                 :         46 : gfc_simplify_lgt (gfc_expr *a, gfc_expr *b)
    4490                 :            : {
    4491                 :         46 :   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
    4492                 :            :     return NULL;
    4493                 :            : 
    4494                 :          1 :   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    4495                 :          2 :                                gfc_compare_string (a, b) > 0);
    4496                 :            : }
    4497                 :            : 
    4498                 :            : 
    4499                 :            : gfc_expr *
    4500                 :         52 : gfc_simplify_lle (gfc_expr *a, gfc_expr *b)
    4501                 :            : {
    4502                 :         52 :   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
    4503                 :            :     return NULL;
    4504                 :            : 
    4505                 :          1 :   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    4506                 :          2 :                                gfc_compare_string (a, b) <= 0);
    4507                 :            : }
    4508                 :            : 
    4509                 :            : 
    4510                 :            : gfc_expr *
    4511                 :         46 : gfc_simplify_llt (gfc_expr *a, gfc_expr *b)
    4512                 :            : {
    4513                 :         46 :   if (a->expr_type != EXPR_CONSTANT || b->expr_type != EXPR_CONSTANT)
    4514                 :            :     return NULL;
    4515                 :            : 
    4516                 :          1 :   return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
    4517                 :          2 :                                gfc_compare_string (a, b) < 0);
    4518                 :            : }
    4519                 :            : 
    4520                 :            : 
    4521                 :            : gfc_expr *
    4522                 :        286 : gfc_simplify_log (gfc_expr *x)
    4523                 :            : {
    4524                 :        286 :   gfc_expr *result;
    4525                 :            : 
    4526                 :        286 :   if (x->expr_type != EXPR_CONSTANT)
    4527                 :            :     return NULL;
    4528                 :            : 
    4529                 :        141 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    4530                 :            : 
    4531                 :        141 :   switch (x->ts.type)
    4532                 :            :     {
    4533                 :         66 :     case BT_REAL:
    4534                 :         66 :       if (mpfr_sgn (x->value.real) <= 0)
    4535                 :            :         {
    4536                 :          0 :           gfc_error ("Argument of LOG at %L cannot be less than or equal "
    4537                 :            :                      "to zero", &x->where);
    4538                 :          0 :           gfc_free_expr (result);
    4539                 :          0 :           return &gfc_bad_expr;
    4540                 :            :         }
    4541                 :            : 
    4542                 :         66 :       mpfr_log (result->value.real, x->value.real, GFC_RND_MODE);
    4543                 :         66 :       break;
    4544                 :            : 
    4545                 :         75 :     case BT_COMPLEX:
    4546                 :         75 :       if (mpfr_zero_p (mpc_realref (x->value.complex))
    4547                 :          0 :           && mpfr_zero_p (mpc_imagref (x->value.complex)))
    4548                 :            :         {
    4549                 :          0 :           gfc_error ("Complex argument of LOG at %L cannot be zero",
    4550                 :            :                      &x->where);
    4551                 :          0 :           gfc_free_expr (result);
    4552                 :          0 :           return &gfc_bad_expr;
    4553                 :            :         }
    4554                 :            : 
    4555                 :         75 :       gfc_set_model_kind (x->ts.kind);
    4556                 :         75 :       mpc_log (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    4557                 :         75 :       break;
    4558                 :            : 
    4559                 :          0 :     default:
    4560                 :          0 :       gfc_internal_error ("gfc_simplify_log: bad type");
    4561                 :            :     }
    4562                 :            : 
    4563                 :        141 :   return range_check (result, "LOG");
    4564                 :            : }
    4565                 :            : 
    4566                 :            : 
    4567                 :            : gfc_expr *
    4568                 :        252 : gfc_simplify_log10 (gfc_expr *x)
    4569                 :            : {
    4570                 :        252 :   gfc_expr *result;
    4571                 :            : 
    4572                 :        252 :   if (x->expr_type != EXPR_CONSTANT)
    4573                 :            :     return NULL;
    4574                 :            : 
    4575                 :         97 :   if (mpfr_sgn (x->value.real) <= 0)
    4576                 :            :     {
    4577                 :          0 :       gfc_error ("Argument of LOG10 at %L cannot be less than or equal "
    4578                 :            :                  "to zero", &x->where);
    4579                 :          0 :       return &gfc_bad_expr;
    4580                 :            :     }
    4581                 :            : 
    4582                 :         97 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    4583                 :         97 :   mpfr_log10 (result->value.real, x->value.real, GFC_RND_MODE);
    4584                 :            : 
    4585                 :         97 :   return range_check (result, "LOG10");
    4586                 :            : }
    4587                 :            : 
    4588                 :            : 
    4589                 :            : gfc_expr *
    4590                 :         16 : gfc_simplify_logical (gfc_expr *e, gfc_expr *k)
    4591                 :            : {
    4592                 :         16 :   int kind;
    4593                 :            : 
    4594                 :         16 :   kind = get_kind (BT_LOGICAL, k, "LOGICAL", gfc_default_logical_kind);
    4595                 :         16 :   if (kind < 0)
    4596                 :            :     return &gfc_bad_expr;
    4597                 :            : 
    4598                 :         16 :   if (e->expr_type != EXPR_CONSTANT)
    4599                 :            :     return NULL;
    4600                 :            : 
    4601                 :          4 :   return gfc_get_logical_expr (kind, &e->where, e->value.logical);
    4602                 :            : }
    4603                 :            : 
    4604                 :            : 
    4605                 :            : gfc_expr*
    4606                 :       1137 : gfc_simplify_matmul (gfc_expr *matrix_a, gfc_expr *matrix_b)
    4607                 :            : {
    4608                 :       1137 :   gfc_expr *result;
    4609                 :       1137 :   int row, result_rows, col, result_columns;
    4610                 :       1137 :   int stride_a, offset_a, stride_b, offset_b;
    4611                 :            : 
    4612                 :       1137 :   if (!is_constant_array_expr (matrix_a)
    4613                 :       1137 :       || !is_constant_array_expr (matrix_b))
    4614                 :       1087 :     return NULL;
    4615                 :            : 
    4616                 :            :   /* MATMUL should do mixed-mode arithmetic.  Set the result type.  */
    4617                 :         50 :   if (matrix_a->ts.type != matrix_b->ts.type)
    4618                 :            :     {
    4619                 :         12 :       gfc_expr e;
    4620                 :         12 :       e.expr_type = EXPR_OP;
    4621                 :         12 :       gfc_clear_ts (&e.ts);
    4622                 :         12 :       e.value.op.op = INTRINSIC_NONE;
    4623                 :         12 :       e.value.op.op1 = matrix_a;
    4624                 :         12 :       e.value.op.op2 = matrix_b;
    4625                 :         12 :       gfc_type_convert_binary (&e, 1);
    4626                 :         12 :       result = gfc_get_array_expr (e.ts.type, e.ts.kind, &matrix_a->where);
    4627                 :            :     }
    4628                 :            :   else
    4629                 :            :     {
    4630                 :         38 :       result = gfc_get_array_expr (matrix_a->ts.type, matrix_a->ts.kind,
    4631                 :            :                                    &matrix_a->where);
    4632                 :            :     }
    4633                 :            : 
    4634                 :         50 :   if (matrix_a->rank == 1 && matrix_b->rank == 2)
    4635                 :            :     {
    4636                 :          7 :       result_rows = 1;
    4637                 :          7 :       result_columns = mpz_get_si (matrix_b->shape[1]);
    4638                 :          7 :       stride_a = 1;
    4639                 :          7 :       stride_b = mpz_get_si (matrix_b->shape[0]);
    4640                 :            : 
    4641                 :          7 :       result->rank = 1;
    4642                 :          7 :       result->shape = gfc_get_shape (result->rank);
    4643                 :          7 :       mpz_init_set_si (result->shape[0], result_columns);
    4644                 :            :     }
    4645                 :         43 :   else if (matrix_a->rank == 2 && matrix_b->rank == 1)
    4646                 :            :     {
    4647                 :          6 :       result_rows = mpz_get_si (matrix_a->shape[0]);
    4648                 :          6 :       result_columns = 1;
    4649                 :          6 :       stride_a = mpz_get_si (matrix_a->shape[0]);
    4650                 :          6 :       stride_b = 1;
    4651                 :            : 
    4652                 :          6 :       result->rank = 1;
    4653                 :          6 :       result->shape = gfc_get_shape (result->rank);
    4654                 :          6 :       mpz_init_set_si (result->shape[0], result_rows);
    4655                 :            :     }
    4656                 :         37 :   else if (matrix_a->rank == 2 && matrix_b->rank == 2)
    4657                 :            :     {
    4658                 :         37 :       result_rows = mpz_get_si (matrix_a->shape[0]);
    4659                 :         37 :       result_columns = mpz_get_si (matrix_b->shape[1]);
    4660                 :         37 :       stride_a = mpz_get_si (matrix_a->shape[0]);
    4661                 :         37 :       stride_b = mpz_get_si (matrix_b->shape[0]);
    4662                 :            : 
    4663                 :         37 :       result->rank = 2;
    4664                 :         37 :       result->shape = gfc_get_shape (result->rank);
    4665                 :         37 :       mpz_init_set_si (result->shape[0], result_rows);
    4666                 :         37 :       mpz_init_set_si (result->shape[1], result_columns);
    4667                 :            :     }
    4668                 :            :   else
    4669                 :          0 :     gcc_unreachable();
    4670                 :            : 
    4671                 :         50 :   offset_b = 0;
    4672                 :        174 :   for (col = 0; col < result_columns; ++col)
    4673                 :            :     {
    4674                 :            :       offset_a = 0;
    4675                 :            : 
    4676                 :        434 :       for (row = 0; row < result_rows; ++row)
    4677                 :            :         {
    4678                 :        310 :           gfc_expr *e = compute_dot_product (matrix_a, stride_a, offset_a,
    4679                 :            :                                              matrix_b, 1, offset_b, false);
    4680                 :        310 :           gfc_constructor_append_expr (&result->value.constructor,
    4681                 :            :                                        e, NULL);
    4682                 :            : 
    4683                 :        310 :           offset_a += 1;
    4684                 :            :         }
    4685                 :            : 
    4686                 :        124 :       offset_b += stride_b;
    4687                 :            :     }
    4688                 :            : 
    4689                 :            :   return result;
    4690                 :            : }
    4691                 :            : 
    4692                 :            : 
    4693                 :            : gfc_expr *
    4694                 :        240 : gfc_simplify_maskr (gfc_expr *i, gfc_expr *kind_arg)
    4695                 :            : {
    4696                 :        240 :   gfc_expr *result;
    4697                 :        240 :   int kind, arg, k;
    4698                 :            : 
    4699                 :        240 :   if (i->expr_type != EXPR_CONSTANT)
    4700                 :            :     return NULL;
    4701                 :            : 
    4702                 :        210 :   kind = get_kind (BT_INTEGER, kind_arg, "MASKR", gfc_default_integer_kind);
    4703                 :        210 :   if (kind == -1)
    4704                 :            :     return &gfc_bad_expr;
    4705                 :        210 :   k = gfc_validate_kind (BT_INTEGER, kind, false);
    4706                 :            : 
    4707                 :        210 :   bool fail = gfc_extract_int (i, &arg);
    4708                 :        210 :   gcc_assert (!fail);
    4709                 :            : 
    4710                 :        210 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
    4711                 :            : 
    4712                 :            :   /* MASKR(n) = 2^n - 1 */
    4713                 :        210 :   mpz_set_ui (result->value.integer, 1);
    4714                 :        210 :   mpz_mul_2exp (result->value.integer, result->value.integer, arg);
    4715                 :        210 :   mpz_sub_ui (result->value.integer, result->value.integer, 1);
    4716                 :            : 
    4717                 :        210 :   gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
    4718                 :            : 
    4719                 :        210 :   return result;
    4720                 :            : }
    4721                 :            : 
    4722                 :            : 
    4723                 :            : gfc_expr *
    4724                 :        240 : gfc_simplify_maskl (gfc_expr *i, gfc_expr *kind_arg)
    4725                 :            : {
    4726                 :        240 :   gfc_expr *result;
    4727                 :        240 :   int kind, arg, k;
    4728                 :        240 :   mpz_t z;
    4729                 :            : 
    4730                 :        240 :   if (i->expr_type != EXPR_CONSTANT)
    4731                 :            :     return NULL;
    4732                 :            : 
    4733                 :        210 :   kind = get_kind (BT_INTEGER, kind_arg, "MASKL", gfc_default_integer_kind);
    4734                 :        210 :   if (kind == -1)
    4735                 :            :     return &gfc_bad_expr;
    4736                 :        210 :   k = gfc_validate_kind (BT_INTEGER, kind, false);
    4737                 :            : 
    4738                 :        210 :   bool fail = gfc_extract_int (i, &arg);
    4739                 :        210 :   gcc_assert (!fail);
    4740                 :            : 
    4741                 :        210 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &i->where);
    4742                 :            : 
    4743                 :            :   /* MASKL(n) = 2^bit_size - 2^(bit_size - n) */
    4744                 :        210 :   mpz_init_set_ui (z, 1);
    4745                 :        210 :   mpz_mul_2exp (z, z, gfc_integer_kinds[k].bit_size);
    4746                 :        210 :   mpz_set_ui (result->value.integer, 1);
    4747                 :        210 :   mpz_mul_2exp (result->value.integer, result->value.integer,
    4748                 :        210 :                 gfc_integer_kinds[k].bit_size - arg);
    4749                 :        210 :   mpz_sub (result->value.integer, z, result->value.integer);
    4750                 :        210 :   mpz_clear (z);
    4751                 :            : 
    4752                 :        210 :   gfc_convert_mpz_to_signed (result->value.integer, gfc_integer_kinds[k].bit_size);
    4753                 :            : 
    4754                 :        210 :   return result;
    4755                 :            : }
    4756                 :            : 
    4757                 :            : 
    4758                 :            : gfc_expr *
    4759                 :       2435 : gfc_simplify_merge (gfc_expr *tsource, gfc_expr *fsource, gfc_expr *mask)
    4760                 :            : {
    4761                 :       2435 :   gfc_expr * result;
    4762                 :       2435 :   gfc_constructor *tsource_ctor, *fsource_ctor, *mask_ctor;
    4763                 :            : 
    4764                 :       2435 :   if (mask->expr_type == EXPR_CONSTANT)
    4765                 :            :     {
    4766                 :        413 :       result = gfc_copy_expr (mask->value.logical ? tsource : fsource);
    4767                 :            :       /* Parenthesis is needed to get lower bounds of 1.  */
    4768                 :        328 :       result = gfc_get_parentheses (result);
    4769                 :        328 :       gfc_simplify_expr (result, 1);
    4770                 :        328 :       return result;
    4771                 :            :     }
    4772                 :            : 
    4773                 :        403 :   if (!mask->rank || !is_constant_array_expr (mask)
    4774                 :       2142 :       || !is_constant_array_expr (tsource) || !is_constant_array_expr (fsource))
    4775                 :       2088 :     return NULL;
    4776                 :            : 
    4777                 :         19 :   result = gfc_get_array_expr (tsource->ts.type, tsource->ts.kind,
    4778                 :            :                                &tsource->where);
    4779                 :         19 :   if (tsource->ts.type == BT_DERIVED)
    4780                 :          1 :     result->ts.u.derived = tsource->ts.u.derived;
    4781                 :         18 :   else if (tsource->ts.type == BT_CHARACTER)
    4782                 :          6 :     result->ts.u.cl = tsource->ts.u.cl;
    4783                 :            : 
    4784                 :         19 :   tsource_ctor = gfc_constructor_first (tsource->value.constructor);
    4785                 :         19 :   fsource_ctor = gfc_constructor_first (fsource->value.constructor);
    4786                 :         19 :   mask_ctor = gfc_constructor_first (mask->value.constructor);
    4787                 :            : 
    4788                 :         68 :   while (mask_ctor)
    4789                 :            :     {
    4790                 :         49 :       if (mask_ctor->expr->value.logical)
    4791                 :         31 :         gfc_constructor_append_expr (&result->value.constructor,
    4792                 :            :                                      gfc_copy_expr (tsource_ctor->expr),
    4793                 :            :                                      NULL);
    4794                 :            :       else
    4795                 :         18 :         gfc_constructor_append_expr (&result->value.constructor,
    4796                 :            :                                      gfc_copy_expr (fsource_ctor->expr),
    4797                 :            :                                      NULL);
    4798                 :         49 :       tsource_ctor = gfc_constructor_next (tsource_ctor);
    4799                 :         49 :       fsource_ctor = gfc_constructor_next (fsource_ctor);
    4800                 :         49 :       mask_ctor = gfc_constructor_next (mask_ctor);
    4801                 :            :     }
    4802                 :            : 
    4803                 :         19 :   result->shape = gfc_get_shape (1);
    4804                 :         19 :   gfc_array_size (result, &result->shape[0]);
    4805                 :            : 
    4806                 :         19 :   return result;
    4807                 :            : }
    4808                 :            : 
    4809                 :            : 
    4810                 :            : gfc_expr *
    4811                 :        288 : gfc_simplify_merge_bits (gfc_expr *i, gfc_expr *j, gfc_expr *mask_expr)
    4812                 :            : {
    4813                 :        288 :   mpz_t arg1, arg2, mask;
    4814                 :        288 :   gfc_expr *result;
    4815                 :            : 
    4816                 :        288 :   if (i->expr_type != EXPR_CONSTANT || j->expr_type != EXPR_CONSTANT
    4817                 :        258 :       || mask_expr->expr_type != EXPR_CONSTANT)
    4818                 :            :     return NULL;
    4819                 :            : 
    4820                 :        258 :   result = gfc_get_constant_expr (BT_INTEGER, i->ts.kind, &i->where);
    4821                 :            : 
    4822                 :            :   /* Convert all argument to unsigned.  */
    4823                 :        258 :   mpz_init_set (arg1, i->value.integer);
    4824                 :        258 :   mpz_init_set (arg2, j->value.integer);
    4825                 :        258 :   mpz_init_set (mask, mask_expr->value.integer);
    4826                 :            : 
    4827                 :            :   /* MERGE_BITS(I,J,MASK) = IOR (IAND (I, MASK), IAND (J, NOT (MASK))).  */
    4828                 :        258 :   mpz_and (arg1, arg1, mask);
    4829                 :        258 :   mpz_com (mask, mask);
    4830                 :        258 :   mpz_and (arg2, arg2, mask);
    4831                 :        258 :   mpz_ior (result->value.integer, arg1, arg2);
    4832                 :            : 
    4833                 :        258 :   mpz_clear (arg1);
    4834                 :        258 :   mpz_clear (arg2);
    4835                 :        258 :   mpz_clear (mask);
    4836                 :            : 
    4837                 :        258 :   return result;
    4838                 :            : }
    4839                 :            : 
    4840                 :            : 
    4841                 :            : /* Selects between current value and extremum for simplify_min_max
    4842                 :            :    and simplify_minval_maxval.  */
    4843                 :            : static int
    4844                 :       4084 : min_max_choose (gfc_expr *arg, gfc_expr *extremum, int sign, bool back_val)
    4845                 :            : {
    4846                 :       4084 :   int ret;
    4847                 :            : 
    4848                 :       4084 :   switch (arg->ts.type)
    4849                 :            :     {
    4850                 :       2997 :       case BT_INTEGER:
    4851                 :       2997 :         ret = mpz_cmp (arg->value.integer,
    4852                 :       2997 :                        extremum->value.integer) * sign;
    4853                 :       2997 :         if (ret > 0)
    4854                 :       2600 :           mpz_set (extremum->value.integer, arg->value.integer);
    4855                 :            :         break;
    4856                 :            : 
    4857                 :        590 :       case BT_REAL:
    4858                 :        590 :         if (mpfr_nan_p (extremum->value.real))
    4859                 :            :           {
    4860                 :        192 :             ret = 1;
    4861                 :        192 :             mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
    4862                 :            :           }
    4863                 :        398 :         else if (mpfr_nan_p (arg->value.real))
    4864                 :            :           ret = -1;
    4865                 :            :         else
    4866                 :            :           {
    4867                 :        278 :             ret = mpfr_cmp (arg->value.real, extremum->value.real) * sign;
    4868                 :        278 :             if (ret > 0)
    4869                 :        138 :               mpfr_set (extremum->value.real, arg->value.real, GFC_RND_MODE);
    4870                 :            :           }
    4871                 :            :         break;
    4872                 :            : 
    4873                 :        497 :       case BT_CHARACTER:
    4874                 :            : #define LENGTH(x) ((x)->value.character.length)
    4875                 :            : #define STRING(x) ((x)->value.character.string)
    4876                 :        497 :         if (LENGTH (extremum) < LENGTH(arg))
    4877                 :            :           {
    4878                 :         12 :             gfc_char_t *tmp = STRING(extremum);
    4879                 :            : 
    4880                 :         12 :             STRING(extremum) = gfc_get_wide_string (LENGTH(arg) + 1);
    4881                 :         12 :             memcpy (STRING(extremum), tmp,
    4882                 :         12 :                       LENGTH(extremum) * sizeof (gfc_char_t));
    4883                 :         12 :             gfc_wide_memset (&STRING(extremum)[LENGTH(extremum)], ' ',
    4884                 :         12 :                                LENGTH(arg) - LENGTH(extremum));
    4885                 :         12 :             STRING(extremum)[LENGTH(arg)] = '\0';  /* For debugger  */
    4886                 :         12 :             LENGTH(extremum) = LENGTH(arg);
    4887                 :         12 :             free (tmp);
    4888                 :            :           }
    4889                 :        497 :         ret = gfc_compare_string (arg, extremum) * sign;
    4890                 :        497 :         if (ret > 0)
    4891                 :            :           {
    4892                 :        187 :             free (STRING(extremum));
    4893                 :        187 :             STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
    4894                 :        187 :             memcpy (STRING(extremum), STRING(arg),
    4895                 :        187 :                       LENGTH(arg) * sizeof (gfc_char_t));
    4896                 :        187 :             gfc_wide_memset (&STRING(extremum)[LENGTH(arg)], ' ',
    4897                 :        187 :                                LENGTH(extremum) - LENGTH(arg));
    4898                 :        187 :             STRING(extremum)[LENGTH(extremum)] = '\0';  /* For debugger  */
    4899                 :            :           }
    4900                 :            : #undef LENGTH
    4901                 :            : #undef STRING
    4902                 :            :         break;
    4903                 :            : 
    4904                 :          0 :       default:
    4905                 :          0 :         gfc_internal_error ("simplify_min_max(): Bad type in arglist");
    4906                 :            :     }
    4907                 :       4084 :   if (back_val && ret == 0)
    4908                 :         59 :     ret = 1;
    4909                 :            : 
    4910                 :       4084 :   return ret;
    4911                 :            : }
    4912                 :            : 
    4913                 :            : 
    4914                 :            : /* This function is special since MAX() can take any number of
    4915                 :            :    arguments.  The simplified expression is a rewritten version of the
    4916                 :            :    argument list containing at most one constant element.  Other
    4917                 :            :    constant elements are deleted.  Because the argument list has
    4918                 :            :    already been checked, this function always succeeds.  sign is 1 for
    4919                 :            :    MAX(), -1 for MIN().  */
    4920                 :            : 
    4921                 :            : static gfc_expr *
    4922                 :       5131 : simplify_min_max (gfc_expr *expr, int sign)
    4923                 :            : {
    4924                 :       5131 :   gfc_actual_arglist *arg, *last, *extremum;
    4925                 :       5131 :   gfc_expr *tmp, *ret;
    4926                 :       5131 :   const char *fname;
    4927                 :            : 
    4928                 :       5131 :   last = NULL;
    4929                 :       5131 :   extremum = NULL;
    4930                 :            : 
    4931                 :       5131 :   arg = expr->value.function.actual;
    4932                 :            : 
    4933                 :      16337 :   for (; arg; last = arg, arg = arg->next)
    4934                 :            :     {
    4935                 :      11206 :       if (arg->expr->expr_type != EXPR_CONSTANT)
    4936                 :       3911 :         continue;
    4937                 :            : 
    4938                 :       7295 :       if (extremum == NULL)
    4939                 :            :         {
    4940                 :       3832 :           extremum = arg;
    4941                 :       3832 :           continue;
    4942                 :            :         }
    4943                 :            : 
    4944                 :       3463 :       min_max_choose (arg->expr, extremum->expr, sign);
    4945                 :            : 
    4946                 :            :       /* Delete the extra constant argument.  */
    4947                 :       3463 :       last->next = arg->next;
    4948                 :            : 
    4949                 :       3463 :       arg->next = NULL;
    4950                 :       3463 :       gfc_free_actual_arglist (arg);
    4951                 :       3463 :       arg = last;
    4952                 :            :     }
    4953                 :            : 
    4954                 :            :   /* If there is one value left, replace the function call with the
    4955                 :            :      expression.  */
    4956                 :       5131 :   if (expr->value.function.actual->next != NULL)
    4957                 :            :     return NULL;
    4958                 :            : 
    4959                 :            :   /* Handle special cases of specific functions (min|max)1 and
    4960                 :            :      a(min|max)0.  */
    4961                 :            : 
    4962                 :       3082 :   tmp = expr->value.function.actual->expr;
    4963                 :       3082 :   fname = expr->value.function.isym->name;
    4964                 :            : 
    4965                 :       3082 :   if ((tmp->ts.type != BT_INTEGER || tmp->ts.kind != gfc_integer_4_kind)
    4966                 :        536 :       && (strcmp (fname, "min1") == 0 || strcmp (fname, "max1") == 0))
    4967                 :            :     {
    4968                 :         11 :       ret = gfc_convert_constant (tmp, BT_INTEGER, gfc_integer_4_kind);
    4969                 :            :     }
    4970                 :       3071 :   else if ((tmp->ts.type != BT_REAL || tmp->ts.kind != gfc_real_4_kind)
    4971                 :       2830 :            && (strcmp (fname, "amin0") == 0 || strcmp (fname, "amax0") == 0))
    4972                 :            :     {
    4973                 :         11 :       ret = gfc_convert_constant (tmp, BT_REAL, gfc_real_4_kind);
    4974                 :            :     }
    4975                 :            :   else
    4976                 :       3060 :     ret = gfc_copy_expr (tmp);
    4977                 :            : 
    4978                 :            :   return ret;
    4979                 :            : 
    4980                 :            : }
    4981                 :            : 
    4982                 :            : 
    4983                 :            : gfc_expr *
    4984                 :       1088 : gfc_simplify_min (gfc_expr *e)
    4985                 :            : {
    4986                 :       1088 :   return simplify_min_max (e, -1);
    4987                 :            : }
    4988                 :            : 
    4989                 :            : 
    4990                 :            : gfc_expr *
    4991                 :       4043 : gfc_simplify_max (gfc_expr *e)
    4992                 :            : {
    4993                 :       4043 :   return simplify_min_max (e, 1);
    4994                 :            : }
    4995                 :            : 
    4996                 :            : /* Helper function for gfc_simplify_minval.  */
    4997                 :            : 
    4998                 :            : static gfc_expr *
    4999                 :        167 : gfc_min (gfc_expr *op1, gfc_expr *op2)
    5000                 :            : {
    5001                 :        167 :   min_max_choose (op1, op2, -1);
    5002                 :        167 :   gfc_free_expr (op1);
    5003                 :        167 :   return op2;
    5004                 :            : }
    5005                 :            : 
    5006                 :            : /* Simplify minval for constant arrays.  */
    5007                 :            : 
    5008                 :            : gfc_expr *
    5009                 :       3768 : gfc_simplify_minval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
    5010                 :            : {
    5011                 :       3768 :   return simplify_transformation (array, dim, mask, INT_MAX, gfc_min);
    5012                 :            : }
    5013                 :            : 
    5014                 :            : /* Helper function for gfc_simplify_maxval.  */
    5015                 :            : 
    5016                 :            : static gfc_expr *
    5017                 :        141 : gfc_max (gfc_expr *op1, gfc_expr *op2)
    5018                 :            : {
    5019                 :        141 :   min_max_choose (op1, op2, 1);
    5020                 :        141 :   gfc_free_expr (op1);
    5021                 :        141 :   return op2;
    5022                 :            : }
    5023                 :            : 
    5024                 :            : 
    5025                 :            : /* Simplify maxval for constant arrays.  */
    5026                 :            : 
    5027                 :            : gfc_expr *
    5028                 :       2635 : gfc_simplify_maxval (gfc_expr *array, gfc_expr* dim, gfc_expr *mask)
    5029                 :            : {
    5030                 :       2635 :   return simplify_transformation (array, dim, mask, INT_MIN, gfc_max);
    5031                 :            : }
    5032                 :            : 
    5033                 :            : 
    5034                 :            : /* Transform minloc or maxloc of an array, according to MASK,
    5035                 :            :    to the scalar result.  This code is mostly identical to
    5036                 :            :    simplify_transformation_to_scalar.  */
    5037                 :            : 
    5038                 :            : static gfc_expr *
    5039                 :         58 : simplify_minmaxloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *mask,
    5040                 :            :                               gfc_expr *extremum, int sign, bool back_val)
    5041                 :            : {
    5042                 :         58 :   gfc_expr *a, *m;
    5043                 :         58 :   gfc_constructor *array_ctor, *mask_ctor;
    5044                 :         58 :   mpz_t count;
    5045                 :            : 
    5046                 :         58 :   mpz_set_si (result->value.integer, 0);
    5047                 :            : 
    5048                 :            : 
    5049                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5050                 :         58 :   if (mask
    5051                 :         42 :       && mask->expr_type == EXPR_CONSTANT
    5052                 :         36 :       && !mask->value.logical)
    5053                 :            :     return result;
    5054                 :            : 
    5055                 :         22 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5056                 :         22 :   if (mask && mask->expr_type == EXPR_ARRAY)
    5057                 :          6 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5058                 :            :   else
    5059                 :            :     mask_ctor = NULL;
    5060                 :            : 
    5061                 :         22 :   mpz_init_set_si (count, 0);
    5062                 :        110 :   while (array_ctor)
    5063                 :            :     {
    5064                 :         88 :       mpz_add_ui (count, count, 1);
    5065                 :         88 :       a = array_ctor->expr;
    5066                 :         88 :       array_ctor = gfc_constructor_next (array_ctor);
    5067                 :            :       /* A constant MASK equals .TRUE. here and can be ignored.  */
    5068                 :         88 :       if (mask_ctor)
    5069                 :            :         {
    5070                 :         28 :           m = mask_ctor->expr;
    5071                 :         28 :           mask_ctor = gfc_constructor_next (mask_ctor);
    5072                 :         28 :           if (!m->value.logical)
    5073                 :         12 :             continue;
    5074                 :            :         }
    5075                 :         76 :       if (min_max_choose (a, extremum, sign, back_val) > 0)
    5076                 :         36 :         mpz_set (result->value.integer, count);
    5077                 :            :     }
    5078                 :         22 :   mpz_clear (count);
    5079                 :         22 :   gfc_free_expr (extremum);
    5080                 :         22 :   return result;
    5081                 :            : }
    5082                 :            : 
    5083                 :            : /* Simplify minloc / maxloc in the absence of a dim argument.  */
    5084                 :            : 
    5085                 :            : static gfc_expr *
    5086                 :         68 : simplify_minmaxloc_nodim (gfc_expr *result, gfc_expr *extremum,
    5087                 :            :                           gfc_expr *array, gfc_expr *mask, int sign,
    5088                 :            :                           bool back_val)
    5089                 :            : {
    5090                 :         68 :   ssize_t res[GFC_MAX_DIMENSIONS];
    5091                 :         68 :   int i, n;
    5092                 :         68 :   gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
    5093                 :         68 :   ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    5094                 :            :     sstride[GFC_MAX_DIMENSIONS];
    5095                 :         68 :   gfc_expr *a, *m;
    5096                 :         68 :   bool continue_loop;
    5097                 :         68 :   bool ma;
    5098                 :            : 
    5099                 :        152 :   for (i = 0; i<array->rank; i++)
    5100                 :         84 :     res[i] = -1;
    5101                 :            : 
    5102                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5103                 :         68 :   if (mask
    5104                 :         56 :       && mask->expr_type == EXPR_CONSTANT
    5105                 :         40 :       && !mask->value.logical)
    5106                 :         38 :     goto finish;
    5107                 :            : 
    5108                 :         66 :   for (i = 0; i < array->rank; i++)
    5109                 :            :     {
    5110                 :         44 :       count[i] = 0;
    5111                 :         44 :       sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
    5112                 :         44 :       extent[i] = mpz_get_si (array->shape[i]);
    5113                 :         44 :       if (extent[i] <= 0)
    5114                 :          8 :         goto finish;
    5115                 :            :     }
    5116                 :            : 
    5117                 :         22 :   continue_loop = true;
    5118                 :         22 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5119                 :         22 :   if (mask && mask->rank > 0)
    5120                 :         12 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5121                 :            :   else
    5122                 :            :     mask_ctor = NULL;
    5123                 :            : 
    5124                 :            :   /* Loop over the array elements (and mask), keeping track of
    5125                 :            :      the indices to return.  */
    5126                 :         66 :   while (continue_loop)
    5127                 :            :     {
    5128                 :        120 :       do
    5129                 :            :         {
    5130                 :        120 :           a = array_ctor->expr;
    5131                 :        120 :           if (mask_ctor)
    5132                 :            :             {
    5133                 :         46 :               m = mask_ctor->expr;
    5134                 :         46 :               ma = m->value.logical;
    5135                 :         46 :               mask_ctor = gfc_constructor_next (mask_ctor);
    5136                 :            :             }
    5137                 :            :           else
    5138                 :            :             ma = true;
    5139                 :            : 
    5140                 :        120 :           if (ma && min_max_choose (a, extremum, sign, back_val) > 0)
    5141                 :            :             {
    5142                 :        130 :               for (i = 0; i<array->rank; i++)
    5143                 :         86 :                 res[i] = count[i];
    5144                 :            :             }
    5145                 :        120 :           array_ctor = gfc_constructor_next (array_ctor);
    5146                 :        120 :           count[0] ++;
    5147                 :        120 :         } while (count[0] != extent[0]);
    5148                 :            :       n = 0;
    5149                 :         58 :       do
    5150                 :            :         {
    5151                 :            :           /* When we get to the end of a dimension, reset it and increment
    5152                 :            :              the next dimension.  */
    5153                 :         58 :           count[n] = 0;
    5154                 :         58 :           n++;
    5155                 :         58 :           if (n >= array->rank)
    5156                 :            :             {
    5157                 :            :               continue_loop = false;
    5158                 :            :               break;
    5159                 :            :             }
    5160                 :            :           else
    5161                 :         36 :             count[n] ++;
    5162                 :         36 :         } while (count[n] == extent[n]);
    5163                 :            :     }
    5164                 :            : 
    5165                 :         22 :  finish:
    5166                 :         68 :   gfc_free_expr (extremum);
    5167                 :         68 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5168                 :        152 :   for (i = 0; i<array->rank; i++)
    5169                 :            :     {
    5170                 :         84 :       gfc_expr *r_expr;
    5171                 :         84 :       r_expr = result_ctor->expr;
    5172                 :         84 :       mpz_set_si (r_expr->value.integer, res[i] + 1);
    5173                 :         84 :       result_ctor = gfc_constructor_next (result_ctor);
    5174                 :            :     }
    5175                 :         68 :   return result;
    5176                 :            : }
    5177                 :            : 
    5178                 :            : /* Helper function for gfc_simplify_minmaxloc - build an array
    5179                 :            :    expression with n elements.  */
    5180                 :            : 
    5181                 :            : static gfc_expr *
    5182                 :         81 : new_array (bt type, int kind, int n, locus *where)
    5183                 :            : {
    5184                 :         81 :   gfc_expr *result;
    5185                 :         81 :   int i;
    5186                 :            : 
    5187                 :         81 :   result = gfc_get_array_expr (type, kind, where);
    5188                 :         81 :   result->rank = 1;
    5189                 :         81 :   result->shape = gfc_get_shape(1);
    5190                 :         81 :   mpz_init_set_si (result->shape[0], n);
    5191                 :        185 :   for (i = 0; i < n; i++)
    5192                 :            :     {
    5193                 :        104 :       gfc_constructor_append_expr (&result->value.constructor,
    5194                 :            :                                    gfc_get_constant_expr (type, kind, where),
    5195                 :            :                                    NULL);
    5196                 :            :     }
    5197                 :            : 
    5198                 :         81 :   return result;
    5199                 :            : }
    5200                 :            : 
    5201                 :            : /* Simplify minloc and maxloc. This code is mostly identical to
    5202                 :            :    simplify_transformation_to_array.  */
    5203                 :            : 
    5204                 :            : static gfc_expr *
    5205                 :         24 : simplify_minmaxloc_to_array (gfc_expr *result, gfc_expr *array,
    5206                 :            :                              gfc_expr *dim, gfc_expr *mask,
    5207                 :            :                              gfc_expr *extremum, int sign, bool back_val)
    5208                 :            : {
    5209                 :         24 :   mpz_t size;
    5210                 :         24 :   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
    5211                 :         24 :   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
    5212                 :         24 :   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
    5213                 :            : 
    5214                 :         24 :   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    5215                 :            :       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
    5216                 :            :       tmpstride[GFC_MAX_DIMENSIONS];
    5217                 :            : 
    5218                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5219                 :         24 :   if (mask
    5220                 :         10 :       && mask->expr_type == EXPR_CONSTANT
    5221                 :          0 :       && !mask->value.logical)
    5222                 :            :     return result;
    5223                 :            : 
    5224                 :            :   /* Build an indexed table for array element expressions to minimize
    5225                 :            :      linked-list traversal. Masked elements are set to NULL.  */
    5226                 :         24 :   gfc_array_size (array, &size);
    5227                 :         24 :   arraysize = mpz_get_ui (size);
    5228                 :         24 :   mpz_clear (size);
    5229                 :            : 
    5230                 :         24 :   arrayvec = XCNEWVEC (gfc_expr*, arraysize);
    5231                 :            : 
    5232                 :         24 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5233                 :         24 :   mask_ctor = NULL;
    5234                 :         24 :   if (mask && mask->expr_type == EXPR_ARRAY)
    5235                 :         10 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5236                 :            : 
    5237                 :        234 :   for (i = 0; i < arraysize; ++i)
    5238                 :            :     {
    5239                 :        210 :       arrayvec[i] = array_ctor->expr;
    5240                 :        210 :       array_ctor = gfc_constructor_next (array_ctor);
    5241                 :            : 
    5242                 :        210 :       if (mask_ctor)
    5243                 :            :         {
    5244                 :        106 :           if (!mask_ctor->expr->value.logical)
    5245                 :         65 :             arrayvec[i] = NULL;
    5246                 :            : 
    5247                 :        106 :           mask_ctor = gfc_constructor_next (mask_ctor);
    5248                 :            :         }
    5249                 :            :     }
    5250                 :            : 
    5251                 :            :   /* Same for the result expression.  */
    5252                 :         24 :   gfc_array_size (result, &size);
    5253                 :         24 :   resultsize = mpz_get_ui (size);
    5254                 :         24 :   mpz_clear (size);
    5255                 :            : 
    5256                 :         24 :   resultvec = XCNEWVEC (gfc_expr*, resultsize);
    5257                 :         24 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5258                 :         90 :   for (i = 0; i < resultsize; ++i)
    5259                 :            :     {
    5260                 :         66 :       resultvec[i] = result_ctor->expr;
    5261                 :         66 :       result_ctor = gfc_constructor_next (result_ctor);
    5262                 :            :     }
    5263                 :            : 
    5264                 :         24 :   gfc_extract_int (dim, &dim_index);
    5265                 :         24 :   dim_index -= 1;               /* zero-base index */
    5266                 :         24 :   dim_extent = 0;
    5267                 :         24 :   dim_stride = 0;
    5268                 :            : 
    5269                 :         72 :   for (i = 0, n = 0; i < array->rank; ++i)
    5270                 :            :     {
    5271                 :         48 :       count[i] = 0;
    5272                 :         48 :       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
    5273                 :         48 :       if (i == dim_index)
    5274                 :            :         {
    5275                 :         24 :           dim_extent = mpz_get_si (array->shape[i]);
    5276                 :         24 :           dim_stride = tmpstride[i];
    5277                 :         24 :           continue;
    5278                 :            :         }
    5279                 :            : 
    5280                 :         24 :       extent[n] = mpz_get_si (array->shape[i]);
    5281                 :         24 :       sstride[n] = tmpstride[i];
    5282                 :         24 :       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
    5283                 :         24 :       n += 1;
    5284                 :            :     }
    5285                 :            : 
    5286                 :         24 :   done = resultsize <= 0;
    5287                 :         24 :   base = arrayvec;
    5288                 :         24 :   dest = resultvec;
    5289                 :         90 :   while (!done)
    5290                 :            :     {
    5291                 :         66 :       gfc_expr *ex;
    5292                 :         66 :       ex = gfc_copy_expr (extremum);
    5293                 :        276 :       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
    5294                 :            :         {
    5295                 :        210 :           if (*src && min_max_choose (*src, ex, sign, back_val) > 0)
    5296                 :        107 :             mpz_set_si ((*dest)->value.integer, n + 1);
    5297                 :            :         }
    5298                 :            : 
    5299                 :         66 :       count[0]++;
    5300                 :         66 :       base += sstride[0];
    5301                 :         66 :       dest += dstride[0];
    5302                 :         66 :       gfc_free_expr (ex);
    5303                 :            : 
    5304                 :         66 :       n = 0;
    5305                 :         88 :       while (!done && count[n] == extent[n])
    5306                 :            :         {
    5307                 :         22 :           count[n] = 0;
    5308                 :         22 :           base -= sstride[n] * extent[n];
    5309                 :         22 :           dest -= dstride[n] * extent[n];
    5310                 :            : 
    5311                 :         22 :           n++;
    5312                 :         22 :           if (n < result->rank)
    5313                 :            :             {
    5314                 :            :               /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
    5315                 :            :                  times, we'd warn for the last iteration, because the
    5316                 :            :                  array index will have already been incremented to the
    5317                 :            :                  array sizes, and we can't tell that this must make
    5318                 :            :                  the test against result->rank false, because ranks
    5319                 :            :                  must not exceed GFC_MAX_DIMENSIONS.  */
    5320                 :          0 :               GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
    5321                 :          0 :               count[n]++;
    5322                 :          0 :               base += sstride[n];
    5323                 :          0 :               dest += dstride[n];
    5324                 :          0 :               GCC_DIAGNOSTIC_POP
    5325                 :            :             }
    5326                 :            :           else
    5327                 :            :             done = true;
    5328                 :            :        }
    5329                 :            :     }
    5330                 :            : 
    5331                 :            :   /* Place updated expression in result constructor.  */
    5332                 :         24 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5333                 :         90 :   for (i = 0; i < resultsize; ++i)
    5334                 :            :     {
    5335                 :         66 :       result_ctor->expr = resultvec[i];
    5336                 :         66 :       result_ctor = gfc_constructor_next (result_ctor);
    5337                 :            :     }
    5338                 :            : 
    5339                 :         24 :   free (arrayvec);
    5340                 :         24 :   free (resultvec);
    5341                 :         24 :   free (extremum);
    5342                 :         24 :   return result;
    5343                 :            : }
    5344                 :            : 
    5345                 :            : /* Simplify minloc and maxloc for constant arrays.  */
    5346                 :            : 
    5347                 :            : static gfc_expr *
    5348                 :       8932 : gfc_simplify_minmaxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask,
    5349                 :            :                         gfc_expr *kind, gfc_expr *back, int sign)
    5350                 :            : {
    5351                 :       8932 :   gfc_expr *result;
    5352                 :       8932 :   gfc_expr *extremum;
    5353                 :       8932 :   int ikind;
    5354                 :       8932 :   int init_val;
    5355                 :       8932 :   bool back_val = false;
    5356                 :            : 
    5357                 :       8932 :   if (!is_constant_array_expr (array)
    5358                 :       8932 :       || !gfc_is_constant_expr (dim))
    5359                 :       8674 :     return NULL;
    5360                 :            : 
    5361                 :        258 :   if (mask
    5362                 :        216 :       && !is_constant_array_expr (mask)
    5363                 :        442 :       && mask->expr_type != EXPR_CONSTANT)
    5364                 :            :     return NULL;
    5365                 :            : 
    5366                 :        150 :   if (kind)
    5367                 :            :     {
    5368                 :          0 :       if (gfc_extract_int (kind, &ikind, -1))
    5369                 :            :         return NULL;
    5370                 :            :     }
    5371                 :            :   else
    5372                 :        150 :     ikind = gfc_default_integer_kind;
    5373                 :            : 
    5374                 :        150 :   if (back)
    5375                 :            :     {
    5376                 :        150 :       if (back->expr_type != EXPR_CONSTANT)
    5377                 :            :         return NULL;
    5378                 :            : 
    5379                 :        150 :       back_val = back->value.logical;
    5380                 :            :     }
    5381                 :            : 
    5382                 :        150 :   if (sign < 0)
    5383                 :            :     init_val = INT_MAX;
    5384                 :         77 :   else if (sign > 0)
    5385                 :            :     init_val = INT_MIN;
    5386                 :            :   else
    5387                 :          0 :     gcc_unreachable();
    5388                 :            : 
    5389                 :        150 :   extremum = gfc_get_constant_expr (array->ts.type, array->ts.kind, &array->where);
    5390                 :        150 :   init_result_expr (extremum, init_val, array);
    5391                 :            : 
    5392                 :        150 :   if (dim)
    5393                 :            :     {
    5394                 :         82 :       result = transformational_result (array, dim, BT_INTEGER,
    5395                 :            :                                         ikind, &array->where);
    5396                 :         82 :       init_result_expr (result, 0, array);
    5397                 :            : 
    5398                 :         82 :       if (array->rank == 1)
    5399                 :         58 :         return simplify_minmaxloc_to_scalar (result, array, mask, extremum,
    5400                 :         58 :                                              sign, back_val);
    5401                 :            :       else
    5402                 :         24 :         return simplify_minmaxloc_to_array (result, array, dim, mask, extremum,
    5403                 :         24 :                                             sign, back_val);
    5404                 :            :     }
    5405                 :            :   else
    5406                 :            :     {
    5407                 :         68 :       result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
    5408                 :         68 :       return simplify_minmaxloc_nodim (result, extremum, array, mask,
    5409                 :         68 :                                        sign, back_val);
    5410                 :            :     }
    5411                 :            : }
    5412                 :            : 
    5413                 :            : gfc_expr *
    5414                 :       5299 : gfc_simplify_minloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
    5415                 :            :                      gfc_expr *back)
    5416                 :            : {
    5417                 :       5299 :   return gfc_simplify_minmaxloc (array, dim, mask, kind, back, -1);
    5418                 :            : }
    5419                 :            : 
    5420                 :            : gfc_expr *
    5421                 :       3633 : gfc_simplify_maxloc (gfc_expr *array, gfc_expr *dim, gfc_expr *mask, gfc_expr *kind,
    5422                 :            :                      gfc_expr *back)
    5423                 :            : {
    5424                 :       3633 :   return gfc_simplify_minmaxloc (array, dim, mask, kind, back, 1);
    5425                 :            : }
    5426                 :            : 
    5427                 :            : /* Simplify findloc to scalar.  Similar to
    5428                 :            :    simplify_minmaxloc_to_scalar.  */
    5429                 :            : 
    5430                 :            : static gfc_expr *
    5431                 :          7 : simplify_findloc_to_scalar (gfc_expr *result, gfc_expr *array, gfc_expr *value,
    5432                 :            :                             gfc_expr *mask, int back_val)
    5433                 :            : {
    5434                 :          7 :   gfc_expr *a, *m;
    5435                 :          7 :   gfc_constructor *array_ctor, *mask_ctor;
    5436                 :          7 :   mpz_t count;
    5437                 :            : 
    5438                 :          7 :   mpz_set_si (result->value.integer, 0);
    5439                 :            : 
    5440                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5441                 :          7 :   if (mask
    5442                 :          2 :       && mask->expr_type == EXPR_CONSTANT
    5443                 :          0 :       && !mask->value.logical)
    5444                 :            :     return result;
    5445                 :            : 
    5446                 :          7 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5447                 :          7 :   if (mask && mask->expr_type == EXPR_ARRAY)
    5448                 :          2 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5449                 :            :   else
    5450                 :            :     mask_ctor = NULL;
    5451                 :            : 
    5452                 :          7 :   mpz_init_set_si (count, 0);
    5453                 :         25 :   while (array_ctor)
    5454                 :            :     {
    5455                 :         22 :       mpz_add_ui (count, count, 1);
    5456                 :         22 :       a = array_ctor->expr;
    5457                 :         22 :       array_ctor = gfc_constructor_next (array_ctor);
    5458                 :            :       /* A constant MASK equals .TRUE. here and can be ignored.  */
    5459                 :         22 :       if (mask_ctor)
    5460                 :            :         {
    5461                 :          8 :           m = mask_ctor->expr;
    5462                 :          8 :           mask_ctor = gfc_constructor_next (mask_ctor);
    5463                 :          8 :           if (!m->value.logical)
    5464                 :          2 :             continue;
    5465                 :            :         }
    5466                 :         20 :       if (gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
    5467                 :            :         {
    5468                 :            :           /* We have a match.  If BACK is true, continue so we find
    5469                 :            :              the last one.  */
    5470                 :          7 :           mpz_set (result->value.integer, count);
    5471                 :          7 :           if (!back_val)
    5472                 :            :             break;
    5473                 :            :         }
    5474                 :            :     }
    5475                 :          7 :   mpz_clear (count);
    5476                 :          7 :   return result;
    5477                 :            : }
    5478                 :            : 
    5479                 :            : /* Simplify findloc in the absence of a dim argument.  Similar to
    5480                 :            :    simplify_minmaxloc_nodim.  */
    5481                 :            : 
    5482                 :            : static gfc_expr *
    5483                 :         13 : simplify_findloc_nodim (gfc_expr *result, gfc_expr *value, gfc_expr *array,
    5484                 :            :                         gfc_expr *mask, bool back_val)
    5485                 :            : {
    5486                 :         13 :   ssize_t res[GFC_MAX_DIMENSIONS];
    5487                 :         13 :   int i, n;
    5488                 :         13 :   gfc_constructor *result_ctor, *array_ctor, *mask_ctor;
    5489                 :         13 :   ssize_t count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    5490                 :            :     sstride[GFC_MAX_DIMENSIONS];
    5491                 :         13 :   gfc_expr *a, *m;
    5492                 :         13 :   bool continue_loop;
    5493                 :         13 :   bool ma;
    5494                 :            : 
    5495                 :         33 :   for (i = 0; i < array->rank; i++)
    5496                 :         20 :     res[i] = -1;
    5497                 :            : 
    5498                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5499                 :         13 :   if (mask
    5500                 :          1 :       && mask->expr_type == EXPR_CONSTANT
    5501                 :          0 :       && !mask->value.logical)
    5502                 :          0 :     goto finish;
    5503                 :            : 
    5504                 :         27 :   for (i = 0; i < array->rank; i++)
    5505                 :            :     {
    5506                 :         20 :       count[i] = 0;
    5507                 :         20 :       sstride[i] = (i == 0) ? 1 : sstride[i-1] * mpz_get_si (array->shape[i-1]);
    5508                 :         20 :       extent[i] = mpz_get_si (array->shape[i]);
    5509                 :         20 :       if (extent[i] <= 0)
    5510                 :          6 :         goto finish;
    5511                 :            :     }
    5512                 :            : 
    5513                 :          7 :   continue_loop = true;
    5514                 :          7 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5515                 :          7 :   if (mask && mask->rank > 0)
    5516                 :          1 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5517                 :            :   else
    5518                 :            :     mask_ctor = NULL;
    5519                 :            : 
    5520                 :            :   /* Loop over the array elements (and mask), keeping track of
    5521                 :            :      the indices to return.  */
    5522                 :         14 :   while (continue_loop)
    5523                 :            :     {
    5524                 :         22 :       do
    5525                 :            :         {
    5526                 :         22 :           a = array_ctor->expr;
    5527                 :         22 :           if (mask_ctor)
    5528                 :            :             {
    5529                 :          4 :               m = mask_ctor->expr;
    5530                 :          4 :               ma = m->value.logical;
    5531                 :          4 :               mask_ctor = gfc_constructor_next (mask_ctor);
    5532                 :            :             }
    5533                 :            :           else
    5534                 :            :             ma = true;
    5535                 :            : 
    5536                 :         22 :           if (ma && gfc_compare_expr (a, value, INTRINSIC_EQ) == 0)
    5537                 :            :             {
    5538                 :         15 :               for (i = 0; i < array->rank; i++)
    5539                 :         10 :                 res[i] = count[i];
    5540                 :          5 :               if (!back_val)
    5541                 :          4 :                 goto finish;
    5542                 :            :             }
    5543                 :         18 :           array_ctor = gfc_constructor_next (array_ctor);
    5544                 :         18 :           count[0] ++;
    5545                 :         18 :         } while (count[0] != extent[0]);
    5546                 :            :       n = 0;
    5547                 :         10 :       do
    5548                 :            :         {
    5549                 :            :           /* When we get to the end of a dimension, reset it and increment
    5550                 :            :              the next dimension.  */
    5551                 :         10 :           count[n] = 0;
    5552                 :         10 :           n++;
    5553                 :         10 :           if (n >= array->rank)
    5554                 :            :             {
    5555                 :            :               continue_loop = false;
    5556                 :            :               break;
    5557                 :            :             }
    5558                 :            :           else
    5559                 :          7 :             count[n] ++;
    5560                 :          7 :         } while (count[n] == extent[n]);
    5561                 :            :     }
    5562                 :            : 
    5563                 :          3 : finish:
    5564                 :         13 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5565                 :         33 :   for (i = 0; i < array->rank; i++)
    5566                 :            :     {
    5567                 :         20 :       gfc_expr *r_expr;
    5568                 :         20 :       r_expr = result_ctor->expr;
    5569                 :         20 :       mpz_set_si (r_expr->value.integer, res[i] + 1);
    5570                 :         20 :       result_ctor = gfc_constructor_next (result_ctor);
    5571                 :            :     }
    5572                 :         13 :   return result;
    5573                 :            : }
    5574                 :            : 
    5575                 :            : 
    5576                 :            : /* Simplify findloc to an array.  Similar to
    5577                 :            :    simplify_minmaxloc_to_array.  */
    5578                 :            : 
    5579                 :            : static gfc_expr *
    5580                 :          2 : simplify_findloc_to_array (gfc_expr *result, gfc_expr *array, gfc_expr *value,
    5581                 :            :                            gfc_expr *dim, gfc_expr *mask, bool back_val)
    5582                 :            : {
    5583                 :          2 :   mpz_t size;
    5584                 :          2 :   int done, i, n, arraysize, resultsize, dim_index, dim_extent, dim_stride;
    5585                 :          2 :   gfc_expr **arrayvec, **resultvec, **base, **src, **dest;
    5586                 :          2 :   gfc_constructor *array_ctor, *mask_ctor, *result_ctor;
    5587                 :            : 
    5588                 :          2 :   int count[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS],
    5589                 :            :       sstride[GFC_MAX_DIMENSIONS], dstride[GFC_MAX_DIMENSIONS],
    5590                 :            :       tmpstride[GFC_MAX_DIMENSIONS];
    5591                 :            : 
    5592                 :            :   /* Shortcut for constant .FALSE. MASK.  */
    5593                 :          2 :   if (mask
    5594                 :          0 :       && mask->expr_type == EXPR_CONSTANT
    5595                 :          0 :       && !mask->value.logical)
    5596                 :            :     return result;
    5597                 :            : 
    5598                 :            :   /* Build an indexed table for array element expressions to minimize
    5599                 :            :      linked-list traversal. Masked elements are set to NULL.  */
    5600                 :          2 :   gfc_array_size (array, &size);
    5601                 :          2 :   arraysize = mpz_get_ui (size);
    5602                 :          2 :   mpz_clear (size);
    5603                 :            : 
    5604                 :          2 :   arrayvec = XCNEWVEC (gfc_expr*, arraysize);
    5605                 :            : 
    5606                 :          2 :   array_ctor = gfc_constructor_first (array->value.constructor);
    5607                 :          2 :   mask_ctor = NULL;
    5608                 :          2 :   if (mask && mask->expr_type == EXPR_ARRAY)
    5609                 :          0 :     mask_ctor = gfc_constructor_first (mask->value.constructor);
    5610                 :            : 
    5611                 :         14 :   for (i = 0; i < arraysize; ++i)
    5612                 :            :     {
    5613                 :         12 :       arrayvec[i] = array_ctor->expr;
    5614                 :         12 :       array_ctor = gfc_constructor_next (array_ctor);
    5615                 :            : 
    5616                 :         12 :       if (mask_ctor)
    5617                 :            :         {
    5618                 :          0 :           if (!mask_ctor->expr->value.logical)
    5619                 :          0 :             arrayvec[i] = NULL;
    5620                 :            : 
    5621                 :          0 :           mask_ctor = gfc_constructor_next (mask_ctor);
    5622                 :            :         }
    5623                 :            :     }
    5624                 :            : 
    5625                 :            :   /* Same for the result expression.  */
    5626                 :          2 :   gfc_array_size (result, &size);
    5627                 :          2 :   resultsize = mpz_get_ui (size);
    5628                 :          2 :   mpz_clear (size);
    5629                 :            : 
    5630                 :          2 :   resultvec = XCNEWVEC (gfc_expr*, resultsize);
    5631                 :          2 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5632                 :          7 :   for (i = 0; i < resultsize; ++i)
    5633                 :            :     {
    5634                 :          5 :       resultvec[i] = result_ctor->expr;
    5635                 :          5 :       result_ctor = gfc_constructor_next (result_ctor);
    5636                 :            :     }
    5637                 :            : 
    5638                 :          2 :   gfc_extract_int (dim, &dim_index);
    5639                 :            : 
    5640                 :          2 :   dim_index -= 1;       /* Zero-base index.  */
    5641                 :          2 :   dim_extent = 0;
    5642                 :          2 :   dim_stride = 0;
    5643                 :            : 
    5644                 :          6 :   for (i = 0, n = 0; i < array->rank; ++i)
    5645                 :            :     {
    5646                 :          4 :       count[i] = 0;
    5647                 :          4 :       tmpstride[i] = (i == 0) ? 1 : tmpstride[i-1] * mpz_get_si (array->shape[i-1]);
    5648                 :          4 :       if (i == dim_index)
    5649                 :            :         {
    5650                 :          2 :           dim_extent = mpz_get_si (array->shape[i]);
    5651                 :          2 :           dim_stride = tmpstride[i];
    5652                 :          2 :           continue;
    5653                 :            :         }
    5654                 :            : 
    5655                 :          2 :       extent[n] = mpz_get_si (array->shape[i]);
    5656                 :          2 :       sstride[n] = tmpstride[i];
    5657                 :          2 :       dstride[n] = (n == 0) ? 1 : dstride[n-1] * extent[n-1];
    5658                 :          2 :       n += 1;
    5659                 :            :     }
    5660                 :            : 
    5661                 :          2 :   done = resultsize <= 0;
    5662                 :          2 :   base = arrayvec;
    5663                 :          2 :   dest = resultvec;
    5664                 :          7 :   while (!done)
    5665                 :            :     {
    5666                 :          9 :       for (src = base, n = 0; n < dim_extent; src += dim_stride, ++n)
    5667                 :            :         {
    5668                 :          8 :           if (*src && gfc_compare_expr (*src, value, INTRINSIC_EQ) == 0)
    5669                 :            :             {
    5670                 :          4 :               mpz_set_si ((*dest)->value.integer, n + 1);
    5671                 :          4 :               if (!back_val)
    5672                 :            :                 break;
    5673                 :            :             }
    5674                 :            :         }
    5675                 :            : 
    5676                 :          5 :       count[0]++;
    5677                 :          5 :       base += sstride[0];
    5678                 :          5 :       dest += dstride[0];
    5679                 :            : 
    5680                 :          5 :       n = 0;
    5681                 :          7 :       while (!done && count[n] == extent[n])
    5682                 :            :         {
    5683                 :          2 :           count[n] = 0;
    5684                 :          2 :           base -= sstride[n] * extent[n];
    5685                 :          2 :           dest -= dstride[n] * extent[n];
    5686                 :            : 
    5687                 :          2 :           n++;
    5688                 :          2 :           if (n < result->rank)
    5689                 :            :             {
    5690                 :            :               /* If the nested loop is unrolled GFC_MAX_DIMENSIONS
    5691                 :            :                  times, we'd warn for the last iteration, because the
    5692                 :            :                  array index will have already been incremented to the
    5693                 :            :                  array sizes, and we can't tell that this must make
    5694                 :            :                  the test against result->rank false, because ranks
    5695                 :            :                  must not exceed GFC_MAX_DIMENSIONS.  */
    5696                 :          0 :               GCC_DIAGNOSTIC_PUSH_IGNORED (-Warray-bounds)
    5697                 :          0 :               count[n]++;
    5698                 :          0 :               base += sstride[n];
    5699                 :          0 :               dest += dstride[n];
    5700                 :          0 :               GCC_DIAGNOSTIC_POP
    5701                 :            :             }
    5702                 :            :           else
    5703                 :            :             done = true;
    5704                 :            :        }
    5705                 :            :     }
    5706                 :            : 
    5707                 :            :   /* Place updated expression in result constructor.  */
    5708                 :          2 :   result_ctor = gfc_constructor_first (result->value.constructor);
    5709                 :          7 :   for (i = 0; i < resultsize; ++i)
    5710                 :            :     {
    5711                 :          5 :       result_ctor->expr = resultvec[i];
    5712                 :          5 :       result_ctor = gfc_constructor_next (result_ctor);
    5713                 :            :     }
    5714                 :            : 
    5715                 :          2 :   free (arrayvec);
    5716                 :          2 :   free (resultvec);
    5717                 :          2 :   return result;
    5718                 :            : }
    5719                 :            : 
    5720                 :            : /* Simplify findloc.  */
    5721                 :            : 
    5722                 :            : gfc_expr *
    5723                 :        972 : gfc_simplify_findloc (gfc_expr *array, gfc_expr *value, gfc_expr *dim,
    5724                 :            :                       gfc_expr *mask, gfc_expr *kind, gfc_expr *back)
    5725                 :            : {
    5726                 :        972 :   gfc_expr *result;
    5727                 :        972 :   int ikind;
    5728                 :        972 :   bool back_val = false;
    5729                 :            : 
    5730                 :        972 :   if (!is_constant_array_expr (array)
    5731                 :        972 :       || !gfc_is_constant_expr (dim))
    5732                 :        948 :     return NULL;
    5733                 :            : 
    5734                 :         24 :   if (! gfc_is_constant_expr (value))
    5735                 :            :     return 0;
    5736                 :            : 
    5737                 :         24 :   if (mask
    5738                 :          3 :       && !is_constant_array_expr (mask)
    5739                 :         24 :       && mask->expr_type != EXPR_CONSTANT)
    5740                 :            :     return NULL;
    5741                 :            : 
    5742                 :         24 :   if (kind)
    5743                 :            :     {
    5744                 :          0 :       if (gfc_extract_int (kind, &ikind, -1))
    5745                 :            :         return NULL;
    5746                 :            :     }
    5747                 :            :   else
    5748                 :         24 :     ikind = gfc_default_integer_kind;
    5749                 :            : 
    5750                 :         24 :   if (back)
    5751                 :            :     {
    5752                 :         24 :       if (back->expr_type != EXPR_CONSTANT)
    5753                 :            :         return NULL;
    5754                 :            : 
    5755                 :         22 :       back_val = back->value.logical;
    5756                 :            :     }
    5757                 :            : 
    5758                 :         22 :   if (dim)
    5759                 :            :     {
    5760                 :          9 :       result = transformational_result (array, dim, BT_INTEGER,
    5761                 :            :                                         ikind, &array->where);
    5762                 :          9 :       init_result_expr (result, 0, array);
    5763                 :            : 
    5764                 :          9 :       if (array->rank == 1)
    5765                 :          7 :         return simplify_findloc_to_scalar (result, array, value, mask,
    5766                 :          7 :                                            back_val);
    5767                 :            :       else
    5768                 :          2 :         return simplify_findloc_to_array (result, array, value, dim, mask,
    5769                 :          2 :                                           back_val);
    5770                 :            :     }
    5771                 :            :   else
    5772                 :            :     {
    5773                 :         13 :       result = new_array (BT_INTEGER, ikind, array->rank, &array->where);
    5774                 :         13 :       return simplify_findloc_nodim (result, value, array, mask, back_val);
    5775                 :            :     }
    5776                 :            :   return NULL;
    5777                 :            : }
    5778                 :            : 
    5779                 :            : gfc_expr *
    5780                 :          0 : gfc_simplify_maxexponent (gfc_expr *x)
    5781                 :            : {
    5782                 :          0 :   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
    5783                 :          0 :   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
    5784                 :          0 :                            gfc_real_kinds[i].max_exponent);
    5785                 :            : }
    5786                 :            : 
    5787                 :            : 
    5788                 :            : gfc_expr *
    5789                 :         24 : gfc_simplify_minexponent (gfc_expr *x)
    5790                 :            : {
    5791                 :         24 :   int i = gfc_validate_kind (BT_REAL, x->ts.kind, false);
    5792                 :         24 :   return gfc_get_int_expr (gfc_default_integer_kind, &x->where,
    5793                 :         24 :                            gfc_real_kinds[i].min_exponent);
    5794                 :            : }
    5795                 :            : 
    5796                 :            : 
    5797                 :            : gfc_expr *
    5798                 :     265075 : gfc_simplify_mod (gfc_expr *a, gfc_expr *p)
    5799                 :            : {
    5800                 :     265075 :   gfc_expr *result;
    5801                 :     265075 :   int kind;
    5802                 :            : 
    5803                 :            :   /* First check p.  */
    5804                 :     265075 :   if (p->expr_type != EXPR_CONSTANT)
    5805                 :            :     return NULL;
    5806                 :            : 
    5807                 :            :   /* p shall not be 0.  */
    5808                 :     264738 :   switch (p->ts.type)
    5809                 :            :     {
    5810                 :     264528 :       case BT_INTEGER:
    5811                 :     264528 :         if (mpz_cmp_ui (p->value.integer, 0) == 0)
    5812                 :            :           {
    5813                 :          4 :             gfc_error ("Argument %qs of MOD at %L shall not be zero",
    5814                 :            :                         "P", &p->where);
    5815                 :          4 :             return &gfc_bad_expr;
    5816                 :            :           }
    5817                 :            :         break;
    5818                 :        210 :       case BT_REAL:
    5819                 :        210 :         if (mpfr_cmp_ui (p->value.real, 0) == 0)
    5820                 :            :           {
    5821                 :          0 :             gfc_error ("Argument %qs of MOD at %L shall not be zero",
    5822                 :            :                         "P", &p->where);
    5823                 :          0 :             return &gfc_bad_expr;
    5824                 :            :           }
    5825                 :            :         break;
    5826                 :          0 :       default:
    5827                 :          0 :         gfc_internal_error ("gfc_simplify_mod(): Bad arguments");
    5828                 :            :     }
    5829                 :            : 
    5830                 :     264734 :   if (a->expr_type != EXPR_CONSTANT)
    5831                 :            :     return NULL;
    5832                 :            : 
    5833                 :     262773 :   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
    5834                 :     262773 :   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
    5835                 :            : 
    5836                 :     262773 :   if (a->ts.type == BT_INTEGER)
    5837                 :     262665 :     mpz_tdiv_r (result->value.integer, a->value.integer, p->value.integer);
    5838                 :            :   else
    5839                 :            :     {
    5840                 :        108 :       gfc_set_model_kind (kind);
    5841                 :        108 :       mpfr_fmod (result->value.real, a->value.real, p->value.real,
    5842                 :            :                  GFC_RND_MODE);
    5843                 :            :     }
    5844                 :            : 
    5845                 :     262773 :   return range_check (result, "MOD");
    5846                 :            : }
    5847                 :            : 
    5848                 :            : 
    5849                 :            : gfc_expr *
    5850                 :       1560 : gfc_simplify_modulo (gfc_expr *a, gfc_expr *p)
    5851                 :            : {
    5852                 :       1560 :   gfc_expr *result;
    5853                 :       1560 :   int kind;
    5854                 :            : 
    5855                 :            :   /* First check p.  */
    5856                 :       1560 :   if (p->expr_type != EXPR_CONSTANT)
    5857                 :            :     return NULL;
    5858                 :            : 
    5859                 :            :   /* p shall not be 0.  */
    5860                 :       1460 :   switch (p->ts.type)
    5861                 :            :     {
    5862                 :       1424 :       case BT_INTEGER:
    5863                 :       1424 :         if (mpz_cmp_ui (p->value.integer, 0) == 0)
    5864                 :            :           {
    5865                 :          4 :             gfc_error ("Argument %qs of MODULO at %L shall not be zero",
    5866                 :            :                         "P", &p->where);
    5867                 :          4 :             return &gfc_bad_expr;
    5868                 :            :           }
    5869                 :            :         break;
    5870                 :         36 :       case BT_REAL:
    5871                 :         36 :         if (mpfr_cmp_ui (p->value.real, 0) == 0)
    5872                 :            :           {
    5873                 :          0 :             gfc_error ("Argument %qs of MODULO at %L shall not be zero",
    5874                 :            :                         "P", &p->where);
    5875                 :          0 :             return &gfc_bad_expr;
    5876                 :            :           }
    5877                 :            :         break;
    5878                 :          0 :       default:
    5879                 :          0 :         gfc_internal_error ("gfc_simplify_modulo(): Bad arguments");
    5880                 :            :     }
    5881                 :            : 
    5882                 :       1456 :   if (a->expr_type != EXPR_CONSTANT)
    5883                 :            :     return NULL;
    5884                 :            : 
    5885                 :        234 :   kind = a->ts.kind > p->ts.kind ? a->ts.kind : p->ts.kind;
    5886                 :        234 :   result = gfc_get_constant_expr (a->ts.type, kind, &a->where);
    5887                 :            : 
    5888                 :        234 :   if (a->ts.type == BT_INTEGER)
    5889                 :        198 :         mpz_fdiv_r (result->value.integer, a->value.integer, p->value.integer);
    5890                 :            :   else
    5891                 :            :     {
    5892                 :         36 :       gfc_set_model_kind (kind);
    5893                 :         36 :       mpfr_fmod (result->value.real, a->value.real, p->value.real,
    5894                 :            :                  GFC_RND_MODE);
    5895                 :         36 :       if (mpfr_cmp_ui (result->value.real, 0) != 0)
    5896                 :            :         {
    5897                 :         12 :           if (mpfr_signbit (a->value.real) != mpfr_signbit (p->value.real))
    5898                 :          6 :             mpfr_add (result->value.real, result->value.real, p->value.real,
    5899                 :            :                       GFC_RND_MODE);
    5900                 :            :             }
    5901                 :            :           else
    5902                 :         24 :         mpfr_copysign (result->value.real, result->value.real,
    5903                 :            :                        p->value.real, GFC_RND_MODE);
    5904                 :            :     }
    5905                 :            : 
    5906                 :        234 :   return range_check (result, "MODULO");
    5907                 :            : }
    5908                 :            : 
    5909                 :            : 
    5910                 :            : gfc_expr *
    5911                 :       3798 : gfc_simplify_nearest (gfc_expr *x, gfc_expr *s)
    5912                 :            : {
    5913                 :       3798 :   gfc_expr *result;
    5914                 :       3798 :   mpfr_exp_t emin, emax;
    5915                 :       3798 :   int kind;
    5916                 :            : 
    5917                 :       3798 :   if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
    5918                 :            :     return NULL;
    5919                 :            : 
    5920                 :        802 :   result = gfc_copy_expr (x);
    5921                 :            : 
    5922                 :            :   /* Save current values of emin and emax.  */
    5923                 :        802 :   emin = mpfr_get_emin ();
    5924                 :        802 :   emax = mpfr_get_emax ();
    5925                 :            : 
    5926                 :            :   /* Set emin and emax for the current model number.  */
    5927                 :        802 :   kind = gfc_validate_kind (BT_REAL, x->ts.kind, 0);
    5928                 :        802 :   mpfr_set_emin ((mpfr_exp_t) gfc_real_kinds[kind].min_exponent -
    5929                 :        802 :                 mpfr_get_prec(result->value.real) + 1);
    5930                 :        802 :   mpfr_set_emax ((mpfr_exp_t) gfc_real_kinds[kind].max_exponent - 1);
    5931                 :        802 :   mpfr_check_range (result->value.real, 0, MPFR_RNDU);
    5932                 :            : 
    5933                 :        802 :   if (mpfr_sgn (s->value.real) > 0)
    5934                 :            :     {
    5935                 :        392 :       mpfr_nextabove (result->value.real);
    5936                 :        392 :       mpfr_subnormalize (result->value.real, 0, MPFR_RNDU);
    5937                 :            :     }
    5938                 :            :   else
    5939                 :            :     {
    5940                 :        410 :       mpfr_nextbelow (result->value.real);
    5941                 :        410 :       mpfr_subnormalize (result->value.real, 0, MPFR_RNDD);
    5942                 :            :     }
    5943                 :            : 
    5944                 :        802 :   mpfr_set_emin (emin);
    5945                 :        802 :   mpfr_set_emax (emax);
    5946                 :            : 
    5947                 :            :   /* Only NaN can occur. Do not use range check as it gives an
    5948                 :            :      error for denormal numbers.  */
    5949                 :        802 :   if (mpfr_nan_p (result->value.real) && flag_range_check)
    5950                 :            :     {
    5951                 :          0 :       gfc_error ("Result of NEAREST is NaN at %L", &result->where);
    5952                 :          0 :       gfc_free_expr (result);
    5953                 :          0 :       return &gfc_bad_expr;
    5954                 :            :     }
    5955                 :            : 
    5956                 :            :   return result;
    5957                 :            : }
    5958                 :            : 
    5959                 :            : 
    5960                 :            : static gfc_expr *
    5961                 :        308 : simplify_nint (const char *name, gfc_expr *e, gfc_expr *k)
    5962                 :            : {
    5963                 :        308 :   gfc_expr *itrunc, *result;
    5964                 :        308 :   int kind;
    5965                 :            : 
    5966                 :        308 :   kind = get_kind (BT_INTEGER, k, name, gfc_default_integer_kind);
    5967                 :        308 :   if (kind == -1)
    5968                 :            :     return &gfc_bad_expr;
    5969                 :            : 
    5970                 :        308 :   if (e->expr_type != EXPR_CONSTANT)
    5971                 :            :     return NULL;
    5972                 :            : 
    5973                 :        133 :   itrunc = gfc_copy_expr (e);
    5974                 :        133 :   mpfr_round (itrunc->value.real, e->value.real);
    5975                 :            : 
    5976                 :        133 :   result = gfc_get_constant_expr (BT_INTEGER, kind, &e->where);
    5977                 :        133 :   gfc_mpfr_to_mpz (result->value.integer, itrunc->value.real, &e->where);
    5978                 :            : 
    5979                 :        133 :   gfc_free_expr (itrunc);
    5980                 :            : 
    5981                 :        133 :   return range_check (result, name);
    5982                 :            : }
    5983                 :            : 
    5984                 :            : 
    5985                 :            : gfc_expr *
    5986                 :        324 : gfc_simplify_new_line (gfc_expr *e)
    5987                 :            : {
    5988                 :        324 :   gfc_expr *result;
    5989                 :            : 
    5990                 :        324 :   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, 1);
    5991                 :        324 :   result->value.character.string[0] = '\n';
    5992                 :            : 
    5993                 :        324 :   return result;
    5994                 :            : }
    5995                 :            : 
    5996                 :            : 
    5997                 :            : gfc_expr *
    5998                 :        228 : gfc_simplify_nint (gfc_expr *e, gfc_expr *k)
    5999                 :            : {
    6000                 :        228 :   return simplify_nint ("NINT", e, k);
    6001                 :            : }
    6002                 :            : 
    6003                 :            : 
    6004                 :            : gfc_expr *
    6005                 :         80 : gfc_simplify_idnint (gfc_expr *e)
    6006                 :            : {
    6007                 :         80 :   return simplify_nint ("IDNINT", e, NULL);
    6008                 :            : }
    6009                 :            : 
    6010                 :            : static int norm2_scale;
    6011                 :            : 
    6012                 :            : static gfc_expr *
    6013                 :        120 : norm2_add_squared (gfc_expr *result, gfc_expr *e)
    6014                 :            : {
    6015                 :        120 :   mpfr_t tmp;
    6016                 :            : 
    6017                 :        120 :   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
    6018                 :        120 :   gcc_assert (result->ts.type == BT_REAL
    6019                 :            :               && result->expr_type == EXPR_CONSTANT);
    6020                 :            : 
    6021                 :        120 :   gfc_set_model_kind (result->ts.kind);
    6022                 :        120 :   int index = gfc_validate_kind (BT_REAL, result->ts.kind, false);
    6023                 :        120 :   mpfr_exp_t exp;
    6024                 :        120 :   if (mpfr_regular_p (result->value.real))
    6025                 :            :     {
    6026                 :         60 :       exp = mpfr_get_exp (result->value.real);
    6027                 :            :       /* If result is getting close to overflowing, scale down.  */
    6028                 :         60 :       if (exp >= gfc_real_kinds[index].max_exponent - 4
    6029                 :          0 :           && norm2_scale <= gfc_real_kinds[index].max_exponent - 2)
    6030                 :            :         {
    6031                 :          0 :           norm2_scale += 2;
    6032                 :          0 :           mpfr_div_ui (result->value.real, result->value.real, 16,
    6033                 :            :                        GFC_RND_MODE);
    6034                 :            :         }
    6035                 :            :     }
    6036                 :            : 
    6037                 :        120 :   mpfr_init (tmp);
    6038                 :        120 :   if (mpfr_regular_p (e->value.real))
    6039                 :            :     {
    6040                 :         84 :       exp = mpfr_get_exp (e->value.real);
    6041                 :            :       /* If e**2 would overflow or close to overflowing, scale down.  */
    6042                 :         84 :       if (exp - norm2_scale >= gfc_real_kinds[index].max_exponent / 2 - 2)
    6043                 :            :         {
    6044                 :         12 :           int new_scale = gfc_real_kinds[index].max_exponent / 2 + 4;
    6045                 :         12 :           mpfr_set_ui (tmp, 1, GFC_RND_MODE);
    6046                 :         12 :           mpfr_set_exp (tmp, new_scale - norm2_scale);
    6047                 :         12 :           mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
    6048                 :         12 :           mpfr_div (result->value.real, result->value.real, tmp, GFC_RND_MODE);
    6049                 :         12 :           norm2_scale = new_scale;
    6050                 :            :         }
    6051                 :            :     }
    6052                 :        120 :   if (norm2_scale)
    6053                 :            :     {
    6054                 :         12 :       mpfr_set_ui (tmp, 1, GFC_RND_MODE);
    6055                 :         12 :       mpfr_set_exp (tmp, norm2_scale);
    6056                 :         12 :       mpfr_div (tmp, e->value.real, tmp, GFC_RND_MODE);
    6057                 :            :     }
    6058                 :            :   else
    6059                 :        108 :     mpfr_set (tmp, e->value.real, GFC_RND_MODE);
    6060                 :        120 :   mpfr_pow_ui (tmp, tmp, 2, GFC_RND_MODE);
    6061                 :        120 :   mpfr_add (result->value.real, result->value.real, tmp,
    6062                 :            :             GFC_RND_MODE);
    6063                 :        120 :   mpfr_clear (tmp);
    6064                 :            : 
    6065                 :        120 :   return result;
    6066                 :            : }
    6067                 :            : 
    6068                 :            : 
    6069                 :            : static gfc_expr *
    6070                 :          0 : norm2_do_sqrt (gfc_expr *result, gfc_expr *e)
    6071                 :            : {
    6072                 :          0 :   gcc_assert (e->ts.type == BT_REAL && e->expr_type == EXPR_CONSTANT);
    6073                 :          0 :   gcc_assert (result->ts.type == BT_REAL
    6074                 :            :               && result->expr_type == EXPR_CONSTANT);
    6075                 :            : 
    6076                 :          0 :   if (result != e)
    6077                 :          0 :     mpfr_set (result->value.real, e->value.real, GFC_RND_MODE);
    6078                 :          0 :   mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
    6079                 :          0 :   if (norm2_scale && mpfr_regular_p (result->value.real))
    6080                 :            :     {
    6081                 :          0 :       mpfr_t tmp;
    6082                 :          0 :       mpfr_init (tmp);
    6083                 :          0 :       mpfr_set_ui (tmp, 1, GFC_RND_MODE);
    6084                 :          0 :       mpfr_set_exp (tmp, norm2_scale);
    6085                 :          0 :       mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
    6086                 :          0 :       mpfr_clear (tmp);
    6087                 :            :     }
    6088                 :          0 :   norm2_scale = 0;
    6089                 :            : 
    6090                 :          0 :   return result;
    6091                 :            : }
    6092                 :            : 
    6093                 :            : 
    6094                 :            : gfc_expr *
    6095                 :        357 : gfc_simplify_norm2 (gfc_expr *e, gfc_expr *dim)
    6096                 :            : {
    6097                 :        357 :   gfc_expr *result;
    6098                 :        357 :   bool size_zero;
    6099                 :            : 
    6100                 :        357 :   size_zero = gfc_is_size_zero_array (e);
    6101                 :            : 
    6102                 :        653 :   if (!(is_constant_array_expr (e) || size_zero)
    6103                 :        357 :       || (dim != NULL && !gfc_is_constant_expr (dim)))
    6104                 :        296 :     return NULL;
    6105                 :            : 
    6106                 :         61 :   result = transformational_result (e, dim, e->ts.type, e->ts.kind, &e->where);
    6107                 :         61 :   init_result_expr (result, 0, NULL);
    6108                 :            : 
    6109                 :         61 :   if (size_zero)
    6110                 :            :     return result;
    6111                 :            : 
    6112                 :         36 :   norm2_scale = 0;
    6113                 :         36 :   if (!dim || e->rank == 1)
    6114                 :            :     {
    6115                 :         36 :       result = simplify_transformation_to_scalar (result, e, NULL,
    6116                 :            :                                                   norm2_add_squared);
    6117                 :         36 :       mpfr_sqrt (result->value.real, result->value.real, GFC_RND_MODE);
    6118                 :         36 :       if (norm2_scale && mpfr_regular_p (result->value.real))
    6119                 :            :         {
    6120                 :         12 :           mpfr_t tmp;
    6121                 :         12 :           mpfr_init (tmp);
    6122                 :         12 :           mpfr_set_ui (tmp, 1, GFC_RND_MODE);
    6123                 :         12 :           mpfr_set_exp (tmp, norm2_scale);
    6124                 :         12 :           mpfr_mul (result->value.real, result->value.real, tmp, GFC_RND_MODE);
    6125                 :         12 :           mpfr_clear (tmp);
    6126                 :            :         }
    6127                 :         36 :       norm2_scale = 0;
    6128                 :            :     }
    6129                 :            :   else
    6130                 :          0 :     result = simplify_transformation_to_array (result, e, dim, NULL,
    6131                 :            :                                                norm2_add_squared,
    6132                 :            :                                                norm2_do_sqrt);
    6133                 :            : 
    6134                 :            :   return result;
    6135                 :            : }
    6136                 :            : 
    6137                 :            : 
    6138                 :            : gfc_expr *
    6139                 :        427 : gfc_simplify_not (gfc_expr *e)
    6140                 :            : {
    6141                 :        427 :   gfc_expr *result;
    6142                 :            : 
    6143                 :        427 :   if (e->expr_type != EXPR_CONSTANT)
    6144                 :            :     return NULL;
    6145                 :            : 
    6146                 :        181 :   result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    6147                 :        181 :   mpz_com (result->value.integer, e->value.integer);
    6148                 :            : 
    6149                 :        181 :   return range_check (result, "NOT");
    6150                 :            : }
    6151                 :            : 
    6152                 :            : 
    6153                 :            : gfc_expr *
    6154                 :        815 : gfc_simplify_null (gfc_expr *mold)
    6155                 :            : {
    6156                 :        815 :   gfc_expr *result;
    6157                 :            : 
    6158                 :        815 :   if (mold)
    6159                 :            :     {
    6160                 :         84 :       result = gfc_copy_expr (mold);
    6161                 :         84 :       result->expr_type = EXPR_NULL;
    6162                 :            :     }
    6163                 :            :   else
    6164                 :        731 :     result = gfc_get_null_expr (NULL);
    6165                 :            : 
    6166                 :        815 :   return result;
    6167                 :            : }
    6168                 :            : 
    6169                 :            : 
    6170                 :            : gfc_expr *
    6171                 :       1073 : gfc_simplify_num_images (gfc_expr *distance ATTRIBUTE_UNUSED, gfc_expr *failed)
    6172                 :            : {
    6173                 :       1073 :   gfc_expr *result;
    6174                 :            : 
    6175                 :       1073 :   if (flag_coarray == GFC_FCOARRAY_NONE)
    6176                 :            :     {
    6177                 :          0 :       gfc_fatal_error ("Coarrays disabled at %C, use %<-fcoarray=%> to enable");
    6178                 :            :       return &gfc_bad_expr;
    6179                 :            :     }
    6180                 :            : 
    6181                 :       1073 :   if (flag_coarray != GFC_FCOARRAY_SINGLE)
    6182                 :            :     return NULL;
    6183                 :            : 
    6184                 :        375 :   if (failed && failed->expr_type != EXPR_CONSTANT)
    6185                 :            :     return NULL;
    6186                 :            : 
    6187                 :            :   /* FIXME: gfc_current_locus is wrong.  */
    6188                 :        375 :   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
    6189                 :            :                                   &gfc_current_locus);
    6190                 :            : 
    6191                 :        375 :   if (failed && failed->value.logical != 0)
    6192                 :          1 :     mpz_set_si (result->value.integer, 0);
    6193                 :            :   else
    6194                 :        374 :     mpz_set_si (result->value.integer, 1);
    6195                 :            : 
    6196                 :            :   return result;
    6197                 :            : }
    6198                 :            : 
    6199                 :            : 
    6200                 :            : gfc_expr *
    6201                 :         20 : gfc_simplify_or (gfc_expr *x, gfc_expr *y)
    6202                 :            : {
    6203                 :         20 :   gfc_expr *result;
    6204                 :         20 :   int kind;
    6205                 :            : 
    6206                 :         20 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    6207                 :            :     return NULL;
    6208                 :            : 
    6209                 :          6 :   kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
    6210                 :            : 
    6211                 :          6 :   switch (x->ts.type)
    6212                 :            :     {
    6213                 :          0 :       case BT_INTEGER:
    6214                 :          0 :         result = gfc_get_constant_expr (BT_INTEGER, kind, &x->where);
    6215                 :          0 :         mpz_ior (result->value.integer, x->value.integer, y->value.integer);
    6216                 :          0 :         return range_check (result, "OR");
    6217                 :            : 
    6218                 :          6 :       case BT_LOGICAL:
    6219                 :          6 :         return gfc_get_logical_expr (kind, &x->where,
    6220                 :         12 :                                      x->value.logical || y->value.logical);
    6221                 :          0 :       default:
    6222                 :          0 :         gcc_unreachable();
    6223                 :            :     }
    6224                 :            : }
    6225                 :            : 
    6226                 :            : 
    6227                 :            : gfc_expr *
    6228                 :        824 : gfc_simplify_pack (gfc_expr *array, gfc_expr *mask, gfc_expr *vector)
    6229                 :            : {
    6230                 :        824 :   gfc_expr *result;
    6231                 :        824 :   gfc_constructor *array_ctor, *mask_ctor, *vector_ctor;
    6232                 :            : 
    6233                 :        824 :   if (!is_constant_array_expr (array)
    6234                 :         17 :       || !is_constant_array_expr (vector)
    6235                 :        841 :       || (!gfc_is_constant_expr (mask)
    6236                 :          1 :           && !is_constant_array_expr (mask)))
    6237                 :        808 :     return NULL;
    6238                 :            : 
    6239                 :         16 :   result = gfc_get_array_expr (array->ts.type, array->ts.kind, &array->where);
    6240                 :         16 :   if (array->ts.type == BT_DERIVED)
    6241                 :          1 :     result->ts.u.derived = array->ts.u.derived;
    6242                 :            : 
    6243                 :         16 :   array_ctor = gfc_constructor_first (array->value.constructor);
    6244                 :         32 :   vector_ctor = vector
    6245                 :         16 :                   ? gfc_constructor_first (vector->value.constructor)
    6246                 :            :                   : NULL;
    6247                 :            : 
    6248                 :         16 :   if (mask->expr_type == EXPR_CONSTANT
    6249                 :          0 :       && mask->value.logical)
    6250                 :            :     {
    6251                 :            :       /* Copy all elements of ARRAY to RESULT.  */
    6252                 :          0 :       while (array_ctor)
    6253                 :            :         {
    6254                 :          0 :           gfc_constructor_append_expr (&result->value.constructor,
    6255                 :            :                                        gfc_copy_expr (array_ctor->expr),
    6256                 :            :                                        NULL);
    6257                 :            : 
    6258                 :          0 :           array_ctor = gfc_constructor_next (array_ctor);
    6259                 :          0 :           vector_ctor = gfc_constructor_next (vector_ctor);
    6260                 :            :         }
    6261                 :            :     }
    6262                 :         16 :   else if (mask->expr_type == EXPR_ARRAY)
    6263                 :            :     {
    6264                 :            :       /* Copy only those elements of ARRAY to RESULT whose
    6265                 :            :          MASK equals .TRUE..  */
    6266                 :         16 :       mask_ctor = gfc_constructor_first (mask->value.constructor);
    6267                 :        162 :       while (mask_ctor)
    6268                 :            :         {
    6269                 :        146 :           if (mask_ctor->expr->value.logical)
    6270                 :            :             {
    6271                 :         90 :               gfc_constructor_append_expr (&result->value.constructor,
    6272                 :            :                                            gfc_copy_expr (array_ctor->expr),
    6273                 :            :                                            NULL);
    6274                 :         90 :               vector_ctor = gfc_constructor_next (vector_ctor);
    6275                 :            :             }
    6276                 :            : 
    6277                 :        146 :           array_ctor = gfc_constructor_next (array_ctor);
    6278                 :        146 :           mask_ctor = gfc_constructor_next (mask_ctor);
    6279                 :            :         }
    6280                 :            :     }
    6281                 :            : 
    6282                 :            :   /* Append any left-over elements from VECTOR to RESULT.  */
    6283                 :         44 :   while (vector_ctor)
    6284                 :            :     {
    6285                 :         28 :       gfc_constructor_append_expr (&result->value.constructor,
    6286                 :            :                                    gfc_copy_expr (vector_ctor->expr),
    6287                 :            :                                    NULL);
    6288                 :         28 :       vector_ctor = gfc_constructor_next (vector_ctor);
    6289                 :            :     }
    6290                 :            : 
    6291                 :         16 :   result->shape = gfc_get_shape (1);
    6292                 :         16 :   gfc_array_size (result, &result->shape[0]);
    6293                 :            : 
    6294                 :         16 :   if (array->ts.type == BT_CHARACTER)
    6295                 :         14 :     result->ts.u.cl = array->ts.u.cl;
    6296                 :            : 
    6297                 :            :   return result;
    6298                 :            : }
    6299                 :            : 
    6300                 :            : 
    6301                 :            : static gfc_expr *
    6302                 :        120 : do_xor (gfc_expr *result, gfc_expr *e)
    6303                 :            : {
    6304                 :        120 :   gcc_assert (e->ts.type == BT_LOGICAL && e->expr_type == EXPR_CONSTANT);
    6305                 :        120 :   gcc_assert (result->ts.type == BT_LOGICAL
    6306                 :            :               && result->expr_type == EXPR_CONSTANT);
    6307                 :            : 
    6308                 :        120 :   result->value.logical = result->value.logical != e->value.logical;
    6309                 :        120 :   return result;
    6310                 :            : }
    6311                 :            : 
    6312                 :            : 
    6313                 :            : gfc_expr *
    6314                 :         99 : gfc_simplify_is_contiguous (gfc_expr *array)
    6315                 :            : {
    6316                 :         99 :   if (gfc_is_simply_contiguous (array, false, true))
    6317                 :          1 :     return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 1);
    6318                 :            : 
    6319                 :         98 :   if (gfc_is_not_contiguous (array))
    6320                 :          4 :     return gfc_get_logical_expr (gfc_default_logical_kind, &array->where, 0);
    6321                 :            :     
    6322                 :            :   return NULL;
    6323                 :            : }
    6324                 :            : 
    6325                 :            : 
    6326                 :            : gfc_expr *
    6327                 :        145 : gfc_simplify_parity (gfc_expr *e, gfc_expr *dim)
    6328                 :            : {
    6329                 :        145 :   return simplify_transformation (e, dim, NULL, 0, do_xor);
    6330                 :            : }
    6331                 :            : 
    6332                 :            : 
    6333                 :            : gfc_expr *
    6334                 :        672 : gfc_simplify_popcnt (gfc_expr *e)
    6335                 :            : {
    6336                 :        672 :   int res, k;
    6337                 :        672 :   mpz_t x;
    6338                 :            : 
    6339                 :        672 :   if (e->expr_type != EXPR_CONSTANT)
    6340                 :            :     return NULL;
    6341                 :            : 
    6342                 :        642 :   k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    6343                 :            : 
    6344                 :            :   /* Convert argument to unsigned, then count the '1' bits.  */
    6345                 :        642 :   mpz_init_set (x, e->value.integer);
    6346                 :        642 :   convert_mpz_to_unsigned (x, gfc_integer_kinds[k].bit_size);
    6347                 :        642 :   res = mpz_popcount (x);
    6348                 :        642 :   mpz_clear (x);
    6349                 :            : 
    6350                 :        642 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, res);
    6351                 :            : }
    6352                 :            : 
    6353                 :            : 
    6354                 :            : gfc_expr *
    6355                 :        330 : gfc_simplify_poppar (gfc_expr *e)
    6356                 :            : {
    6357                 :        330 :   gfc_expr *popcnt;
    6358                 :        330 :   int i;
    6359                 :            : 
    6360                 :        330 :   if (e->expr_type != EXPR_CONSTANT)
    6361                 :            :     return NULL;
    6362                 :            : 
    6363                 :        300 :   popcnt = gfc_simplify_popcnt (e);
    6364                 :        300 :   gcc_assert (popcnt);
    6365                 :            : 
    6366                 :        300 :   bool fail = gfc_extract_int (popcnt, &i);
    6367                 :        300 :   gcc_assert (!fail);
    6368                 :            : 
    6369                 :        300 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i % 2);
    6370                 :            : }
    6371                 :            : 
    6372                 :            : 
    6373                 :            : gfc_expr *
    6374                 :        339 : gfc_simplify_precision (gfc_expr *e)
    6375                 :            : {
    6376                 :        339 :   int i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    6377                 :        339 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where,
    6378                 :        339 :                            gfc_real_kinds[i].precision);
    6379                 :            : }
    6380                 :            : 
    6381                 :            : 
    6382                 :            : gfc_expr *
    6383                 :        738 : gfc_simplify_product (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
    6384                 :            : {
    6385                 :        738 :   return simplify_transformation (array, dim, mask, 1, gfc_multiply);
    6386                 :            : }
    6387                 :            : 
    6388                 :            : 
    6389                 :            : gfc_expr *
    6390                 :         48 : gfc_simplify_radix (gfc_expr *e)
    6391                 :            : {
    6392                 :         48 :   int i;
    6393                 :         48 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    6394                 :            : 
    6395                 :         48 :   switch (e->ts.type)
    6396                 :            :     {
    6397                 :          0 :       case BT_INTEGER:
    6398                 :          0 :         i = gfc_integer_kinds[i].radix;
    6399                 :          0 :         break;
    6400                 :            : 
    6401                 :         48 :       case BT_REAL:
    6402                 :         48 :         i = gfc_real_kinds[i].radix;
    6403                 :         48 :         break;
    6404                 :            : 
    6405                 :          0 :       default:
    6406                 :          0 :         gcc_unreachable ();
    6407                 :            :     }
    6408                 :            : 
    6409                 :         48 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
    6410                 :            : }
    6411                 :            : 
    6412                 :            : 
    6413                 :            : gfc_expr *
    6414                 :        138 : gfc_simplify_range (gfc_expr *e)
    6415                 :            : {
    6416                 :        138 :   int i;
    6417                 :        138 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    6418                 :            : 
    6419                 :        138 :   switch (e->ts.type)
    6420                 :            :     {
    6421                 :         68 :       case BT_INTEGER:
    6422                 :         68 :         i = gfc_integer_kinds[i].range;
    6423                 :         68 :         break;
    6424                 :            : 
    6425                 :         70 :       case BT_REAL:
    6426                 :         70 :       case BT_COMPLEX:
    6427                 :         70 :         i = gfc_real_kinds[i].range;
    6428                 :         70 :         break;
    6429                 :            : 
    6430                 :          0 :       default:
    6431                 :          0 :         gcc_unreachable ();
    6432                 :            :     }
    6433                 :            : 
    6434                 :        138 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, i);
    6435                 :            : }
    6436                 :            : 
    6437                 :            : 
    6438                 :            : gfc_expr *
    6439                 :        613 : gfc_simplify_rank (gfc_expr *e)
    6440                 :            : {
    6441                 :            :   /* Assumed rank.  */
    6442                 :        613 :   if (e->rank == -1)
    6443                 :            :     return NULL;
    6444                 :            : 
    6445                 :        140 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
    6446                 :            : }
    6447                 :            : 
    6448                 :            : 
    6449                 :            : gfc_expr *
    6450                 :      24252 : gfc_simplify_real (gfc_expr *e, gfc_expr *k)
    6451                 :            : {
    6452                 :      24252 :   gfc_expr *result = NULL;
    6453                 :      24252 :   int kind, tmp1, tmp2;
    6454                 :            : 
    6455                 :            :   /* Convert BOZ to real, and return without range checking.  */
    6456                 :      24252 :   if (e->ts.type == BT_BOZ)
    6457                 :            :     {
    6458                 :            :       /* Determine kind for conversion of the BOZ.  */
    6459                 :         82 :       if (k)
    6460                 :         63 :         gfc_extract_int (k, &kind);
    6461                 :            :       else
    6462                 :         19 :         kind = gfc_default_real_kind;
    6463                 :            : 
    6464                 :         82 :       if (!gfc_boz2real (e, kind))
    6465                 :            :         return NULL;
    6466                 :         82 :       result = gfc_copy_expr (e);
    6467                 :         82 :       return result;
    6468                 :            :     }
    6469                 :            : 
    6470                 :      24170 :   if (e->ts.type == BT_COMPLEX)
    6471                 :       1391 :     kind = get_kind (BT_REAL, k, "REAL", e->ts.kind);
    6472                 :            :   else
    6473                 :      22779 :     kind = get_kind (BT_REAL, k, "REAL", gfc_default_real_kind);
    6474                 :            : 
    6475                 :      24170 :   if (kind == -1)
    6476                 :            :     return &gfc_bad_expr;
    6477                 :            : 
    6478                 :      24170 :   if (e->expr_type != EXPR_CONSTANT)
    6479                 :            :     return NULL;
    6480                 :            : 
    6481                 :            :   /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
    6482                 :            :      warnings.  */
    6483                 :      20893 :   tmp1 = warn_conversion;
    6484                 :      20893 :   tmp2 = warn_conversion_extra;
    6485                 :      20893 :   warn_conversion = warn_conversion_extra = 0;
    6486                 :            : 
    6487                 :      20893 :   result = gfc_convert_constant (e, BT_REAL, kind);
    6488                 :            : 
    6489                 :      20893 :   warn_conversion = tmp1;
    6490                 :      20893 :   warn_conversion_extra = tmp2;
    6491                 :            : 
    6492                 :      20893 :   if (result == &gfc_bad_expr)
    6493                 :            :     return &gfc_bad_expr;
    6494                 :            : 
    6495                 :      20892 :   return range_check (result, "REAL");
    6496                 :            : }
    6497                 :            : 
    6498                 :            : 
    6499                 :            : gfc_expr *
    6500                 :          2 : gfc_simplify_realpart (gfc_expr *e)
    6501                 :            : {
    6502                 :          2 :   gfc_expr *result;
    6503                 :            : 
    6504                 :          2 :   if (e->expr_type != EXPR_CONSTANT)
    6505                 :            :     return NULL;
    6506                 :            : 
    6507                 :          1 :   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
    6508                 :          1 :   mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
    6509                 :            : 
    6510                 :          1 :   return range_check (result, "REALPART");
    6511                 :            : }
    6512                 :            : 
    6513                 :            : gfc_expr *
    6514                 :       1953 : gfc_simplify_repeat (gfc_expr *e, gfc_expr *n)
    6515                 :            : {
    6516                 :       1953 :   gfc_expr *result;
    6517                 :       1953 :   gfc_charlen_t len;
    6518                 :       1953 :   mpz_t ncopies;
    6519                 :       1953 :   bool have_length = false;
    6520                 :            : 
    6521                 :            :   /* If NCOPIES isn't a constant, there's nothing we can do.  */
    6522                 :       1953 :   if (n->expr_type != EXPR_CONSTANT)
    6523                 :            :     return NULL;
    6524                 :            : 
    6525                 :            :   /* If NCOPIES is negative, it's an error.  */
    6526                 :       1459 :   if (mpz_sgn (n->value.integer) < 0)
    6527                 :            :     {
    6528                 :          6 :       gfc_error ("Argument NCOPIES of REPEAT intrinsic is negative at %L",
    6529                 :            :                  &n->where);
    6530                 :          6 :       return &gfc_bad_expr;
    6531                 :            :     }
    6532                 :            : 
    6533                 :            :   /* If we don't know the character length, we can do no more.  */
    6534                 :       1453 :   if (e->ts.u.cl && e->ts.u.cl->length
    6535                 :        344 :         && e->ts.u.cl->length->expr_type == EXPR_CONSTANT)
    6536                 :            :     {
    6537                 :        344 :       len = gfc_mpz_get_hwi (e->ts.u.cl->length->value.integer);
    6538                 :        344 :       have_length = true;
    6539                 :            :     }
    6540                 :       1109 :   else if (e->expr_type == EXPR_CONSTANT
    6541                 :       1109 :              && (e->ts.u.cl == NULL || e->ts.u.cl->length == NULL))
    6542                 :            :     {
    6543                 :       1109 :       len = e->value.character.length;
    6544                 :            :     }
    6545                 :            :   else
    6546                 :            :     return NULL;
    6547                 :            : 
    6548                 :            :   /* If the source length is 0, any value of NCOPIES is valid
    6549                 :            :      and everything behaves as if NCOPIES == 0.  */
    6550                 :       1453 :   mpz_init (ncopies);
    6551                 :       1453 :   if (len == 0)
    6552                 :         63 :     mpz_set_ui (ncopies, 0);
    6553                 :            :   else
    6554                 :       1390 :     mpz_set (ncopies, n->value.integer);
    6555                 :            : 
    6556                 :            :   /* Check that NCOPIES isn't too large.  */
    6557                 :       1453 :   if (len)
    6558                 :            :     {
    6559                 :       1390 :       mpz_t max, mlen;
    6560                 :       1390 :       int i;
    6561                 :            : 
    6562                 :            :       /* Compute the maximum value allowed for NCOPIES: huge(cl) / len.  */
    6563                 :       1390 :       mpz_init (max);
    6564                 :       1390 :       i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
    6565                 :            : 
    6566                 :       1390 :       if (have_length)
    6567                 :            :         {
    6568                 :        287 :           mpz_tdiv_q (max, gfc_integer_kinds[i].huge,
    6569                 :        287 :                       e->ts.u.cl->length->value.integer);
    6570                 :            :         }
    6571                 :            :       else
    6572                 :            :         {
    6573                 :       1103 :           mpz_init (mlen);
    6574                 :       1103 :           gfc_mpz_set_hwi (mlen, len);
    6575                 :       1103 :           mpz_tdiv_q (max, gfc_integer_kinds[i].huge, mlen);
    6576                 :       1103 :           mpz_clear (mlen);
    6577                 :            :         }
    6578                 :            : 
    6579                 :            :       /* The check itself.  */
    6580                 :       1390 :       if (mpz_cmp (ncopies, max) > 0)
    6581                 :            :         {
    6582                 :          4 :           mpz_clear (max);
    6583                 :          4 :           mpz_clear (ncopies);
    6584                 :          4 :           gfc_error ("Argument NCOPIES of REPEAT intrinsic is too large at %L",
    6585                 :            :                      &n->where);
    6586                 :          4 :           return &gfc_bad_expr;
    6587                 :            :         }
    6588                 :            : 
    6589                 :       1386 :       mpz_clear (max);
    6590                 :            :     }
    6591                 :       1449 :   mpz_clear (ncopies);
    6592                 :            : 
    6593                 :            :   /* For further simplification, we need the character string to be
    6594                 :            :      constant.  */
    6595                 :       1449 :   if (e->expr_type != EXPR_CONSTANT)
    6596                 :            :     return NULL;
    6597                 :            : 
    6598                 :       1164 :   HOST_WIDE_INT ncop;
    6599                 :       1164 :   if (len ||
    6600                 :         24 :       (e->ts.u.cl->length &&
    6601                 :         18 :        mpz_sgn (e->ts.u.cl->length->value.integer) != 0))
    6602                 :            :     {
    6603                 :       1140 :       bool fail = gfc_extract_hwi (n, &ncop);
    6604                 :       1140 :       gcc_assert (!fail);
    6605                 :            :     }
    6606                 :            :   else
    6607                 :         24 :     ncop = 0;
    6608                 :            : 
    6609                 :       1164 :   if (ncop == 0)
    6610                 :         54 :     return gfc_get_character_expr (e->ts.kind, &e->where, NULL, 0);
    6611                 :            : 
    6612                 :       1110 :   len = e->value.character.length;
    6613                 :       1110 :   gfc_charlen_t nlen = ncop * len;
    6614                 :            : 
    6615                 :            :   /* Here's a semi-arbitrary limit. If the string is longer than 1 GB
    6616                 :            :      (2**28 elements * 4 bytes (wide chars) per element) defer to
    6617                 :            :      runtime instead of consuming (unbounded) memory and CPU at
    6618                 :            :      compile time.  */
    6619                 :       1110 :   if (nlen > 268435456)
    6620                 :            :     {
    6621                 :          1 :       gfc_warning_now (0, "Evaluation of string longer than 2**28 at %L"
    6622                 :            :                        " deferred to runtime, expect bugs", &e->where);
    6623                 :          1 :       return NULL;
    6624                 :            :     }
    6625                 :            : 
    6626                 :       1109 :   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, nlen);
    6627                 :      54334 :   for (size_t i = 0; i < (size_t) ncop; i++)
    6628                 :     106780 :     for (size_t j = 0; j < (size_t) len; j++)
    6629                 :      53555 :       result->value.character.string[j+i*len]= e->value.character.string[j];
    6630                 :            : 
    6631                 :       1109 :   result->value.character.string[nlen] = '\0';       /* For debugger */
    6632                 :       1109 :   return result;
    6633                 :            : }
    6634                 :            : 
    6635                 :            : 
    6636                 :            : /* This one is a bear, but mainly has to do with shuffling elements.  */
    6637                 :            : 
    6638                 :            : gfc_expr *
    6639                 :       4965 : gfc_simplify_reshape (gfc_expr *source, gfc_expr *shape_exp,
    6640                 :            :                       gfc_expr *pad, gfc_expr *order_exp)
    6641                 :            : {
    6642                 :       4965 :   int order[GFC_MAX_DIMENSIONS], shape[GFC_MAX_DIMENSIONS];
    6643                 :       4965 :   int i, rank, npad, x[GFC_MAX_DIMENSIONS];
    6644                 :       4965 :   mpz_t index, size;
    6645                 :       4965 :   unsigned long j;
    6646                 :       4965 :   size_t nsource;
    6647                 :       4965 :   gfc_expr *e, *result;
    6648                 :            : 
    6649                 :            :   /* Check that argument expression types are OK.  */
    6650                 :       4965 :   if (!is_constant_array_expr (source)
    6651                 :       3398 :       || !is_constant_array_expr (shape_exp)
    6652                 :       3379 :       || !is_constant_array_expr (pad)
    6653                 :       8344 :       || !is_constant_array_expr (order_exp))
    6654                 :       1598 :     return NULL;
    6655                 :            : 
    6656                 :       3367 :   if (source->shape == NULL)
    6657                 :            :     return NULL;
    6658                 :            : 
    6659                 :            :   /* Proceed with simplification, unpacking the array.  */
    6660                 :            : 
    6661                 :       3364 :   mpz_init (index);
    6662                 :       3364 :   rank = 0;
    6663                 :            : 
    6664                 :      53824 :   for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
    6665                 :      50460 :     x[i] = 0;
    6666                 :            : 
    6667                 :      17258 :   for (;;)
    6668                 :            :     {
    6669                 :      10311 :       e = gfc_constructor_lookup_expr (shape_exp->value.constructor, rank);
    6670                 :      10311 :       if (e == NULL)
    6671                 :            :         break;
    6672                 :            : 
    6673                 :       6947 :       gfc_extract_int (e, &shape[rank]);
    6674                 :            : 
    6675                 :       6947 :       gcc_assert (rank >= 0 && rank < GFC_MAX_DIMENSIONS);
    6676                 :       6947 :       gcc_assert (shape[rank] >= 0);
    6677                 :            : 
    6678                 :       6947 :       rank++;
    6679                 :            :     }
    6680                 :            : 
    6681                 :       3364 :   gcc_assert (rank > 0);
    6682                 :            : 
    6683                 :            :   /* Now unpack the order array if present.  */
    6684                 :       3364 :   if (order_exp == NULL)
    6685                 :            :     {
    6686                 :      10245 :       for (i = 0; i < rank; i++)
    6687                 :       6903 :         order[i] = i;
    6688                 :            :     }
    6689                 :            :   else
    6690                 :            :     {
    6691                 :         22 :       mpz_t size;
    6692                 :         22 :       int order_size, shape_size;
    6693                 :            : 
    6694                 :         22 :       if (order_exp->rank != shape_exp->rank)
    6695                 :            :         {
    6696                 :          1 :           gfc_error ("Shapes of ORDER at %L and SHAPE at %L are different",
    6697                 :            :                      &order_exp->where, &shape_exp->where);
    6698                 :          4 :           return &gfc_bad_expr;
    6699                 :            :         }
    6700                 :            : 
    6701                 :         21 :       gfc_array_size (shape_exp, &size);
    6702                 :         21 :       shape_size = mpz_get_ui (size);
    6703                 :         21 :       mpz_clear (size);
    6704                 :         21 :       gfc_array_size (order_exp, &size);
    6705                 :         21 :       order_size = mpz_get_ui (size);
    6706                 :         21 :       mpz_clear (size);
    6707                 :         21 :       if (order_size != shape_size)
    6708                 :            :         {
    6709                 :          1 :           gfc_error ("Sizes of ORDER at %L and SHAPE at %L are different",
    6710                 :            :                      &order_exp->where, &shape_exp->where);
    6711                 :          1 :           return &gfc_bad_expr;
    6712                 :            :         }
    6713                 :            : 
    6714                 :         58 :       for (i = 0; i < rank; i++)
    6715                 :            :         {
    6716                 :         40 :           e = gfc_constructor_lookup_expr (order_exp->value.constructor, i);
    6717                 :         40 :           gcc_assert (e);
    6718                 :            : 
    6719                 :         40 :           gfc_extract_int (e, &order[i]);
    6720                 :            : 
    6721                 :         40 :           if (order[i] < 1 || order[i] > rank)
    6722                 :            :             {
    6723                 :          1 :               gfc_error ("Element with a value of %d in ORDER at %L must be "
    6724                 :            :                          "in the range [1, ..., %d] for the RESHAPE intrinsic "
    6725                 :            :                          "near %L", order[i], &order_exp->where, rank,
    6726                 :            :                          &shape_exp->where);
    6727                 :          1 :               return &gfc_bad_expr;
    6728                 :            :             }
    6729                 :            : 
    6730                 :         39 :           order[i]--;
    6731                 :         39 :           if (x[order[i]] != 0)
    6732                 :            :             {
    6733                 :          1 :               gfc_error ("ORDER at %L is not a permutation of the size of "
    6734                 :            :                          "SHAPE at %L", &order_exp->where, &shape_exp->where);
    6735                 :          1 :               return &gfc_bad_expr;
    6736                 :            :             }
    6737                 :         38 :           x[order[i]] = 1;
    6738                 :            :         }
    6739                 :            :     }
    6740                 :            : 
    6741                 :            :   /* Count the elements in the source and padding arrays.  */
    6742                 :            : 
    6743                 :       3360 :   npad = 0;
    6744                 :       3360 :   if (pad != NULL)
    6745                 :            :     {
    6746                 :         56 :       gfc_array_size (pad, &size);
    6747                 :         56 :       npad = mpz_get_ui (size);
    6748                 :         56 :       mpz_clear (size);
    6749                 :            :     }
    6750                 :            : 
    6751                 :       3360 :   gfc_array_size (source, &size);
    6752                 :       3360 :   nsource = mpz_get_ui (size);
    6753                 :       3360 :   mpz_clear (size);
    6754                 :            : 
    6755                 :            :   /* If it weren't for that pesky permutation we could just loop
    6756                 :            :      through the source and round out any shortage with pad elements.
    6757                 :            :      But no, someone just had to have the compiler do something the
    6758                 :            :      user should be doing.  */
    6759                 :            : 
    6760                 :      10299 :   for (i = 0; i < rank; i++)
    6761                 :       6939 :     x[i] = 0;
    6762                 :            : 
    6763                 :       3360 :   result = gfc_get_array_expr (source->ts.type, source->ts.kind,
    6764                 :            :                                &source->where);
    6765                 :       3360 :   if (source->ts.type == BT_DERIVED)
    6766                 :         64 :     result->ts.u.derived = source->ts.u.derived;
    6767                 :       3360 :   result->rank = rank;
    6768                 :       3360 :   result->shape = gfc_get_shape (rank);
    6769                 :      10299 :   for (i = 0; i < rank; i++)
    6770                 :       6939 :     mpz_init_set_ui (result->shape[i], shape[i]);
    6771                 :            : 
    6772                 :      38968 :   while (nsource > 0 || npad > 0)
    6773                 :            :     {
    6774                 :            :       /* Figure out which element to extract.  */
    6775                 :      38962 :       mpz_set_ui (index, 0);
    6776                 :            : 
    6777                 :     122518 :       for (i = rank - 1; i >= 0; i--)
    6778                 :            :         {
    6779                 :      83556 :           mpz_add_ui (index, index, x[order[i]]);
    6780                 :      83556 :           if (i != 0)
    6781                 :      44594 :             mpz_mul_ui (index, index, shape[order[i - 1]]);
    6782                 :            :         }
    6783                 :            : 
    6784                 :      38962 :       if (mpz_cmp_ui (index, INT_MAX) > 0)
    6785                 :          0 :         gfc_internal_error ("Reshaped array too large at %C");
    6786                 :            : 
    6787                 :      38962 :       j = mpz_get_ui (index);
    6788                 :            : 
    6789                 :      38962 :       if (j < nsource)
    6790                 :      38781 :         e = gfc_constructor_lookup_expr (source->value.constructor, j);
    6791                 :            :       else
    6792                 :            :         {
    6793                 :        181 :           if (npad <= 0)
    6794                 :            :             {
    6795                 :          3 :               mpz_clear (index);
    6796                 :          3 :               return NULL;
    6797                 :            :             }
    6798                 :        178 :           j = j - nsource;
    6799                 :        178 :           j = j % npad;
    6800                 :        178 :           e = gfc_constructor_lookup_expr (pad->value.constructor, j);
    6801                 :            :         }
    6802                 :      38959 :       gcc_assert (e);
    6803                 :            : 
    6804                 :      38959 :       gfc_constructor_append_expr (&result->value.constructor,
    6805                 :            :                                    gfc_copy_expr (e), &e->where);
    6806                 :            : 
    6807                 :            :       /* Calculate the next element.  */
    6808                 :      38959 :       i = 0;
    6809                 :            : 
    6810                 :      51118 : inc:
    6811                 :      51118 :       if (++x[i] < shape[i])
    6812                 :      35608 :         continue;
    6813                 :      15510 :       x[i++] = 0;
    6814                 :      15510 :       if (i < rank)
    6815                 :      12159 :         goto inc;
    6816                 :            : 
    6817                 :            :       break;
    6818                 :            :     }
    6819                 :            : 
    6820                 :       3357 :   mpz_clear (index);
    6821                 :            : 
    6822                 :       3357 :   return result;
    6823                 :            : }
    6824                 :            : 
    6825                 :            : 
    6826                 :            : gfc_expr *
    6827                 :        102 : gfc_simplify_rrspacing (gfc_expr *x)
    6828                 :            : {
    6829                 :        102 :   gfc_expr *result;
    6830                 :        102 :   int i;
    6831                 :        102 :   long int e, p;
    6832                 :            : 
    6833                 :        102 :   if (x->expr_type != EXPR_CONSTANT)
    6834                 :            :     return NULL;
    6835                 :            : 
    6836                 :         36 :   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
    6837                 :            : 
    6838                 :         36 :   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
    6839                 :            : 
    6840                 :            :   /* RRSPACING(+/- 0.0) = 0.0  */
    6841                 :         36 :   if (mpfr_zero_p (x->value.real))
    6842                 :            :     {
    6843                 :         12 :       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    6844                 :         12 :       return result;
    6845                 :            :     }
    6846                 :            : 
    6847                 :            :   /* RRSPACING(inf) = NaN  */
    6848                 :         24 :   if (mpfr_inf_p (x->value.real))
    6849                 :            :     {
    6850                 :         12 :       mpfr_set_nan (result->value.real);
    6851                 :         12 :       return result;
    6852                 :            :     }
    6853                 :            : 
    6854                 :            :   /* RRSPACING(NaN) = same NaN  */
    6855                 :         12 :   if (mpfr_nan_p (x->value.real))
    6856                 :            :     {
    6857                 :          6 :       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
    6858                 :          6 :       return result;
    6859                 :            :     }
    6860                 :            : 
    6861                 :            :   /* | x * 2**(-e) | * 2**p.  */
    6862                 :          6 :   mpfr_abs (result->value.real, x->value.real, GFC_RND_MODE);
    6863                 :          6 :   e = - (long int) mpfr_get_exp (x->value.real);
    6864                 :          6 :   mpfr_mul_2si (result->value.real, result->value.real, e, GFC_RND_MODE);
    6865                 :            : 
    6866                 :          6 :   p = (long int) gfc_real_kinds[i].digits;
    6867                 :          6 :   mpfr_mul_2si (result->value.real, result->value.real, p, GFC_RND_MODE);
    6868                 :            : 
    6869                 :          6 :   return range_check (result, "RRSPACING");
    6870                 :            : }
    6871                 :            : 
    6872                 :            : 
    6873                 :            : gfc_expr *
    6874                 :         96 : gfc_simplify_scale (gfc_expr *x, gfc_expr *i)
    6875                 :            : {
    6876                 :         96 :   int k, neg_flag, power, exp_range;
    6877                 :         96 :   mpfr_t scale, radix;
    6878                 :         96 :   gfc_expr *result;
    6879                 :            : 
    6880                 :         96 :   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
    6881                 :            :     return NULL;
    6882                 :            : 
    6883                 :         12 :   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
    6884                 :            : 
    6885                 :         12 :   if (mpfr_zero_p (x->value.real))
    6886                 :            :     {
    6887                 :          0 :       mpfr_set_ui (result->value.real, 0, GFC_RND_MODE);
    6888                 :          0 :       return result;
    6889                 :            :     }
    6890                 :            : 
    6891                 :         12 :   k = gfc_validate_kind (BT_REAL, x->ts.kind, false);
    6892                 :            : 
    6893                 :         12 :   exp_range = gfc_real_kinds[k].max_exponent - gfc_real_kinds[k].min_exponent;
    6894                 :            : 
    6895                 :            :   /* This check filters out values of i that would overflow an int.  */
    6896                 :         12 :   if (mpz_cmp_si (i->value.integer, exp_range + 2) > 0
    6897                 :         12 :       || mpz_cmp_si (i->value.integer, -exp_range - 2) < 0)
    6898                 :            :     {
    6899                 :          0 :       gfc_error ("Result of SCALE overflows its kind at %L", &result->where);
    6900                 :          0 :       gfc_free_expr (result);
    6901                 :          0 :       return &gfc_bad_expr;
    6902                 :            :     }
    6903                 :            : 
    6904                 :            :   /* Compute scale = radix ** power.  */
    6905                 :         12 :   power = mpz_get_si (i->value.integer);
    6906                 :            : 
    6907                 :         12 :   if (power >= 0)
    6908                 :            :     neg_flag = 0;
    6909                 :            :   else
    6910                 :            :     {
    6911                 :          0 :       neg_flag = 1;
    6912                 :          0 :       power = -power;
    6913                 :            :     }
    6914                 :            : 
    6915                 :         12 :   gfc_set_model_kind (x->ts.kind);
    6916                 :         12 :   mpfr_init (scale);
    6917                 :         12 :   mpfr_init (radix);
    6918                 :         12 :   mpfr_set_ui (radix, gfc_real_kinds[k].radix, GFC_RND_MODE);
    6919                 :         12 :   mpfr_pow_ui (scale, radix, power, GFC_RND_MODE);
    6920                 :            : 
    6921                 :         12 :   if (neg_flag)
    6922                 :          0 :     mpfr_div (result->value.real, x->value.real, scale, GFC_RND_MODE);
    6923                 :            :   else
    6924                 :         12 :     mpfr_mul (result->value.real, x->value.real, scale, GFC_RND_MODE);
    6925                 :            : 
    6926                 :         12 :   mpfr_clears (scale, radix, NULL);
    6927                 :            : 
    6928                 :         12 :   return range_check (result, "SCALE");
    6929                 :            : }
    6930                 :            : 
    6931                 :            : 
    6932                 :            : /* Variants of strspn and strcspn that operate on wide characters.  */
    6933                 :            : 
    6934                 :            : static size_t
    6935                 :         60 : wide_strspn (const gfc_char_t *s1, const gfc_char_t *s2)
    6936                 :            : {
    6937                 :          0 :   size_t i = 0;
    6938                 :        144 :   const gfc_char_t *c;
    6939                 :            : 
    6940                 :        144 :   while (s1[i])
    6941                 :            :     {
    6942                 :        354 :       for (c = s2; *c; c++)
    6943                 :            :         {
    6944                 :        294 :           if (s1[i] == *c)
    6945                 :            :             break;
    6946                 :            :         }
    6947                 :        144 :       if (*c == '\0')
    6948                 :            :         break;
    6949                 :         84 :       i++;
    6950                 :            :     }
    6951                 :            : 
    6952                 :         60 :   return i;
    6953                 :            : }
    6954                 :            : 
    6955                 :            : static size_t
    6956                 :         60 : wide_strcspn (const gfc_char_t *s1, const gfc_char_t *s2)
    6957                 :            : {
    6958                 :          0 :   size_t i = 0;
    6959                 :        396 :   const gfc_char_t *c;
    6960                 :            : 
    6961                 :        396 :   while (s1[i])
    6962                 :            :     {
    6963                 :       1392 :       for (c = s2; *c; c++)
    6964                 :            :         {
    6965                 :       1056 :           if (s1[i] == *c)
    6966                 :            :             break;
    6967                 :            :         }
    6968                 :        384 :       if (*c)
    6969                 :            :         break;
    6970                 :        336 :       i++;
    6971                 :            :     }
    6972                 :            : 
    6973                 :         60 :   return i;
    6974                 :            : }
    6975                 :            : 
    6976                 :            : 
    6977                 :            : gfc_expr *
    6978                 :        676 : gfc_simplify_scan (gfc_expr *e, gfc_expr *c, gfc_expr *b, gfc_expr *kind)
    6979                 :            : {
    6980                 :        676 :   gfc_expr *result;
    6981                 :        676 :   int back;
    6982                 :        676 :   size_t i;
    6983                 :        676 :   size_t indx, len, lenc;
    6984                 :        676 :   int k = get_kind (BT_INTEGER, kind, "SCAN", gfc_default_integer_kind);
    6985                 :            : 
    6986                 :        676 :   if (k == -1)
    6987                 :            :     return &gfc_bad_expr;
    6988                 :            : 
    6989                 :        676 :   if (e->expr_type != EXPR_CONSTANT || c->expr_type != EXPR_CONSTANT
    6990                 :        169 :       || ( b != NULL && b->expr_type !=  EXPR_CONSTANT))
    6991                 :            :     return NULL;
    6992                 :            : 
    6993                 :        144 :   if (b != NULL && b->value.logical != 0)
    6994                 :            :     back = 1;
    6995                 :            :   else
    6996                 :         72 :     back = 0;
    6997                 :            : 
    6998                 :        144 :   len = e->value.character.length;
    6999                 :        144 :   lenc = c->value.character.length;
    7000                 :            : 
    7001                 :        144 :   if (len == 0 || lenc == 0)
    7002                 :            :     {
    7003                 :            :       indx = 0;
    7004                 :            :     }
    7005                 :            :   else
    7006                 :            :     {
    7007                 :        120 :       if (back == 0)
    7008                 :            :         {
    7009                 :        120 :           indx = wide_strcspn (e->value.character.string,
    7010                 :         60 :                                c->value.character.string) + 1;
    7011                 :         60 :           if (indx > len)
    7012                 :         12 :             indx = 0;
    7013                 :            :         }
    7014                 :            :       else
    7015                 :        408 :         for (indx = len; indx > 0; indx--)
    7016                 :            :           {
    7017                 :       1488 :             for (i = 0; i < lenc; i++)
    7018                 :            :               {
    7019                 :       1140 :                 if (c->value.character.string[i]
    7020                 :       1140 :                     == e->value.character.string[indx - 1])
    7021                 :            :                   break;
    7022                 :            :               }
    7023                 :        396 :             if (i < lenc)
    7024                 :            :               break;
    7025                 :            :           }
    7026                 :            :     }
    7027                 :            : 
    7028                 :        144 :   result = gfc_get_int_expr (k, &e->where, indx);
    7029                 :        144 :   return range_check (result, "SCAN");
    7030                 :            : }
    7031                 :            : 
    7032                 :            : 
    7033                 :            : gfc_expr *
    7034                 :        221 : gfc_simplify_selected_char_kind (gfc_expr *e)
    7035                 :            : {
    7036                 :        221 :   int kind;
    7037                 :            : 
    7038                 :        221 :   if (e->expr_type != EXPR_CONSTANT)
    7039                 :            :     return NULL;
    7040                 :            : 
    7041                 :        136 :   if (gfc_compare_with_Cstring (e, "ascii", false) == 0
    7042                 :        136 :       || gfc_compare_with_Cstring (e, "default", false) == 0)
    7043                 :            :     kind = 1;
    7044                 :         52 :   else if (gfc_compare_with_Cstring (e, "iso_10646", false) == 0)
    7045                 :            :     kind = 4;
    7046                 :            :   else
    7047                 :         39 :     kind = -1;
    7048                 :            : 
    7049                 :        136 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
    7050                 :            : }
    7051                 :            : 
    7052                 :            : 
    7053                 :            : gfc_expr *
    7054                 :        242 : gfc_simplify_selected_int_kind (gfc_expr *e)
    7055                 :            : {
    7056                 :        242 :   int i, kind, range;
    7057                 :            : 
    7058                 :        242 :   if (e->expr_type != EXPR_CONSTANT || gfc_extract_int (e, &range))
    7059                 :         49 :     return NULL;
    7060                 :            : 
    7061                 :            :   kind = INT_MAX;
    7062                 :            : 
    7063                 :       1158 :   for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
    7064                 :        965 :     if (gfc_integer_kinds[i].range >= range
    7065                 :            :         && gfc_integer_kinds[i].kind < kind)
    7066                 :            :       kind = gfc_integer_kinds[i].kind;
    7067                 :            : 
    7068                 :        193 :   if (kind == INT_MAX)
    7069                 :          0 :     kind = -1;
    7070                 :            : 
    7071                 :        193 :   return gfc_get_int_expr (gfc_default_integer_kind, &e->where, kind);
    7072                 :            : }
    7073                 :            : 
    7074                 :            : 
    7075                 :            : gfc_expr *
    7076                 :        671 : gfc_simplify_selected_real_kind (gfc_expr *p, gfc_expr *q, gfc_expr *rdx)
    7077                 :            : {
    7078                 :        671 :   int range, precision, radix, i, kind, found_precision, found_range,
    7079                 :            :       found_radix;
    7080                 :        671 :   locus *loc = &gfc_current_locus;
    7081                 :            : 
    7082                 :        671 :   if (p == NULL)
    7083                 :         60 :     precision = 0;
    7084                 :            :   else
    7085                 :            :     {
    7086                 :        611 :       if (p->expr_type != EXPR_CONSTANT
    7087                 :        611 :           || gfc_extract_int (p, &precision))
    7088                 :         46 :         return NULL;
    7089                 :        565 :       loc = &p->where;
    7090                 :            :     }
    7091                 :            : 
    7092                 :        625 :   if (q == NULL)
    7093                 :        361 :     range = 0;
    7094                 :            :   else
    7095                 :            :     {
    7096                 :        264 :       if (q->expr_type != EXPR_CONSTANT
    7097                 :        264 :           || gfc_extract_int (q, &range))
    7098                 :         54 :         return NULL;
    7099                 :            : 
    7100                 :            :       if (!loc)
    7101                 :            :         loc = &q->where;
    7102                 :            :     }
    7103                 :            : 
    7104                 :        571 :   if (rdx == NULL)
    7105                 :        511 :     radix = 0;
    7106                 :            :   else
    7107                 :            :     {
    7108                 :         60 :       if (rdx->expr_type != EXPR_CONSTANT
    7109                 :         60 :           || gfc_extract_int (rdx, &radix))
    7110                 :         24 :         return NULL;
    7111                 :            : 
    7112                 :            :       if (!loc)
    7113                 :            :         loc = &rdx->where;
    7114                 :            :     }
    7115                 :            : 
    7116                 :        547 :   kind = INT_MAX;
    7117                 :        547 :   found_precision = 0;
    7118                 :        547 :   found_range = 0;
    7119                 :        547 :   found_radix = 0;
    7120                 :            : 
    7121                 :       2735 :   for (i = 0; gfc_real_kinds[i].kind != 0; i++)
    7122                 :            :     {
    7123                 :       2188 :       if (gfc_real_kinds[i].precision >= precision)
    7124                 :       1478 :         found_precision = 1;
    7125                 :            : 
    7126                 :       2188 :       if (gfc_real_kinds[i].range >= range)
    7127                 :       2067 :         found_range = 1;
    7128                 :            : 
    7129                 :       2188 :       if (radix == 0 || gfc_real_kinds[i].radix == radix)
    7130                 :       2164 :         found_radix = 1;
    7131                 :            : 
    7132                 :       2188 :       if (gfc_real_kinds[i].precision >= precision
    7133                 :       1478 :           && gfc_real_kinds[i].range >= range
    7134                 :       1478 :           && (radix == 0 || gfc_real_kinds[i].radix == radix)
    7135                 :            :           && gfc_real_kinds[i].kind < kind)
    7136                 :            :         kind = gfc_real_kinds[i].kind;
    7137                 :            :     }
    7138                 :            : 
    7139                 :        547 :   if (kind == INT_MAX)
    7140                 :            :     {
    7141                 :         12 :       if (found_radix && found_range && !found_precision)
    7142                 :            :         kind = -1;
    7143                 :          6 :       else if (found_radix && found_precision && !found_range)
    7144                 :            :         kind = -2;
    7145                 :          6 :       else if (found_radix && !found_precision && !found_range)
    7146                 :            :         kind = -3;
    7147                 :          6 :       else if (found_radix)
    7148                 :            :         kind = -4;
    7149                 :            :       else
    7150                 :          6 :         kind = -5;
    7151                 :            :     }
    7152                 :            : 
    7153                 :        547 :   return gfc_get_int_expr (gfc_default_integer_kind, loc, kind);
    7154                 :            : }
    7155                 :            : 
    7156                 :            : 
    7157                 :            : gfc_expr *
    7158                 :        190 : gfc_simplify_set_exponent (gfc_expr *x, gfc_expr *i)
    7159                 :            : {
    7160                 :        190 :   gfc_expr *result;
    7161                 :        190 :   mpfr_t exp, absv, log2, pow2, frac;
    7162                 :        190 :   unsigned long exp2;
    7163                 :            : 
    7164                 :        190 :   if (x->expr_type != EXPR_CONSTANT || i->expr_type != EXPR_CONSTANT)
    7165                 :            :     return NULL;
    7166                 :            : 
    7167                 :         30 :   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
    7168                 :            : 
    7169                 :            :   /* SET_EXPONENT (+/-0.0, I) = +/- 0.0
    7170                 :            :      SET_EXPONENT (NaN) = same NaN  */
    7171                 :         30 :   if (mpfr_zero_p (x->value.real) || mpfr_nan_p (x->value.real))
    7172                 :            :     {
    7173                 :         18 :       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
    7174                 :         18 :       return result;
    7175                 :            :     }
    7176                 :            : 
    7177                 :            :   /* SET_EXPONENT (inf) = NaN  */
    7178                 :         12 :   if (mpfr_inf_p (x->value.real))
    7179                 :            :     {
    7180                 :         12 :       mpfr_set_nan (result->value.real);
    7181                 :         12 :       return result;
    7182                 :            :     }
    7183                 :            : 
    7184                 :          0 :   gfc_set_model_kind (x->ts.kind);
    7185                 :          0 :   mpfr_init (absv);
    7186                 :          0 :   mpfr_init (log2);
    7187                 :          0 :   mpfr_init (exp);
    7188                 :          0 :   mpfr_init (pow2);
    7189                 :          0 :   mpfr_init (frac);
    7190                 :            : 
    7191                 :          0 :   mpfr_abs (absv, x->value.real, GFC_RND_MODE);
    7192                 :          0 :   mpfr_log2 (log2, absv, GFC_RND_MODE);
    7193                 :            : 
    7194                 :          0 :   mpfr_trunc (log2, log2);
    7195                 :          0 :   mpfr_add_ui (exp, log2, 1, GFC_RND_MODE);
    7196                 :            : 
    7197                 :            :   /* Old exponent value, and fraction.  */
    7198                 :          0 :   mpfr_ui_pow (pow2, 2, exp, GFC_RND_MODE);
    7199                 :            : 
    7200                 :          0 :   mpfr_div (frac, absv, pow2, GFC_RND_MODE);
    7201                 :            : 
    7202                 :            :   /* New exponent.  */
    7203                 :          0 :   exp2 = (unsigned long) mpz_get_d (i->value.integer);
    7204                 :          0 :   mpfr_mul_2exp (result->value.real, frac, exp2, GFC_RND_MODE);
    7205                 :            : 
    7206                 :          0 :   mpfr_clears (absv, log2, pow2, frac, NULL);
    7207                 :            : 
    7208                 :          0 :   return range_check (result, "SET_EXPONENT");
    7209                 :            : }
    7210                 :            : 
    7211                 :            : 
    7212                 :            : gfc_expr *
    7213                 :       1778 : gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
    7214                 :            : {
    7215                 :       1778 :   mpz_t shape[GFC_MAX_DIMENSIONS];
    7216                 :       1778 :   gfc_expr *result, *e, *f;
    7217                 :       1778 :   gfc_array_ref *ar;
    7218                 :       1778 :   int n;
    7219                 :       1778 :   bool t;
    7220                 :       1778 :   int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
    7221                 :            : 
    7222                 :       1778 :   if (source->rank == -1)
    7223                 :            :     return NULL;
    7224                 :            : 
    7225                 :       1473 :   result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
    7226                 :       1473 :   result->shape = gfc_get_shape (1);
    7227                 :       1473 :   mpz_init (result->shape[0]);
    7228                 :            : 
    7229                 :       1473 :   if (source->rank == 0)
    7230                 :            :     return result;
    7231                 :            : 
    7232                 :       1425 :   if (source->expr_type == EXPR_VARIABLE)
    7233                 :            :     {
    7234                 :       1404 :       ar = gfc_find_array_ref (source);
    7235                 :       1404 :       t = gfc_array_ref_shape (ar, shape);
    7236                 :            :     }
    7237                 :         21 :   else if (source->shape)
    7238                 :            :     {
    7239                 :         24 :       t = true;
    7240                 :         24 :       for (n = 0; n < source->rank; n++)
    7241                 :            :         {
    7242                 :         16 :           mpz_init (shape[n]);
    7243                 :         16 :           mpz_set (shape[n], source->shape[n]);
    7244                 :            :         }
    7245                 :            :     }
    7246                 :            :   else
    7247                 :            :     t = false;
    7248                 :            : 
    7249                 :       2855 :   for (n = 0; n < source->rank; n++)
    7250                 :            :     {
    7251                 :       2142 :       e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
    7252                 :            : 
    7253                 :       2142 :       if (t)
    7254                 :       1416 :         mpz_set (e->value.integer, shape[n]);
    7255                 :            :       else
    7256                 :            :         {
    7257                 :        726 :           mpz_set_ui (e->value.integer, n + 1);
    7258                 :            : 
    7259                 :        726 :           f = simplify_size (source, e, k);
    7260                 :        726 :           gfc_free_expr (e);
    7261                 :        726 :           if (f == NULL)
    7262                 :            :             {
    7263                 :        711 :               gfc_free_expr (result);
    7264                 :        711 :               return NULL;
    7265                 :            :             }
    7266                 :            :           else
    7267                 :            :             e = f;
    7268                 :            :         }
    7269                 :            : 
    7270                 :       1431 :       if (e == &gfc_bad_expr || range_check (e, "SHAPE") == &gfc_bad_expr)
    7271                 :            :         {
    7272                 :          1 :           gfc_free_expr (result);
    7273                 :          1 :           if (t)
    7274                 :          1 :             gfc_clear_shape (shape, source->rank);
    7275                 :          1 :           return &gfc_bad_expr;
    7276                 :            :         }
    7277                 :            : 
    7278                 :       1430 :       gfc_constructor_append_expr (&result->value.constructor, e, NULL);
    7279                 :            :     }
    7280                 :            : 
    7281                 :        713 :   if (t)
    7282                 :        713 :     gfc_clear_shape (shape, source->rank);
    7283                 :            : 
    7284                 :        713 :   mpz_set_si (result->shape[0], source->rank);
    7285                 :            : 
    7286                 :        713 :   return result;
    7287                 :            : }
    7288                 :            : 
    7289                 :            : 
    7290                 :            : static gfc_expr *
    7291                 :      23092 : simplify_size (gfc_expr *array, gfc_expr *dim, int k)
    7292                 :            : {
    7293                 :      23092 :   mpz_t size;
    7294                 :      23092 :   gfc_expr *return_value;
    7295                 :      23092 :   int d;
    7296                 :            : 
    7297                 :            :   /* For unary operations, the size of the result is given by the size
    7298                 :            :      of the operand.  For binary ones, it's the size of the first operand
    7299                 :            :      unless it is scalar, then it is the size of the second.  */
    7300                 :      23092 :   if (array->expr_type == EXPR_OP && !array->value.op.uop)
    7301                 :            :     {
    7302                 :         92 :       gfc_expr* replacement;
    7303                 :         92 :       gfc_expr* simplified;
    7304                 :            : 
    7305                 :         92 :       switch (array->value.op.op)
    7306                 :            :         {
    7307                 :            :           /* Unary operations.  */
    7308                 :         55 :           case INTRINSIC_NOT:
    7309                 :         55 :           case INTRINSIC_UPLUS:
    7310                 :         55 :           case INTRINSIC_UMINUS:
    7311                 :         55 :           case INTRINSIC_PARENTHESES:
    7312                 :         55 :             replacement = array->value.op.op1;
    7313                 :         55 :             break;
    7314                 :            : 
    7315                 :            :           /* Binary operations.  If any one of the operands is scalar, take
    7316                 :            :              the other one's size.  If both of them are arrays, it does not
    7317                 :            :              matter -- try to find one with known shape, if possible.  */
    7318                 :         37 :           default:
    7319                 :         37 :             if (array->value.op.op1->rank == 0)
    7320                 :         25 :               replacement = array->value.op.op2;
    7321                 :         12 :             else if (array->value.op.op2->rank == 0)
    7322                 :            :               replacement = array->value.op.op1;
    7323                 :            :             else
    7324                 :            :               {
    7325                 :          0 :                 simplified = simplify_size (array->value.op.op1, dim, k);
    7326                 :          0 :                 if (simplified)
    7327                 :            :                   return simplified;
    7328                 :            : 
    7329                 :          0 :                 replacement = array->value.op.op2;
    7330                 :            :               }
    7331                 :            :             break;
    7332                 :            :         }
    7333                 :            : 
    7334                 :            :       /* Try to reduce it directly if possible.  */
    7335                 :         92 :       simplified = simplify_size (replacement, dim, k);
    7336                 :            : 
    7337                 :            :       /* Otherwise, we build a new SIZE call.  This is hopefully at least
    7338                 :            :          simpler than the original one.  */
    7339                 :         92 :       if (!simplified)
    7340                 :            :         {
    7341                 :         44 :           gfc_expr *kind = gfc_get_int_expr (gfc_default_integer_kind, NULL, k);
    7342                 :         44 :           simplified = gfc_build_intrinsic_call (gfc_current_ns,
    7343                 :            :                                                  GFC_ISYM_SIZE, "size",
    7344                 :            :                                                  array->where, 3,
    7345                 :            :                                                  gfc_copy_expr (replacement),
    7346                 :            :                                                  gfc_copy_expr (dim),
    7347                 :            :                                                  kind);
    7348                 :            :         }
    7349                 :         92 :       return simplified;
    7350                 :            :     }
    7351                 :            : 
    7352                 :      23000 :   if (dim == NULL)
    7353                 :            :     {
    7354                 :       9224 :       if (!gfc_array_size (array, &size))
    7355                 :            :         return NULL;
    7356                 :            :     }
    7357                 :            :   else
    7358                 :            :     {
    7359                 :      13776 :       if (dim->expr_type != EXPR_CONSTANT)
    7360                 :            :         return NULL;
    7361                 :            : 
    7362                 :      13610 :       d = mpz_get_ui (dim->value.integer) - 1;
    7363                 :      13610 :       if (!gfc_array_dimen_size (array, d, &size))
    7364                 :            :         return NULL;
    7365                 :            :     }
    7366                 :            : 
    7367                 :       3885 :   return_value = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
    7368                 :       3885 :   mpz_set (return_value->value.integer, size);
    7369                 :       3885 :   mpz_clear (size);
    7370                 :            : 
    7371                 :       3885 :   return return_value;
    7372                 :            : }
    7373                 :            : 
    7374                 :            : 
    7375                 :            : gfc_expr *
    7376                 :      21504 : gfc_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
    7377                 :            : {
    7378                 :      21504 :   gfc_expr *result;
    7379                 :      21504 :   int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
    7380                 :            : 
    7381                 :      21504 :   if (k == -1)
    7382                 :            :     return &gfc_bad_expr;
    7383                 :            : 
    7384                 :      21504 :   result = simplify_size (array, dim, k);
    7385                 :      21504 :   if (result == NULL || result == &gfc_bad_expr)
    7386                 :            :     return result;
    7387                 :            : 
    7388                 :       3483 :   return range_check (result, "SIZE");
    7389                 :            : }
    7390                 :            : 
    7391                 :            : 
    7392                 :            : /* SIZEOF and C_SIZEOF return the size in bytes of an array element
    7393                 :            :    multiplied by the array size.  */
    7394                 :            : 
    7395                 :            : gfc_expr *
    7396                 :       1122 : gfc_simplify_sizeof (gfc_expr *x)
    7397                 :            : {
    7398                 :       1122 :   gfc_expr *result = NULL;
    7399                 :       1122 :   mpz_t array_size;
    7400                 :       1122 :   size_t res_size;
    7401                 :            : 
    7402                 :       1122 :   if (x->ts.type == BT_CLASS || x->ts.deferred)
    7403                 :            :     return NULL;
    7404                 :            : 
    7405                 :       1052 :   if (x->ts.type == BT_CHARACTER
    7406                 :        248 :       && (!x->ts.u.cl || !x->ts.u.cl->length
    7407                 :         74 :           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
    7408                 :            :     return NULL;
    7409                 :            : 
    7410                 :        565 :   if (x->rank && x->expr_type != EXPR_ARRAY
    7411                 :       1413 :       && !gfc_array_size (x, &array_size))
    7412                 :            :     return NULL;
    7413                 :            : 
    7414                 :        434 :   result = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
    7415                 :            :                                   &x->where);
    7416                 :        434 :   gfc_target_expr_size (x, &res_size);
    7417                 :        434 :   mpz_set_si (result->value.integer, res_size);
    7418                 :            : 
    7419                 :        434 :   return result;
    7420                 :            : }
    7421                 :            : 
    7422                 :            : 
    7423                 :            : /* STORAGE_SIZE returns the size in bits of a single array element.  */
    7424                 :            : 
    7425                 :            : gfc_expr *
    7426                 :        400 : gfc_simplify_storage_size (gfc_expr *x,
    7427                 :            :                            gfc_expr *kind)
    7428                 :            : {
    7429                 :        400 :   gfc_expr *result = NULL;
    7430                 :        400 :   int k;
    7431                 :        400 :   size_t siz;
    7432                 :            : 
    7433                 :        400 :   if (x->ts.type == BT_CLASS || x->ts.deferred)
    7434                 :            :     return NULL;
    7435                 :            : 
    7436                 :        255 :   if (x->ts.type == BT_CHARACTER && x->expr_type != EXPR_CONSTANT
    7437                 :          9 :       && (!x->ts.u.cl || !x->ts.u.cl->length
    7438                 :          0 :           || x->ts.u.cl->length->expr_type != EXPR_CONSTANT))
    7439                 :            :     return NULL;
    7440                 :            : 
    7441                 :        246 :   k = get_kind (BT_INTEGER, kind, "STORAGE_SIZE", gfc_default_integer_kind);
    7442                 :        246 :   if (k == -1)
    7443                 :            :     return &gfc_bad_expr;
    7444                 :            : 
    7445                 :        246 :   result = gfc_get_constant_expr (BT_INTEGER, k, &x->where);
    7446                 :            : 
    7447                 :        246 :   gfc_element_size (x, &siz);
    7448                 :        246 :   mpz_set_si (result->value.integer, siz);
    7449                 :        246 :   mpz_mul_ui (result->value.integer, result->value.integer, BITS_PER_UNIT);
    7450                 :            : 
    7451                 :        246 :   return range_check (result, "STORAGE_SIZE");
    7452                 :            : }
    7453                 :            : 
    7454                 :            : 
    7455                 :            : gfc_expr *
    7456                 :        935 : gfc_simplify_sign (gfc_expr *x, gfc_expr *y)
    7457                 :            : {
    7458                 :        935 :   gfc_expr *result;
    7459                 :            : 
    7460                 :        935 :   if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
    7461                 :            :     return NULL;
    7462                 :            : 
    7463                 :         95 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7464                 :            : 
    7465                 :         95 :   switch (x->ts.type)
    7466                 :            :     {
    7467                 :         22 :       case BT_INTEGER:
    7468                 :         22 :         mpz_abs (result->value.integer, x->value.integer);
    7469                 :         22 :         if (mpz_sgn (y->value.integer) < 0)
    7470                 :          0 :           mpz_neg (result->value.integer, result->value.integer);
    7471                 :            :         break;
    7472                 :            : 
    7473                 :         73 :       case BT_REAL:
    7474                 :         73 :         if (flag_sign_zero)
    7475                 :         61 :           mpfr_copysign (result->value.real, x->value.real, y->value.real,
    7476                 :            :                         GFC_RND_MODE);
    7477                 :            :         else
    7478                 :         12 :           mpfr_setsign (result->value.real, x->value.real,
    7479                 :            :                         mpfr_sgn (y->value.real) < 0 ? 1 : 0, GFC_RND_MODE);
    7480                 :            :         break;
    7481                 :            : 
    7482                 :          0 :       default:
    7483                 :          0 :         gfc_internal_error ("Bad type in gfc_simplify_sign");
    7484                 :            :     }
    7485                 :            : 
    7486                 :            :   return result;
    7487                 :            : }
    7488                 :            : 
    7489                 :            : 
    7490                 :            : gfc_expr *
    7491                 :        709 : gfc_simplify_sin (gfc_expr *x)
    7492                 :            : {
    7493                 :        709 :   gfc_expr *result;
    7494                 :            : 
    7495                 :        709 :   if (x->expr_type != EXPR_CONSTANT)
    7496                 :            :     return NULL;
    7497                 :            : 
    7498                 :        272 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7499                 :            : 
    7500                 :        272 :   switch (x->ts.type)
    7501                 :            :     {
    7502                 :        215 :       case BT_REAL:
    7503                 :        215 :         mpfr_sin (result->value.real, x->value.real, GFC_RND_MODE);
    7504                 :        215 :         break;
    7505                 :            : 
    7506                 :         57 :       case BT_COMPLEX:
    7507                 :         57 :         gfc_set_model (x->value.real);
    7508                 :         57 :         mpc_sin (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    7509                 :         57 :         break;
    7510                 :            : 
    7511                 :          0 :       default:
    7512                 :          0 :         gfc_internal_error ("in gfc_simplify_sin(): Bad type");
    7513                 :            :     }
    7514                 :            : 
    7515                 :        272 :   return range_check (result, "SIN");
    7516                 :            : }
    7517                 :            : 
    7518                 :            : 
    7519                 :            : gfc_expr *
    7520                 :        169 : gfc_simplify_sinh (gfc_expr *x)
    7521                 :            : {
    7522                 :        169 :   gfc_expr *result;
    7523                 :            : 
    7524                 :        169 :   if (x->expr_type != EXPR_CONSTANT)
    7525                 :            :     return NULL;
    7526                 :            : 
    7527                 :         46 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7528                 :            : 
    7529                 :         46 :   switch (x->ts.type)
    7530                 :            :     {
    7531                 :         42 :       case BT_REAL:
    7532                 :         42 :         mpfr_sinh (result->value.real, x->value.real, GFC_RND_MODE);
    7533                 :         42 :         break;
    7534                 :            : 
    7535                 :          4 :       case BT_COMPLEX:
    7536                 :          4 :         mpc_sinh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    7537                 :          4 :         break;
    7538                 :            : 
    7539                 :          0 :       default:
    7540                 :          0 :         gcc_unreachable ();
    7541                 :            :     }
    7542                 :            : 
    7543                 :         46 :   return range_check (result, "SINH");
    7544                 :            : }
    7545                 :            : 
    7546                 :            : 
    7547                 :            : /* The argument is always a double precision real that is converted to
    7548                 :            :    single precision.  TODO: Rounding!  */
    7549                 :            : 
    7550                 :            : gfc_expr *
    7551                 :          2 : gfc_simplify_sngl (gfc_expr *a)
    7552                 :            : {
    7553                 :          2 :   gfc_expr *result;
    7554                 :          2 :   int tmp1, tmp2;
    7555                 :            : 
    7556                 :          2 :   if (a->expr_type != EXPR_CONSTANT)
    7557                 :            :     return NULL;
    7558                 :            : 
    7559                 :            :   /* For explicit conversion, turn off -Wconversion and -Wconversion-extra
    7560                 :            :      warnings.  */
    7561                 :          2 :   tmp1 = warn_conversion;
    7562                 :          2 :   tmp2 = warn_conversion_extra;
    7563                 :          2 :   warn_conversion = warn_conversion_extra = 0;
    7564                 :            : 
    7565                 :          2 :   result = gfc_real2real (a, gfc_default_real_kind);
    7566                 :            : 
    7567                 :          2 :   warn_conversion = tmp1;
    7568                 :          2 :   warn_conversion_extra = tmp2;
    7569                 :            : 
    7570                 :          2 :   return range_check (result, "SNGL");
    7571                 :            : }
    7572                 :            : 
    7573                 :            : 
    7574                 :            : gfc_expr *
    7575                 :        222 : gfc_simplify_spacing (gfc_expr *x)
    7576                 :            : {
    7577                 :        222 :   gfc_expr *result;
    7578                 :        222 :   int i;
    7579                 :        222 :   long int en, ep;
    7580                 :            : 
    7581                 :        222 :   if (x->expr_type != EXPR_CONSTANT)
    7582                 :            :     return NULL;
    7583                 :            : 
    7584                 :         72 :   i = gfc_validate_kind (x->ts.type, x->ts.kind, false);
    7585                 :         72 :   result = gfc_get_constant_expr (BT_REAL, x->ts.kind, &x->where);
    7586                 :            : 
    7587                 :            :   /* SPACING(+/- 0.0) = SPACING(TINY(0.0)) = TINY(0.0)  */
    7588                 :         72 :   if (mpfr_zero_p (x->value.real))
    7589                 :            :     {
    7590                 :         12 :       mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
    7591                 :         12 :       return result;
    7592                 :            :     }
    7593                 :            : 
    7594                 :            :   /* SPACING(inf) = NaN  */
    7595                 :         60 :   if (mpfr_inf_p (x->value.real))
    7596                 :            :     {
    7597                 :         12 :       mpfr_set_nan (result->value.real);
    7598                 :         12 :       return result;
    7599                 :            :     }
    7600                 :            : 
    7601                 :            :   /* SPACING(NaN) = same NaN  */
    7602                 :         48 :   if (mpfr_nan_p (x->value.real))
    7603                 :            :     {
    7604                 :          6 :       mpfr_set (result->value.real, x->value.real, GFC_RND_MODE);
    7605                 :          6 :       return result;
    7606                 :            :     }
    7607                 :            : 
    7608                 :            :   /* In the Fortran 95 standard, the result is b**(e - p) where b, e, and p
    7609                 :            :      are the radix, exponent of x, and precision.  This excludes the
    7610                 :            :      possibility of subnormal numbers.  Fortran 2003 states the result is
    7611                 :            :      b**max(e - p, emin - 1).  */
    7612                 :            : 
    7613                 :         42 :   ep = (long int) mpfr_get_exp (x->value.real) - gfc_real_kinds[i].digits;
    7614                 :         42 :   en = (long int) gfc_real_kinds[i].min_exponent - 1;
    7615                 :         42 :   en = en > ep ? en : ep;
    7616                 :            : 
    7617                 :         42 :   mpfr_set_ui (result->value.real, 1, GFC_RND_MODE);
    7618                 :         42 :   mpfr_mul_2si (result->value.real, result->value.real, en, GFC_RND_MODE);
    7619                 :            : 
    7620                 :         42 :   return range_check (result, "SPACING");
    7621                 :            : }
    7622                 :            : 
    7623                 :            : 
    7624                 :            : gfc_expr *
    7625                 :        853 : gfc_simplify_spread (gfc_expr *source, gfc_expr *dim_expr, gfc_expr *ncopies_expr)
    7626                 :            : {
    7627                 :        853 :   gfc_expr *result = NULL;
    7628                 :        853 :   int nelem, i, j, dim, ncopies;
    7629                 :        853 :   mpz_t size;
    7630                 :            : 
    7631                 :        853 :   if ((!gfc_is_constant_expr (source)
    7632                 :        715 :        && !is_constant_array_expr (source))
    7633                 :        157 :       || !gfc_is_constant_expr (dim_expr)
    7634                 :       1010 :       || !gfc_is_constant_expr (ncopies_expr))
    7635                 :        696 :     return NULL;
    7636                 :            : 
    7637                 :        157 :   gcc_assert (dim_expr->ts.type == BT_INTEGER);
    7638                 :        157 :   gfc_extract_int (dim_expr, &dim);
    7639                 :        157 :   dim -= 1;   /* zero-base DIM */
    7640                 :            : 
    7641                 :        157 :   gcc_assert (ncopies_expr->ts.type == BT_INTEGER);
    7642                 :        157 :   gfc_extract_int (ncopies_expr, &ncopies);
    7643                 :        157 :   ncopies = MAX (ncopies, 0);
    7644                 :            : 
    7645                 :            :   /* Do not allow the array size to exceed the limit for an array
    7646                 :            :      constructor.  */
    7647                 :        157 :   if (source->expr_type == EXPR_ARRAY)
    7648                 :            :     {
    7649                 :         37 :       if (!gfc_array_size (source, &size))
    7650                 :          0 :         gfc_internal_error ("Failure getting length of a constant array.");
    7651                 :            :     }
    7652                 :            :   else
    7653                 :        120 :     mpz_init_set_ui (size, 1);
    7654                 :            : 
    7655                 :        157 :   nelem = mpz_get_si (size) * ncopies;
    7656                 :        157 :   if (nelem > flag_max_array_constructor)
    7657                 :            :     {
    7658                 :          3 :       if (gfc_init_expr_flag)
    7659                 :            :         {
    7660                 :          2 :           gfc_error ("The number of elements (%d) in the array constructor "
    7661                 :            :                      "at %L requires an increase of the allowed %d upper "
    7662                 :            :                      "limit.  See %<-fmax-array-constructor%> option.",
    7663                 :            :                      nelem, &source->where, flag_max_array_constructor);
    7664                 :          2 :           return &gfc_bad_expr;
    7665                 :            :         }
    7666                 :            :       else
    7667                 :            :         return NULL;
    7668                 :            :     }
    7669                 :            : 
    7670                 :        154 :   if (source->expr_type == EXPR_CONSTANT
    7671                 :         40 :       || source->expr_type == EXPR_STRUCTURE)
    7672                 :            :     {
    7673                 :        120 :       gcc_assert (dim == 0);
    7674                 :            : 
    7675                 :        120 :       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
    7676                 :            :                                    &source->where);
    7677                 :        120 :       if (source->ts.type == BT_DERIVED)
    7678                 :          6 :         result->ts.u.derived = source->ts.u.derived;
    7679                 :        120 :       result->rank = 1;
    7680                 :        120 :       result->shape = gfc_get_shape (result->rank);
    7681                 :        120 :       mpz_init_set_si (result->shape[0], ncopies);
    7682                 :            : 
    7683                 :       1014 :       for (i = 0; i < ncopies; ++i)
    7684                 :        894 :         gfc_constructor_append_expr (&result->value.constructor,
    7685                 :            :                                      gfc_copy_expr (source), NULL);
    7686                 :            :     }
    7687                 :         34 :   else if (source->expr_type == EXPR_ARRAY)
    7688                 :            :     {
    7689                 :         34 :       int offset, rstride[GFC_MAX_DIMENSIONS], extent[GFC_MAX_DIMENSIONS];
    7690                 :         34 :       gfc_constructor *source_ctor;
    7691                 :            : 
    7692                 :         34 :       gcc_assert (source->rank < GFC_MAX_DIMENSIONS);
    7693                 :         34 :       gcc_assert (dim >= 0 && dim <= source->rank);
    7694                 :            : 
    7695                 :         34 :       result = gfc_get_array_expr (source->ts.type, source->ts.kind,
    7696                 :            :                                    &source->where);
    7697                 :         34 :       if (source->ts.type == BT_DERIVED)
    7698                 :          1 :         result->ts.u.derived = source->ts.u.derived;
    7699                 :         34 :       result->rank = source->rank + 1;
    7700                 :         34 :       result->shape = gfc_get_shape (result->rank);
    7701                 :            : 
    7702                 :        120 :       for (i = 0, j = 0; i < result->rank; ++i)
    7703                 :            :         {
    7704                 :         86 :           if (i != dim)
    7705                 :         52 :             mpz_init_set (result->shape[i], source->shape[j++]);
    7706                 :            :           else
    7707                 :         34 :             mpz_init_set_si (result->shape[i], ncopies);
    7708                 :            : 
    7709                 :         86 :           extent[i] = mpz_get_si (result->shape[i]);
    7710                 :         86 :           rstride[i] = (i == 0) ? 1 : rstride[i-1] * extent[i-1];
    7711                 :            :         }
    7712                 :            : 
    7713                 :         34 :       offset = 0;
    7714                 :         34 :       for (source_ctor = gfc_constructor_first (source->value.constructor);
    7715                 :        242 :            source_ctor; source_ctor = gfc_constructor_next (source_ctor))
    7716                 :            :         {
    7717                 :        732 :           for (i = 0; i < ncopies; ++i)
    7718                 :        524 :             gfc_constructor_insert_expr (&result->value.constructor,
    7719                 :            :                                          gfc_copy_expr (source_ctor->expr),
    7720                 :        524 :                                          NULL, offset + i * rstride[dim]);
    7721                 :            : 
    7722                 :        390 :           offset += (dim == 0 ? ncopies : 1);
    7723                 :            :         }
    7724                 :            :     }
    7725                 :            :   else
    7726                 :            :     {
    7727                 :          0 :       gfc_error ("Simplification of SPREAD at %C not yet implemented");
    7728                 :          0 :       return &gfc_bad_expr;
    7729                 :            :     }
    7730                 :            : 
    7731                 :        154 :   if (source->ts.type == BT_CHARACTER)
    7732                 :         30 :     result->ts.u.cl = source->ts.u.cl;
    7733                 :            : 
    7734                 :            :   return result;
    7735                 :            : }
    7736                 :            : 
    7737                 :            : 
    7738                 :            : gfc_expr *
    7739                 :        812 : gfc_simplify_sqrt (gfc_expr *e)
    7740                 :            : {
    7741                 :        812 :   gfc_expr *result = NULL;
    7742                 :            : 
    7743                 :        812 :   if (e->expr_type != EXPR_CONSTANT)
    7744                 :            :     return NULL;
    7745                 :            : 
    7746                 :        160 :   switch (e->ts.type)
    7747                 :            :     {
    7748                 :        103 :       case BT_REAL:
    7749                 :        103 :         if (mpfr_cmp_si (e->value.real, 0) < 0)
    7750                 :            :           {
    7751                 :          0 :             gfc_error ("Argument of SQRT at %L has a negative value",
    7752                 :            :                        &e->where);
    7753                 :          0 :             return &gfc_bad_expr;
    7754                 :            :           }
    7755                 :        103 :         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    7756                 :        103 :         mpfr_sqrt (result->value.real, e->value.real, GFC_RND_MODE);
    7757                 :        103 :         break;
    7758                 :            : 
    7759                 :         57 :       case BT_COMPLEX:
    7760                 :         57 :         gfc_set_model (e->value.real);
    7761                 :            : 
    7762                 :         57 :         result = gfc_get_constant_expr (e->ts.type, e->ts.kind, &e->where);
    7763                 :         57 :         mpc_sqrt (result->value.complex, e->value.complex, GFC_MPC_RND_MODE);
    7764                 :         57 :         break;
    7765                 :            : 
    7766                 :          0 :       default:
    7767                 :          0 :         gfc_internal_error ("invalid argument of SQRT at %L", &e->where);
    7768                 :            :     }
    7769                 :            : 
    7770                 :        160 :   return range_check (result, "SQRT");
    7771                 :            : }
    7772                 :            : 
    7773                 :            : 
    7774                 :            : gfc_expr *
    7775                 :       3927 : gfc_simplify_sum (gfc_expr *array, gfc_expr *dim, gfc_expr *mask)
    7776                 :            : {
    7777                 :       3927 :   return simplify_transformation (array, dim, mask, 0, gfc_add);
    7778                 :            : }
    7779                 :            : 
    7780                 :            : 
    7781                 :            : gfc_expr *
    7782                 :         96 : gfc_simplify_cotan (gfc_expr *x)
    7783                 :            : {
    7784                 :         96 :   gfc_expr *result;
    7785                 :         96 :   mpc_t swp, *val;
    7786                 :            : 
    7787                 :         96 :   if (x->expr_type != EXPR_CONSTANT)
    7788                 :            :     return NULL;
    7789                 :            : 
    7790                 :         12 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7791                 :            : 
    7792                 :         12 :   switch (x->ts.type)
    7793                 :            :     {
    7794                 :         12 :     case BT_REAL:
    7795                 :         12 :       mpfr_cot (result->value.real, x->value.real, GFC_RND_MODE);
    7796                 :         12 :       break;
    7797                 :            : 
    7798                 :          0 :     case BT_COMPLEX:
    7799                 :            :       /* There is no builtin mpc_cot, so compute cot = cos / sin.  */
    7800                 :          0 :       val = &result->value.complex;
    7801                 :          0 :       mpc_init2 (swp, mpfr_get_default_prec ());
    7802                 :          0 :       mpc_cos (swp, x->value.complex, GFC_MPC_RND_MODE);
    7803                 :          0 :       mpc_sin (*val, x->value.complex, GFC_MPC_RND_MODE);
    7804                 :          0 :       mpc_div (*val, swp, *val, GFC_MPC_RND_MODE);
    7805                 :          0 :       mpc_clear (swp);
    7806                 :          0 :       break;
    7807                 :            : 
    7808                 :          0 :     default:
    7809                 :          0 :       gcc_unreachable ();
    7810                 :            :     }
    7811                 :            : 
    7812                 :         12 :   return range_check (result, "COTAN");
    7813                 :            : }
    7814                 :            : 
    7815                 :            : 
    7816                 :            : gfc_expr *
    7817                 :        397 : gfc_simplify_tan (gfc_expr *x)
    7818                 :            : {
    7819                 :        397 :   gfc_expr *result;
    7820                 :            : 
    7821                 :        397 :   if (x->expr_type != EXPR_CONSTANT)
    7822                 :            :     return NULL;
    7823                 :            : 
    7824                 :         58 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7825                 :            : 
    7826                 :         58 :   switch (x->ts.type)
    7827                 :            :     {
    7828                 :         54 :       case BT_REAL:
    7829                 :         54 :         mpfr_tan (result->value.real, x->value.real, GFC_RND_MODE);
    7830                 :         54 :         break;
    7831                 :            : 
    7832                 :          4 :       case BT_COMPLEX:
    7833                 :          4 :         mpc_tan (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    7834                 :          4 :         break;
    7835                 :            : 
    7836                 :          0 :       default:
    7837                 :          0 :         gcc_unreachable ();
    7838                 :            :     }
    7839                 :            : 
    7840                 :         58 :   return range_check (result, "TAN");
    7841                 :            : }
    7842                 :            : 
    7843                 :            : 
    7844                 :            : gfc_expr *
    7845                 :        169 : gfc_simplify_tanh (gfc_expr *x)
    7846                 :            : {
    7847                 :        169 :   gfc_expr *result;
    7848                 :            : 
    7849                 :        169 :   if (x->expr_type != EXPR_CONSTANT)
    7850                 :            :     return NULL;
    7851                 :            : 
    7852                 :         46 :   result = gfc_get_constant_expr (x->ts.type, x->ts.kind, &x->where);
    7853                 :            : 
    7854                 :         46 :   switch (x->ts.type)
    7855                 :            :     {
    7856                 :         42 :       case BT_REAL:
    7857                 :         42 :         mpfr_tanh (result->value.real, x->value.real, GFC_RND_MODE);
    7858                 :         42 :         break;
    7859                 :            : 
    7860                 :          4 :       case BT_COMPLEX:
    7861                 :          4 :         mpc_tanh (result->value.complex, x->value.complex, GFC_MPC_RND_MODE);
    7862                 :          4 :         break;
    7863                 :            : 
    7864                 :          0 :       default:
    7865                 :          0 :         gcc_unreachable ();
    7866                 :            :     }
    7867                 :            : 
    7868                 :         46 :   return range_check (result, "TANH");
    7869                 :            : }
    7870                 :            : 
    7871                 :            : 
    7872                 :            : gfc_expr *
    7873                 :        729 : gfc_simplify_tiny (gfc_expr *e)
    7874                 :            : {
    7875                 :        729 :   gfc_expr *result;
    7876                 :        729 :   int i;
    7877                 :            : 
    7878                 :        729 :   i = gfc_validate_kind (BT_REAL, e->ts.kind, false);
    7879                 :            : 
    7880                 :        729 :   result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
    7881                 :        729 :   mpfr_set (result->value.real, gfc_real_kinds[i].tiny, GFC_RND_MODE);
    7882                 :            : 
    7883                 :        729 :   return result;
    7884                 :            : }
    7885                 :            : 
    7886                 :            : 
    7887                 :            : gfc_expr *
    7888                 :        822 : gfc_simplify_trailz (gfc_expr *e)
    7889                 :            : {
    7890                 :        822 :   unsigned long tz, bs;
    7891                 :        822 :   int i;
    7892                 :            : 
    7893                 :        822 :   if (e->expr_type != EXPR_CONSTANT)
    7894                 :            :     return NULL;
    7895                 :            : 
    7896                 :        258 :   i = gfc_validate_kind (e->ts.type, e->ts.kind, false);
    7897                 :        258 :   bs = gfc_integer_kinds[i].bit_size;
    7898                 :        258 :   tz = mpz_scan1 (e->value.integer, 0);
    7899                 :            : 
    7900                 :        258 :   return gfc_get_int_expr (gfc_default_integer_kind,
    7901                 :        258 :                            &e->where, MIN (tz, bs));
    7902                 :            : }
    7903                 :            : 
    7904                 :            : 
    7905                 :            : gfc_expr *
    7906                 :       1962 : gfc_simplify_transfer (gfc_expr *source, gfc_expr *mold, gfc_expr *size)
    7907                 :            : {
    7908                 :       1962 :   gfc_expr *result;
    7909                 :       1962 :   gfc_expr *mold_element;
    7910                 :       1962 :   size_t source_size;
    7911                 :       1962 :   size_t result_size;
    7912                 :       1962 :   size_t buffer_size;
    7913                 :       1962 :   mpz_t tmp;
    7914                 :       1962 :   unsigned char *buffer;
    7915                 :       1962 :   size_t result_length;
    7916                 :            : 
    7917                 :       1962 :   if (!gfc_is_constant_expr (source) || !gfc_is_constant_expr (size))
    7918                 :       1199 :     return NULL;
    7919                 :            : 
    7920                 :        763 :   if (!gfc_resolve_expr (mold))
    7921                 :            :     return NULL;
    7922                 :        763 :   if (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
    7923                 :            :     return NULL;
    7924                 :            : 
    7925                 :        709 :   if (!gfc_calculate_transfer_sizes (source, mold, size, &source_size,
    7926                 :            :                                      &result_size, &result_length))
    7927                 :            :     return NULL;
    7928                 :            : 
    7929                 :            :   /* Calculate the size of the source.  */
    7930                 :        684 :   if (source->expr_type == EXPR_ARRAY && !gfc_array_size (source, &tmp))
    7931                 :          0 :     gfc_internal_error ("Failure getting length of a constant array.");
    7932                 :            : 
    7933                 :            :   /* Create an empty new expression with the appropriate characteristics.  */
    7934                 :        684 :   result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
    7935                 :            :                                   &source->where);
    7936                 :        684 :   result->ts = mold->ts;
    7937                 :            : 
    7938                 :         78 :   mold_element = (mold->expr_type == EXPR_ARRAY && mold->value.constructor)
    7939                 :        744 :                  ? gfc_constructor_first (mold->value.constructor)->expr
    7940                 :            :                  : mold;
    7941                 :            : 
    7942                 :            :   /* Set result character length, if needed.  Note that this needs to be
    7943                 :            :      set even for array expressions, in order to pass this information into
    7944                 :            :      gfc_target_interpret_expr.  */
    7945                 :        684 :   if (result->ts.type == BT_CHARACTER && gfc_is_constant_expr (mold_element))
    7946                 :        209 :     result->value.character.length = mold_element->value.character.length;
    7947                 :            : 
    7948                 :            :   /* Set the number of elements in the result, and determine its size.  */
    7949                 :            : 
    7950                 :        684 :   if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
    7951                 :            :     {
    7952                 :        145 :       result->expr_type = EXPR_ARRAY;
    7953                 :        145 :       result->rank = 1;
    7954                 :        145 :       result->shape = gfc_get_shape (1);
    7955                 :        145 :       mpz_init_set_ui (result->shape[0], result_length);
    7956                 :            :     }
    7957                 :            :   else
    7958                 :        539 :     result->rank = 0;
    7959                 :            : 
    7960                 :            :   /* Allocate the buffer to store the binary version of the source.  */
    7961                 :        684 :   buffer_size = MAX (source_size, result_size);
    7962                 :        684 :   buffer = (unsigned char*)alloca (buffer_size);
    7963                 :        684 :   memset (buffer, 0, buffer_size);
    7964                 :            : 
    7965                 :            :   /* Now write source to the buffer.  */
    7966                 :        684 :   gfc_target_encode_expr (source, buffer, buffer_size);
    7967                 :            : 
    7968                 :            :   /* And read the buffer back into the new expression.  */
    7969                 :        684 :   gfc_target_interpret_expr (buffer, buffer_size, result, false);
    7970                 :            : 
    7971                 :        684 :   return result;
    7972                 :            : }
    7973                 :            : 
    7974                 :            : 
    7975                 :            : gfc_expr *
    7976                 :       1384 : gfc_simplify_transpose (gfc_expr *matrix)
    7977                 :            : {
    7978                 :       1384 :   int row, matrix_rows, col, matrix_cols;
    7979                 :       1384 :   gfc_expr *result;
    7980                 :            : 
    7981                 :       1384 :   if (!is_constant_array_expr (matrix))
    7982                 :            :     return NULL;
    7983                 :            : 
    7984                 :         38 :   gcc_assert (matrix->rank == 2);
    7985                 :            : 
    7986                 :         38 :   result = gfc_get_array_expr (matrix->ts.type, matrix->ts.kind,
    7987                 :            :                                &matrix->where);
    7988                 :         38 :   result->rank = 2;
    7989                 :         38 :   result->shape = gfc_get_shape (result->rank);
    7990                 :         38 :   mpz_set (result->shape[0], matrix->shape[1]);
    7991                 :         38 :   mpz_set (result->shape[1], matrix->shape[0]);
    7992                 :            : 
    7993                 :         38 :   if (matrix->ts.type == BT_CHARACTER)
    7994                 :         18 :     result->ts.u.cl = matrix->ts.u.cl;
    7995                 :         20 :   else if (matrix->ts.type == BT_DERIVED)
    7996                 :          1 :     result->ts.u.derived = matrix->ts.u.derived;
    7997                 :            : 
    7998                 :         38 :   matrix_rows = mpz_get_si (matrix->shape[0]);
    7999                 :         38 :   matrix_cols = mpz_get_si (matrix->shape[1]);
    8000                 :        182 :   for (row = 0; row < matrix_rows; ++row)
    8001                 :        482 :     for (col = 0; col < matrix_cols; ++col)
    8002                 :            :       {
    8003                 :        676 :         gfc_expr *e = gfc_constructor_lookup_expr (matrix->value.constructor,
    8004                 :        338 :                                                    col * matrix_rows + row);
    8005                 :        338 :         gfc_constructor_insert_expr (&result->value.constructor,
    8006                 :            :                                      gfc_copy_expr (e), &matrix->where,
    8007                 :        338 :                                      row * matrix_cols + col);
    8008                 :            :       }
    8009                 :            : 
    8010                 :            :   return result;
    8011                 :            : }
    8012                 :            : 
    8013                 :            : 
    8014                 :            : gfc_expr *
    8015                 :       4239 : gfc_simplify_trim (gfc_expr *e)
    8016                 :            : {
    8017                 :       4239 :   gfc_expr *result;
    8018                 :       4239 :   int count, i, len, lentrim;
    8019                 :            : 
    8020                 :       4239 :   if (e->expr_type != EXPR_CONSTANT)
    8021                 :            :     return NULL;
    8022                 :            : 
    8023                 :         43 :   len = e->value.character.length;
    8024                 :        195 :   for (count = 0, i = 1; i <= len; ++i)
    8025                 :            :     {
    8026                 :        195 :       if (e->value.character.string[len - i] == ' ')
    8027                 :        152 :         count++;
    8028                 :            :       else
    8029                 :            :         break;
    8030                 :            :     }
    8031                 :            : 
    8032                 :         43 :   lentrim = len - count;
    8033                 :            : 
    8034                 :         43 :   result = gfc_get_character_expr (e->ts.kind, &e->where, NULL, lentrim);
    8035                 :        713 :   for (i = 0; i < lentrim; i++)
    8036                 :        670 :     result->value.character.string[i] = e->value.character.string[i];
    8037                 :            : 
    8038                 :            :   return result;
    8039                 :            : }
    8040                 :            : 
    8041                 :            : 
    8042                 :            : gfc_expr *
    8043                 :        227 : gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
    8044                 :            : {
    8045                 :        227 :   gfc_expr *result;
    8046                 :        227 :   gfc_ref *ref;
    8047                 :        227 :   gfc_array_spec *as;
    8048                 :        227 :   gfc_constructor *sub_cons;
    8049                 :        227 :   bool first_image;
    8050                 :        227 :   int d;
    8051                 :            : 
    8052                 :        227 :   if (!is_constant_array_expr (sub))
    8053                 :            :     return NULL;
    8054                 :            : 
    8055                 :            :   /* Follow any component references.  */
    8056                 :        223 :   as = coarray->symtree->n.sym->as;
    8057                 :        446 :   for (ref = coarray->ref; ref; ref = ref->next)
    8058                 :        223 :     if (ref->type == REF_COMPONENT)
    8059                 :          0 :       as = ref->u.ar.as;
    8060                 :            : 
    8061                 :        223 :   if (as->type == AS_DEFERRED)
    8062                 :            :     return NULL;
    8063                 :            : 
    8064                 :            :   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
    8065                 :            :      the cosubscript addresses the first image.  */
    8066                 :            : 
    8067                 :        131 :   sub_cons = gfc_constructor_first (sub->value.constructor);
    8068                 :        131 :   first_image = true;
    8069                 :            : 
    8070                 :        289 :   for (d = 1; d <= as->corank; d++)
    8071                 :            :     {
    8072                 :        204 :       gfc_expr *ca_bound;
    8073                 :        204 :       int cmp;
    8074                 :            : 
    8075                 :        204 :       gcc_assert (sub_cons != NULL);
    8076                 :            : 
    8077                 :        204 :       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
    8078                 :            :                                      NULL, true);
    8079                 :        204 :       if (ca_bound == NULL)
    8080                 :            :         return NULL;
    8081                 :            : 
    8082                 :        160 :       if (ca_bound == &gfc_bad_expr)
    8083                 :            :         return ca_bound;
    8084                 :            : 
    8085                 :        160 :       cmp = mpz_cmp (ca_bound->value.integer, sub_cons->expr->value.integer);
    8086                 :            : 
    8087                 :        160 :       if (cmp == 0)
    8088                 :            :         {
    8089                 :        109 :           gfc_free_expr (ca_bound);
    8090                 :        109 :           sub_cons = gfc_constructor_next (sub_cons);
    8091                 :        109 :           continue;
    8092                 :            :         }
    8093                 :            : 
    8094                 :         51 :       first_image = false;
    8095                 :            : 
    8096                 :         51 :       if (cmp > 0)
    8097                 :            :         {
    8098                 :          1 :           gfc_error ("Out of bounds in IMAGE_INDEX at %L for dimension %d, "
    8099                 :            :                      "SUB has %ld and COARRAY lower bound is %ld)",
    8100                 :            :                      &coarray->where, d,
    8101                 :            :                      mpz_get_si (sub_cons->expr->value.integer),
    8102                 :            :                      mpz_get_si (ca_bound->value.integer));
    8103                 :          1 :           gfc_free_expr (ca_bound);
    8104                 :          1 :           return &gfc_bad_expr;
    8105                 :            :         }
    8106                 :            : 
    8107                 :         50 :       gfc_free_expr (ca_bound);
    8108                 :            : 
    8109                 :            :       /* Check whether upperbound is valid for the multi-images case.  */