LCOV - code coverage report
Current view: top level - gcc/fortran - trans-intrinsic.cc (source / functions) Coverage Total Hit
Test: gcc.info Lines: 93.1 % 6740 6273
Test Date: 2023-09-09 13:19:57 Functions: 97.0 % 164 159
Legend: Lines: hit not hit | Branches: + taken - not taken # not executed Branches: - 0 0

             Branch data     Line data    Source code
       1                 :             : /* Intrinsic translation
       2                 :             :    Copyright (C) 2002-2023 Free Software Foundation, Inc.
       3                 :             :    Contributed by Paul Brook <paul@nowt.org>
       4                 :             :    and Steven Bosscher <s.bosscher@student.tudelft.nl>
       5                 :             : 
       6                 :             : This file is part of GCC.
       7                 :             : 
       8                 :             : GCC is free software; you can redistribute it and/or modify it under
       9                 :             : the terms of the GNU General Public License as published by the Free
      10                 :             : Software Foundation; either version 3, or (at your option) any later
      11                 :             : version.
      12                 :             : 
      13                 :             : GCC is distributed in the hope that it will be useful, but WITHOUT ANY
      14                 :             : WARRANTY; without even the implied warranty of MERCHANTABILITY or
      15                 :             : FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
      16                 :             : for more details.
      17                 :             : 
      18                 :             : You should have received a copy of the GNU General Public License
      19                 :             : along with GCC; see the file COPYING3.  If not see
      20                 :             : <http://www.gnu.org/licenses/>.  */
      21                 :             : 
      22                 :             : /* trans-intrinsic.cc-- generate GENERIC trees for calls to intrinsics.  */
      23                 :             : 
      24                 :             : #include "config.h"
      25                 :             : #include "system.h"
      26                 :             : #include "coretypes.h"
      27                 :             : #include "memmodel.h"
      28                 :             : #include "tm.h"               /* For UNITS_PER_WORD.  */
      29                 :             : #include "tree.h"
      30                 :             : #include "gfortran.h"
      31                 :             : #include "trans.h"
      32                 :             : #include "stringpool.h"
      33                 :             : #include "fold-const.h"
      34                 :             : #include "internal-fn.h"
      35                 :             : #include "tree-nested.h"
      36                 :             : #include "stor-layout.h"
      37                 :             : #include "toplev.h"   /* For rest_of_decl_compilation.  */
      38                 :             : #include "arith.h"
      39                 :             : #include "trans-const.h"
      40                 :             : #include "trans-types.h"
      41                 :             : #include "trans-array.h"
      42                 :             : #include "dependency.h"       /* For CAF array alias analysis.  */
      43                 :             : #include "attribs.h"
      44                 :             : #include "realmpfr.h"
      45                 :             : 
      46                 :             : /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
      47                 :             : 
      48                 :             : /* This maps Fortran intrinsic math functions to external library or GCC
      49                 :             :    builtin functions.  */
      50                 :             : typedef struct GTY(()) gfc_intrinsic_map_t {
      51                 :             :   /* The explicit enum is required to work around inadequacies in the
      52                 :             :      garbage collection/gengtype parsing mechanism.  */
      53                 :             :   enum gfc_isym_id id;
      54                 :             : 
      55                 :             :   /* Enum value from the "language-independent", aka C-centric, part
      56                 :             :      of gcc, or END_BUILTINS of no such value set.  */
      57                 :             :   enum built_in_function float_built_in;
      58                 :             :   enum built_in_function double_built_in;
      59                 :             :   enum built_in_function long_double_built_in;
      60                 :             :   enum built_in_function complex_float_built_in;
      61                 :             :   enum built_in_function complex_double_built_in;
      62                 :             :   enum built_in_function complex_long_double_built_in;
      63                 :             : 
      64                 :             :   /* True if the naming pattern is to prepend "c" for complex and
      65                 :             :      append "f" for kind=4.  False if the naming pattern is to
      66                 :             :      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
      67                 :             :   bool libm_name;
      68                 :             : 
      69                 :             :   /* True if a complex version of the function exists.  */
      70                 :             :   bool complex_available;
      71                 :             : 
      72                 :             :   /* True if the function should be marked const.  */
      73                 :             :   bool is_constant;
      74                 :             : 
      75                 :             :   /* The base library name of this function.  */
      76                 :             :   const char *name;
      77                 :             : 
      78                 :             :   /* Cache decls created for the various operand types.  */
      79                 :             :   tree real4_decl;
      80                 :             :   tree real8_decl;
      81                 :             :   tree real10_decl;
      82                 :             :   tree real16_decl;
      83                 :             :   tree complex4_decl;
      84                 :             :   tree complex8_decl;
      85                 :             :   tree complex10_decl;
      86                 :             :   tree complex16_decl;
      87                 :             : }
      88                 :             : gfc_intrinsic_map_t;
      89                 :             : 
      90                 :             : /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
      91                 :             :    defines complex variants of all of the entries in mathbuiltins.def
      92                 :             :    except for atan2.  */
      93                 :             : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
      94                 :             :   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
      95                 :             :     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
      96                 :             :     true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
      97                 :             :     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
      98                 :             : 
      99                 :             : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
     100                 :             :   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
     101                 :             :     BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
     102                 :             :     BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
     103                 :             :     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
     104                 :             : 
     105                 :             : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
     106                 :             :   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
     107                 :             :     END_BUILTINS, END_BUILTINS, END_BUILTINS, \
     108                 :             :     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
     109                 :             :     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
     110                 :             : 
     111                 :             : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
     112                 :             :   { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
     113                 :             :     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
     114                 :             :     true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
     115                 :             :     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
     116                 :             : 
     117                 :             : static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
     118                 :             : {
     119                 :             :   /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
     120                 :             :      DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
     121                 :             :      to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro.  */
     122                 :             : #include "mathbuiltins.def"
     123                 :             : 
     124                 :             :   /* Functions in libgfortran.  */
     125                 :             :   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
     126                 :             :   LIB_FUNCTION (SIND, "sind", false),
     127                 :             :   LIB_FUNCTION (COSD, "cosd", false),
     128                 :             :   LIB_FUNCTION (TAND, "tand", false),
     129                 :             : 
     130                 :             :   /* End the list.  */
     131                 :             :   LIB_FUNCTION (NONE, NULL, false)
     132                 :             : 
     133                 :             : };
     134                 :             : #undef OTHER_BUILTIN
     135                 :             : #undef LIB_FUNCTION
     136                 :             : #undef DEFINE_MATH_BUILTIN
     137                 :             : #undef DEFINE_MATH_BUILTIN_C
     138                 :             : 
     139                 :             : 
     140                 :             : enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
     141                 :             : 
     142                 :             : 
     143                 :             : /* Find the correct variant of a given builtin from its argument.  */
     144                 :             : static tree
     145                 :       10746 : builtin_decl_for_precision (enum built_in_function base_built_in,
     146                 :             :                             int precision)
     147                 :             : {
     148                 :       10746 :   enum built_in_function i = END_BUILTINS;
     149                 :             : 
     150                 :       10746 :   gfc_intrinsic_map_t *m;
     151                 :      378571 :   for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
     152                 :             :     ;
     153                 :             : 
     154                 :       10746 :   if (precision == TYPE_PRECISION (float_type_node))
     155                 :        5126 :     i = m->float_built_in;
     156                 :        5620 :   else if (precision == TYPE_PRECISION (double_type_node))
     157                 :             :     i = m->double_built_in;
     158                 :        1695 :   else if (precision == TYPE_PRECISION (long_double_type_node)
     159                 :        1695 :            && (!gfc_real16_is_float128
     160                 :        1571 :                || long_double_type_node != gfc_float128_type_node))
     161                 :        1571 :     i = m->long_double_built_in;
     162                 :         124 :   else if (precision == TYPE_PRECISION (gfc_float128_type_node))
     163                 :             :     {
     164                 :             :       /* Special treatment, because it is not exactly a built-in, but
     165                 :             :          a library function.  */
     166                 :         124 :       return m->real16_decl;
     167                 :             :     }
     168                 :             : 
     169                 :       10622 :   return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
     170                 :             : }
     171                 :             : 
     172                 :             : 
     173                 :             : tree
     174                 :       10074 : gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
     175                 :             :                                  int kind)
     176                 :             : {
     177                 :       10074 :   int i = gfc_validate_kind (BT_REAL, kind, false);
     178                 :             : 
     179                 :       10074 :   if (gfc_real_kinds[i].c_float128)
     180                 :             :     {
     181                 :             :       /* For _Float128, the story is a bit different, because we return
     182                 :             :          a decl to a library function rather than a built-in.  */
     183                 :             :       gfc_intrinsic_map_t *m;
     184                 :       29987 :       for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
     185                 :             :         ;
     186                 :             : 
     187                 :         905 :       return m->real16_decl;
     188                 :             :     }
     189                 :             : 
     190                 :        9169 :   return builtin_decl_for_precision (double_built_in,
     191                 :        9169 :                                      gfc_real_kinds[i].mode_precision);
     192                 :             : }
     193                 :             : 
     194                 :             : 
     195                 :             : /* Evaluate the arguments to an intrinsic function.  The value
     196                 :             :    of NARGS may be less than the actual number of arguments in EXPR
     197                 :             :    to allow optional "KIND" arguments that are not included in the
     198                 :             :    generated code to be ignored.  */
     199                 :             : 
     200                 :             : static void
     201                 :       67549 : gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
     202                 :             :                                   tree *argarray, int nargs)
     203                 :             : {
     204                 :       67549 :   gfc_actual_arglist *actual;
     205                 :       67549 :   gfc_expr *e;
     206                 :       67549 :   gfc_intrinsic_arg  *formal;
     207                 :       67549 :   gfc_se argse;
     208                 :       67549 :   int curr_arg;
     209                 :             : 
     210                 :       67549 :   formal = expr->value.function.isym->formal;
     211                 :       67549 :   actual = expr->value.function.actual;
     212                 :             : 
     213                 :      152731 :    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
     214                 :       85182 :         actual = actual->next,
     215                 :       85182 :         formal = formal ? formal->next : NULL)
     216                 :             :     {
     217                 :       85182 :       gcc_assert (actual);
     218                 :       85182 :       e = actual->expr;
     219                 :             :       /* Skip omitted optional arguments.  */
     220                 :       85182 :       if (!e)
     221                 :             :         {
     222                 :          31 :           --curr_arg;
     223                 :          31 :           continue;
     224                 :             :         }
     225                 :             : 
     226                 :             :       /* Evaluate the parameter.  This will substitute scalarized
     227                 :             :          references automatically.  */
     228                 :       85151 :       gfc_init_se (&argse, se);
     229                 :             : 
     230                 :       85151 :       if (e->ts.type == BT_CHARACTER)
     231                 :             :         {
     232                 :        9325 :           gfc_conv_expr (&argse, e);
     233                 :        9325 :           gfc_conv_string_parameter (&argse);
     234                 :        9325 :           argarray[curr_arg++] = argse.string_length;
     235                 :        9325 :           gcc_assert (curr_arg < nargs);
     236                 :             :         }
     237                 :             :       else
     238                 :       75826 :         gfc_conv_expr_val (&argse, e);
     239                 :             : 
     240                 :             :       /* If an optional argument is itself an optional dummy argument,
     241                 :             :          check its presence and substitute a null if absent.  */
     242                 :       85151 :       if (e->expr_type == EXPR_VARIABLE
     243                 :       45638 :             && e->symtree->n.sym->attr.optional
     244                 :         107 :             && formal
     245                 :          57 :             && formal->optional)
     246                 :          14 :         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
     247                 :             : 
     248                 :       85151 :       gfc_add_block_to_block (&se->pre, &argse.pre);
     249                 :       85151 :       gfc_add_block_to_block (&se->post, &argse.post);
     250                 :       85151 :       argarray[curr_arg] = argse.expr;
     251                 :             :     }
     252                 :       67549 : }
     253                 :             : 
     254                 :             : /* Count the number of actual arguments to the intrinsic function EXPR
     255                 :             :    including any "hidden" string length arguments.  */
     256                 :             : 
     257                 :             : static unsigned int
     258                 :       44339 : gfc_intrinsic_argument_list_length (gfc_expr *expr)
     259                 :             : {
     260                 :       44339 :   int n = 0;
     261                 :       44339 :   gfc_actual_arglist *actual;
     262                 :             : 
     263                 :      101781 :   for (actual = expr->value.function.actual; actual; actual = actual->next)
     264                 :             :     {
     265                 :       57442 :       if (!actual->expr)
     266                 :        5810 :         continue;
     267                 :             : 
     268                 :       51632 :       if (actual->expr->ts.type == BT_CHARACTER)
     269                 :        4409 :         n += 2;
     270                 :             :       else
     271                 :       47223 :         n++;
     272                 :             :     }
     273                 :             : 
     274                 :       44339 :   return n;
     275                 :             : }
     276                 :             : 
     277                 :             : 
     278                 :             : /* Conversions between different types are output by the frontend as
     279                 :             :    intrinsic functions.  We implement these directly with inline code.  */
     280                 :             : 
     281                 :             : static void
     282                 :       29780 : gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
     283                 :             : {
     284                 :       29780 :   tree type;
     285                 :       29780 :   tree *args;
     286                 :       29780 :   int nargs;
     287                 :             : 
     288                 :       29780 :   nargs = gfc_intrinsic_argument_list_length (expr);
     289                 :       29780 :   args = XALLOCAVEC (tree, nargs);
     290                 :             : 
     291                 :             :   /* Evaluate all the arguments passed. Whilst we're only interested in the
     292                 :             :      first one here, there are other parts of the front-end that assume this
     293                 :             :      and will trigger an ICE if it's not the case.  */
     294                 :       29780 :   type = gfc_typenode_for_spec (&expr->ts);
     295                 :       29780 :   gcc_assert (expr->value.function.actual->expr);
     296                 :       29780 :   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
     297                 :             : 
     298                 :             :   /* Conversion between character kinds involves a call to a library
     299                 :             :      function.  */
     300                 :       29780 :   if (expr->ts.type == BT_CHARACTER)
     301                 :             :     {
     302                 :         172 :       tree fndecl, var, addr, tmp;
     303                 :             : 
     304                 :         172 :       if (expr->ts.kind == 1
     305                 :          59 :           && expr->value.function.actual->expr->ts.kind == 4)
     306                 :          59 :         fndecl = gfor_fndecl_convert_char4_to_char1;
     307                 :         113 :       else if (expr->ts.kind == 4
     308                 :         113 :                && expr->value.function.actual->expr->ts.kind == 1)
     309                 :         113 :         fndecl = gfor_fndecl_convert_char1_to_char4;
     310                 :             :       else
     311                 :           0 :         gcc_unreachable ();
     312                 :             : 
     313                 :             :       /* Create the variable storing the converted value.  */
     314                 :         172 :       type = gfc_get_pchar_type (expr->ts.kind);
     315                 :         172 :       var = gfc_create_var (type, "str");
     316                 :         172 :       addr = gfc_build_addr_expr (build_pointer_type (type), var);
     317                 :             : 
     318                 :             :       /* Call the library function that will perform the conversion.  */
     319                 :         172 :       gcc_assert (nargs >= 2);
     320                 :         172 :       tmp = build_call_expr_loc (input_location,
     321                 :             :                              fndecl, 3, addr, args[0], args[1]);
     322                 :         172 :       gfc_add_expr_to_block (&se->pre, tmp);
     323                 :             : 
     324                 :             :       /* Free the temporary afterwards.  */
     325                 :         172 :       tmp = gfc_call_free (var);
     326                 :         172 :       gfc_add_expr_to_block (&se->post, tmp);
     327                 :             : 
     328                 :         172 :       se->expr = var;
     329                 :         172 :       se->string_length = args[0];
     330                 :             : 
     331                 :         172 :       return;
     332                 :             :     }
     333                 :             : 
     334                 :             :   /* Conversion from complex to non-complex involves taking the real
     335                 :             :      component of the value.  */
     336                 :       29608 :   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
     337                 :       29608 :       && expr->ts.type != BT_COMPLEX)
     338                 :             :     {
     339                 :         581 :       tree artype;
     340                 :             : 
     341                 :         581 :       artype = TREE_TYPE (TREE_TYPE (args[0]));
     342                 :         581 :       args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
     343                 :             :                                  args[0]);
     344                 :             :     }
     345                 :             : 
     346                 :       29608 :   se->expr = convert (type, args[0]);
     347                 :             : }
     348                 :             : 
     349                 :             : /* This is needed because the gcc backend only implements
     350                 :             :    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
     351                 :             :    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
     352                 :             :    Similarly for CEILING.  */
     353                 :             : 
     354                 :             : static tree
     355                 :         132 : build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
     356                 :             : {
     357                 :         132 :   tree tmp;
     358                 :         132 :   tree cond;
     359                 :         132 :   tree argtype;
     360                 :         132 :   tree intval;
     361                 :             : 
     362                 :         132 :   argtype = TREE_TYPE (arg);
     363                 :         132 :   arg = gfc_evaluate_now (arg, pblock);
     364                 :             : 
     365                 :         132 :   intval = convert (type, arg);
     366                 :         132 :   intval = gfc_evaluate_now (intval, pblock);
     367                 :             : 
     368                 :         132 :   tmp = convert (argtype, intval);
     369                 :         248 :   cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
     370                 :             :                           logical_type_node, tmp, arg);
     371                 :             : 
     372                 :         248 :   tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
     373                 :         132 :                          intval, build_int_cst (type, 1));
     374                 :         132 :   tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
     375                 :         132 :   return tmp;
     376                 :             : }
     377                 :             : 
     378                 :             : 
     379                 :             : /* Round to nearest integer, away from zero.  */
     380                 :             : 
     381                 :             : static tree
     382                 :         149 : build_round_expr (tree arg, tree restype)
     383                 :             : {
     384                 :         149 :   tree argtype;
     385                 :         149 :   tree fn;
     386                 :         149 :   int argprec, resprec;
     387                 :             : 
     388                 :         149 :   argtype = TREE_TYPE (arg);
     389                 :         149 :   argprec = TYPE_PRECISION (argtype);
     390                 :         149 :   resprec = TYPE_PRECISION (restype);
     391                 :             : 
     392                 :             :   /* Depending on the type of the result, choose the int intrinsic (iround,
     393                 :             :      available only as a builtin, therefore cannot use it for _Float128), long
     394                 :             :      int intrinsic (lround family) or long long intrinsic (llround).  If we
     395                 :             :      don't have an appropriate function that converts directly to the integer
     396                 :             :      type (such as kind == 16), just use ROUND, and then convert the result to
     397                 :             :      an integer.  We might also need to convert the result afterwards.  */
     398                 :         274 :   if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
     399                 :         115 :     fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
     400                 :          38 :   else if (resprec <= LONG_TYPE_SIZE)
     401                 :          22 :     fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
     402                 :          12 :   else if (resprec <= LONG_LONG_TYPE_SIZE)
     403                 :           0 :     fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
     404                 :          12 :   else if (resprec >= argprec)
     405                 :          12 :     fn = builtin_decl_for_precision (BUILT_IN_ROUND, argprec);
     406                 :             :   else
     407                 :           0 :     gcc_unreachable ();
     408                 :             : 
     409                 :         149 :   return convert (restype, build_call_expr_loc (input_location,
     410                 :         149 :                                                 fn, 1, arg));
     411                 :             : }
     412                 :             : 
     413                 :             : 
     414                 :             : /* Convert a real to an integer using a specific rounding mode.
     415                 :             :    Ideally we would just build the corresponding GENERIC node,
     416                 :             :    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
     417                 :             : 
     418                 :             : static tree
     419                 :        1297 : build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
     420                 :             :                enum rounding_mode op)
     421                 :             : {
     422                 :        1297 :   switch (op)
     423                 :             :     {
     424                 :         116 :     case RND_FLOOR:
     425                 :         116 :       return build_fixbound_expr (pblock, arg, type, 0);
     426                 :             : 
     427                 :          16 :     case RND_CEIL:
     428                 :          16 :       return build_fixbound_expr (pblock, arg, type, 1);
     429                 :             : 
     430                 :         149 :     case RND_ROUND:
     431                 :         149 :       return build_round_expr (arg, type);
     432                 :             : 
     433                 :        1016 :     case RND_TRUNC:
     434                 :        1016 :       return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
     435                 :             : 
     436                 :           0 :     default:
     437                 :           0 :       gcc_unreachable ();
     438                 :             :     }
     439                 :             : }
     440                 :             : 
     441                 :             : 
     442                 :             : /* Round a real value using the specified rounding mode.
     443                 :             :    We use a temporary integer of that same kind size as the result.
     444                 :             :    Values larger than those that can be represented by this kind are
     445                 :             :    unchanged, as they will not be accurate enough to represent the
     446                 :             :    rounding.
     447                 :             :     huge = HUGE (KIND (a))
     448                 :             :     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
     449                 :             :    */
     450                 :             : 
     451                 :             : static void
     452                 :         220 : gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
     453                 :             : {
     454                 :         220 :   tree type;
     455                 :         220 :   tree itype;
     456                 :         220 :   tree arg[2];
     457                 :         220 :   tree tmp;
     458                 :         220 :   tree cond;
     459                 :         220 :   tree decl;
     460                 :         220 :   mpfr_t huge;
     461                 :         220 :   int n, nargs;
     462                 :         220 :   int kind;
     463                 :             : 
     464                 :         220 :   kind = expr->ts.kind;
     465                 :         220 :   nargs = gfc_intrinsic_argument_list_length (expr);
     466                 :             : 
     467                 :         220 :   decl = NULL_TREE;
     468                 :             :   /* We have builtin functions for some cases.  */
     469                 :         220 :   switch (op)
     470                 :             :     {
     471                 :          74 :     case RND_ROUND:
     472                 :          74 :       decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
     473                 :          74 :       break;
     474                 :             : 
     475                 :         146 :     case RND_TRUNC:
     476                 :         146 :       decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
     477                 :         146 :       break;
     478                 :             : 
     479                 :           0 :     default:
     480                 :           0 :       gcc_unreachable ();
     481                 :             :     }
     482                 :             : 
     483                 :             :   /* Evaluate the argument.  */
     484                 :         220 :   gcc_assert (expr->value.function.actual->expr);
     485                 :         220 :   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
     486                 :             : 
     487                 :             :   /* Use a builtin function if one exists.  */
     488                 :         220 :   if (decl != NULL_TREE)
     489                 :             :     {
     490                 :         220 :       se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
     491                 :         220 :       return;
     492                 :             :     }
     493                 :             : 
     494                 :             :   /* This code is probably redundant, but we'll keep it lying around just
     495                 :             :      in case.  */
     496                 :           0 :   type = gfc_typenode_for_spec (&expr->ts);
     497                 :           0 :   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
     498                 :             : 
     499                 :             :   /* Test if the value is too large to handle sensibly.  */
     500                 :           0 :   gfc_set_model_kind (kind);
     501                 :           0 :   mpfr_init (huge);
     502                 :           0 :   n = gfc_validate_kind (BT_INTEGER, kind, false);
     503                 :           0 :   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
     504                 :           0 :   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
     505                 :           0 :   cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, arg[0],
     506                 :             :                           tmp);
     507                 :             : 
     508                 :           0 :   mpfr_neg (huge, huge, GFC_RND_MODE);
     509                 :           0 :   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
     510                 :           0 :   tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, arg[0],
     511                 :             :                          tmp);
     512                 :           0 :   cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, logical_type_node,
     513                 :             :                           cond, tmp);
     514                 :           0 :   itype = gfc_get_int_type (kind);
     515                 :             : 
     516                 :           0 :   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
     517                 :           0 :   tmp = convert (type, tmp);
     518                 :           0 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
     519                 :             :                               arg[0]);
     520                 :           0 :   mpfr_clear (huge);
     521                 :             : }
     522                 :             : 
     523                 :             : 
     524                 :             : /* Convert to an integer using the specified rounding mode.  */
     525                 :             : 
     526                 :             : static void
     527                 :        2449 : gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
     528                 :             : {
     529                 :        2449 :   tree type;
     530                 :        2449 :   tree *args;
     531                 :        2449 :   int nargs;
     532                 :             : 
     533                 :        2449 :   nargs = gfc_intrinsic_argument_list_length (expr);
     534                 :        2449 :   args = XALLOCAVEC (tree, nargs);
     535                 :             : 
     536                 :             :   /* Evaluate the argument, we process all arguments even though we only
     537                 :             :      use the first one for code generation purposes.  */
     538                 :        2449 :   type = gfc_typenode_for_spec (&expr->ts);
     539                 :        2449 :   gcc_assert (expr->value.function.actual->expr);
     540                 :        2449 :   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
     541                 :             : 
     542                 :        2449 :   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
     543                 :             :     {
     544                 :             :       /* Conversion to a different integer kind.  */
     545                 :        1152 :       se->expr = convert (type, args[0]);
     546                 :             :     }
     547                 :             :   else
     548                 :             :     {
     549                 :             :       /* Conversion from complex to non-complex involves taking the real
     550                 :             :          component of the value.  */
     551                 :        1297 :       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
     552                 :        1297 :           && expr->ts.type != BT_COMPLEX)
     553                 :             :         {
     554                 :         186 :           tree artype;
     555                 :             : 
     556                 :         186 :           artype = TREE_TYPE (TREE_TYPE (args[0]));
     557                 :         186 :           args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
     558                 :             :                                      args[0]);
     559                 :             :         }
     560                 :             : 
     561                 :        1297 :       se->expr = build_fix_expr (&se->pre, args[0], type, op);
     562                 :             :     }
     563                 :        2449 : }
     564                 :             : 
     565                 :             : 
     566                 :             : /* Get the imaginary component of a value.  */
     567                 :             : 
     568                 :             : static void
     569                 :         426 : gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
     570                 :             : {
     571                 :         426 :   tree arg;
     572                 :             : 
     573                 :         426 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
     574                 :         426 :   se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
     575                 :         426 :                               TREE_TYPE (TREE_TYPE (arg)), arg);
     576                 :         426 : }
     577                 :             : 
     578                 :             : 
     579                 :             : /* Get the complex conjugate of a value.  */
     580                 :             : 
     581                 :             : static void
     582                 :         255 : gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
     583                 :             : {
     584                 :         255 :   tree arg;
     585                 :             : 
     586                 :         255 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
     587                 :         255 :   se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
     588                 :         255 : }
     589                 :             : 
     590                 :             : 
     591                 :             : 
     592                 :             : static tree
     593                 :      609042 : define_quad_builtin (const char *name, tree type, bool is_const)
     594                 :             : {
     595                 :      609042 :   tree fndecl;
     596                 :      609042 :   fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
     597                 :             :                        type);
     598                 :             : 
     599                 :             :   /* Mark the decl as external.  */
     600                 :      609042 :   DECL_EXTERNAL (fndecl) = 1;
     601                 :      609042 :   TREE_PUBLIC (fndecl) = 1;
     602                 :             : 
     603                 :             :   /* Mark it __attribute__((const)).  */
     604                 :      609042 :   TREE_READONLY (fndecl) = is_const;
     605                 :             : 
     606                 :      609042 :   rest_of_decl_compilation (fndecl, 1, 0);
     607                 :             : 
     608                 :      609042 :   return fndecl;
     609                 :             : }
     610                 :             : 
     611                 :             : /* Add SIMD attribute for FNDECL built-in if the built-in
     612                 :             :    name is in VECTORIZED_BUILTINS.  */
     613                 :             : 
     614                 :             : static void
     615                 :    34158280 : add_simd_flag_for_built_in (tree fndecl)
     616                 :             : {
     617                 :    34158280 :   if (gfc_vectorized_builtins == NULL
     618                 :    14723800 :       || fndecl == NULL_TREE)
     619                 :    27532570 :     return;
     620                 :             : 
     621                 :     6625710 :   const char *name = IDENTIFIER_POINTER (DECL_NAME (fndecl));
     622                 :     6625710 :   int *clauses = gfc_vectorized_builtins->get (name);
     623                 :     6625710 :   if (clauses)
     624                 :             :     {
     625                 :     4529800 :       for (unsigned i = 0; i < 3; i++)
     626                 :     3397350 :         if (*clauses & (1 << i))
     627                 :             :           {
     628                 :     1132455 :             gfc_simd_clause simd_type = (gfc_simd_clause)*clauses;
     629                 :     1132455 :             tree omp_clause = NULL_TREE;
     630                 :     1132455 :             if (simd_type == SIMD_NONE)
     631                 :             :               ; /* No SIMD clause.  */
     632                 :             :             else
     633                 :             :               {
     634                 :     2264910 :                 omp_clause_code code
     635                 :             :                   = (simd_type == SIMD_INBRANCH
     636                 :     1132455 :                      ? OMP_CLAUSE_INBRANCH : OMP_CLAUSE_NOTINBRANCH);
     637                 :     1132455 :                 omp_clause = build_omp_clause (UNKNOWN_LOCATION, code);
     638                 :     1132455 :                 omp_clause = build_tree_list (NULL_TREE, omp_clause);
     639                 :             :               }
     640                 :             : 
     641                 :     1132455 :             DECL_ATTRIBUTES (fndecl)
     642                 :     2264910 :               = tree_cons (get_identifier ("omp declare simd"), omp_clause,
     643                 :     1132455 :                            DECL_ATTRIBUTES (fndecl));
     644                 :             :           }
     645                 :             :     }
     646                 :             : }
     647                 :             : 
     648                 :             :   /* Set SIMD attribute to all built-in functions that are mentioned
     649                 :             :      in gfc_vectorized_builtins vector.  */
     650                 :             : 
     651                 :             : void
     652                 :       65689 : gfc_adjust_builtins (void)
     653                 :             : {
     654                 :       65689 :   gfc_intrinsic_map_t *m;
     655                 :     3481517 :   for (m = gfc_intrinsic_map;
     656                 :     3481517 :        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
     657                 :             :     {
     658                 :     3415828 :       add_simd_flag_for_built_in (m->real4_decl);
     659                 :     3415828 :       add_simd_flag_for_built_in (m->complex4_decl);
     660                 :     3415828 :       add_simd_flag_for_built_in (m->real8_decl);
     661                 :     3415828 :       add_simd_flag_for_built_in (m->complex8_decl);
     662                 :     3415828 :       add_simd_flag_for_built_in (m->real10_decl);
     663                 :     3415828 :       add_simd_flag_for_built_in (m->complex10_decl);
     664                 :     3415828 :       add_simd_flag_for_built_in (m->real16_decl);
     665                 :     3415828 :       add_simd_flag_for_built_in (m->complex16_decl);
     666                 :     3415828 :       add_simd_flag_for_built_in (m->real16_decl);
     667                 :     3415828 :       add_simd_flag_for_built_in (m->complex16_decl);
     668                 :             :     }
     669                 :             : 
     670                 :             :   /* Release all strings.  */
     671                 :       65689 :   if (gfc_vectorized_builtins != NULL)
     672                 :             :     {
     673                 :     1557119 :       for (hash_map<nofree_string_hash, int>::iterator it
     674                 :       28315 :            = gfc_vectorized_builtins->begin ();
     675                 :     1557119 :            it != gfc_vectorized_builtins->end (); ++it)
     676                 :     1528804 :         free (CONST_CAST (char *, (*it).first));
     677                 :             : 
     678                 :       56630 :       delete gfc_vectorized_builtins;
     679                 :       28315 :       gfc_vectorized_builtins = NULL;
     680                 :             :     }
     681                 :       65689 : }
     682                 :             : 
     683                 :             : /* Initialize function decls for library functions.  The external functions
     684                 :             :    are created as required.  Builtin functions are added here.  */
     685                 :             : 
     686                 :             : void
     687                 :       29002 : gfc_build_intrinsic_lib_fndecls (void)
     688                 :             : {
     689                 :       29002 :   gfc_intrinsic_map_t *m;
     690                 :       29002 :   tree quad_decls[END_BUILTINS + 1];
     691                 :             : 
     692                 :       29002 :   if (gfc_real16_is_float128)
     693                 :             :   {
     694                 :             :     /* If we have soft-float types, we create the decls for their
     695                 :             :        C99-like library functions.  For now, we only handle _Float128
     696                 :             :        q-suffixed or IEC 60559 f128-suffixed functions.  */
     697                 :             : 
     698                 :       29002 :     tree type, complex_type, func_1, func_2, func_3, func_cabs, func_frexp;
     699                 :       29002 :     tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
     700                 :             : 
     701                 :       29002 :     memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
     702                 :             : 
     703                 :       29002 :     type = gfc_float128_type_node;
     704                 :       29002 :     complex_type = gfc_complex_float128_type_node;
     705                 :             :     /* type (*) (type) */
     706                 :       29002 :     func_1 = build_function_type_list (type, type, NULL_TREE);
     707                 :             :     /* int (*) (type) */
     708                 :       29002 :     func_iround = build_function_type_list (integer_type_node,
     709                 :             :                                             type, NULL_TREE);
     710                 :             :     /* long (*) (type) */
     711                 :       29002 :     func_lround = build_function_type_list (long_integer_type_node,
     712                 :             :                                             type, NULL_TREE);
     713                 :             :     /* long long (*) (type) */
     714                 :       29002 :     func_llround = build_function_type_list (long_long_integer_type_node,
     715                 :             :                                              type, NULL_TREE);
     716                 :             :     /* type (*) (type, type) */
     717                 :       29002 :     func_2 = build_function_type_list (type, type, type, NULL_TREE);
     718                 :             :     /* type (*) (type, type, type) */
     719                 :       29002 :     func_3 = build_function_type_list (type, type, type, type, NULL_TREE);
     720                 :             :     /* type (*) (type, &int) */
     721                 :       29002 :     func_frexp
     722                 :       29002 :       = build_function_type_list (type,
     723                 :             :                                   type,
     724                 :             :                                   build_pointer_type (integer_type_node),
     725                 :             :                                   NULL_TREE);
     726                 :             :     /* type (*) (type, int) */
     727                 :       29002 :     func_scalbn = build_function_type_list (type,
     728                 :             :                                             type, integer_type_node, NULL_TREE);
     729                 :             :     /* type (*) (complex type) */
     730                 :       29002 :     func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
     731                 :             :     /* complex type (*) (complex type, complex type) */
     732                 :       29002 :     func_cpow
     733                 :       29002 :       = build_function_type_list (complex_type,
     734                 :             :                                   complex_type, complex_type, NULL_TREE);
     735                 :             : 
     736                 :             : #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
     737                 :             : #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
     738                 :             : #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
     739                 :             : 
     740                 :             :     /* Only these built-ins are actually needed here. These are used directly
     741                 :             :        from the code, when calling builtin_decl_for_precision() or
     742                 :             :        builtin_decl_for_float_type(). The others are all constructed by
     743                 :             :        gfc_get_intrinsic_lib_fndecl().  */
     744                 :             : #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
     745                 :             :     quad_decls[BUILT_IN_ ## ID]                                         \
     746                 :             :       = define_quad_builtin (gfc_real16_use_iec_60559                   \
     747                 :             :                              ? NAME "f128" : NAME "q", func_ ## TYPE,       \
     748                 :             :                              CONST);
     749                 :             : 
     750                 :             : #include "mathbuiltins.def"
     751                 :             : 
     752                 :             : #undef OTHER_BUILTIN
     753                 :             : #undef LIB_FUNCTION
     754                 :             : #undef DEFINE_MATH_BUILTIN
     755                 :             : #undef DEFINE_MATH_BUILTIN_C
     756                 :             : 
     757                 :             :     /* There is one built-in we defined manually, because it gets called
     758                 :             :        with builtin_decl_for_precision() or builtin_decl_for_float_type()
     759                 :             :        even though it is not an OTHER_BUILTIN: it is SQRT.  */
     760                 :       29002 :     quad_decls[BUILT_IN_SQRT]
     761                 :       29002 :       = define_quad_builtin (gfc_real16_use_iec_60559
     762                 :             :                              ? "sqrtf128" : "sqrtq", func_1, true);
     763                 :             :   }
     764                 :             : 
     765                 :             :   /* Add GCC builtin functions.  */
     766                 :     1508104 :   for (m = gfc_intrinsic_map;
     767                 :     1537106 :        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
     768                 :             :     {
     769                 :     1508104 :       if (m->float_built_in != END_BUILTINS)
     770                 :     1392096 :         m->real4_decl = builtin_decl_explicit (m->float_built_in);
     771                 :     1508104 :       if (m->complex_float_built_in != END_BUILTINS)
     772                 :      464032 :         m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
     773                 :     1508104 :       if (m->double_built_in != END_BUILTINS)
     774                 :     1392096 :         m->real8_decl = builtin_decl_explicit (m->double_built_in);
     775                 :     1508104 :       if (m->complex_double_built_in != END_BUILTINS)
     776                 :      464032 :         m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
     777                 :             : 
     778                 :             :       /* If real(kind=10) exists, it is always long double.  */
     779                 :     1508104 :       if (m->long_double_built_in != END_BUILTINS)
     780                 :     1392096 :         m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
     781                 :     1508104 :       if (m->complex_long_double_built_in != END_BUILTINS)
     782                 :      464032 :         m->complex10_decl
     783                 :      464032 :           = builtin_decl_explicit (m->complex_long_double_built_in);
     784                 :             : 
     785                 :     1508104 :       if (!gfc_real16_is_float128)
     786                 :             :         {
     787                 :           0 :           if (m->long_double_built_in != END_BUILTINS)
     788                 :           0 :             m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
     789                 :           0 :           if (m->complex_long_double_built_in != END_BUILTINS)
     790                 :           0 :             m->complex16_decl
     791                 :           0 :               = builtin_decl_explicit (m->complex_long_double_built_in);
     792                 :             :         }
     793                 :     1508104 :       else if (quad_decls[m->double_built_in] != NULL_TREE)
     794                 :             :         {
     795                 :             :           /* Quad-precision function calls are constructed when first
     796                 :             :              needed by builtin_decl_for_precision(), except for those
     797                 :             :              that will be used directly (define by OTHER_BUILTIN).  */
     798                 :      609042 :           m->real16_decl = quad_decls[m->double_built_in];
     799                 :             :         }
     800                 :      899062 :       else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
     801                 :             :         {
     802                 :             :           /* Same thing for the complex ones.  */
     803                 :           0 :           m->complex16_decl = quad_decls[m->double_built_in];
     804                 :             :         }
     805                 :             :     }
     806                 :       29002 : }
     807                 :             : 
     808                 :             : 
     809                 :             : /* Create a fndecl for a simple intrinsic library function.  */
     810                 :             : 
     811                 :             : static tree
     812                 :        4356 : gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
     813                 :             : {
     814                 :        4356 :   tree type;
     815                 :        4356 :   vec<tree, va_gc> *argtypes;
     816                 :        4356 :   tree fndecl;
     817                 :        4356 :   gfc_actual_arglist *actual;
     818                 :        4356 :   tree *pdecl;
     819                 :        4356 :   gfc_typespec *ts;
     820                 :        4356 :   char name[GFC_MAX_SYMBOL_LEN + 3];
     821                 :             : 
     822                 :        4356 :   ts = &expr->ts;
     823                 :        4356 :   if (ts->type == BT_REAL)
     824                 :             :     {
     825                 :        3512 :       switch (ts->kind)
     826                 :             :         {
     827                 :        1249 :         case 4:
     828                 :        1249 :           pdecl = &m->real4_decl;
     829                 :        1249 :           break;
     830                 :        1298 :         case 8:
     831                 :        1298 :           pdecl = &m->real8_decl;
     832                 :        1298 :           break;
     833                 :         548 :         case 10:
     834                 :         548 :           pdecl = &m->real10_decl;
     835                 :         548 :           break;
     836                 :         417 :         case 16:
     837                 :         417 :           pdecl = &m->real16_decl;
     838                 :         417 :           break;
     839                 :           0 :         default:
     840                 :           0 :           gcc_unreachable ();
     841                 :             :         }
     842                 :             :     }
     843                 :         844 :   else if (ts->type == BT_COMPLEX)
     844                 :             :     {
     845                 :         844 :       gcc_assert (m->complex_available);
     846                 :             : 
     847                 :         844 :       switch (ts->kind)
     848                 :             :         {
     849                 :         386 :         case 4:
     850                 :         386 :           pdecl = &m->complex4_decl;
     851                 :         386 :           break;
     852                 :         387 :         case 8:
     853                 :         387 :           pdecl = &m->complex8_decl;
     854                 :         387 :           break;
     855                 :          51 :         case 10:
     856                 :          51 :           pdecl = &m->complex10_decl;
     857                 :          51 :           break;
     858                 :          20 :         case 16:
     859                 :          20 :           pdecl = &m->complex16_decl;
     860                 :          20 :           break;
     861                 :           0 :         default:
     862                 :           0 :           gcc_unreachable ();
     863                 :             :         }
     864                 :             :     }
     865                 :             :   else
     866                 :           0 :     gcc_unreachable ();
     867                 :             : 
     868                 :        4356 :   if (*pdecl)
     869                 :             :     return *pdecl;
     870                 :             : 
     871                 :         338 :   if (m->libm_name)
     872                 :             :     {
     873                 :         161 :       int n = gfc_validate_kind (BT_REAL, ts->kind, false);
     874                 :         161 :       if (gfc_real_kinds[n].c_float)
     875                 :           0 :         snprintf (name, sizeof (name), "%s%s%s",
     876                 :           0 :                   ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
     877                 :         161 :       else if (gfc_real_kinds[n].c_double)
     878                 :           0 :         snprintf (name, sizeof (name), "%s%s",
     879                 :           0 :                   ts->type == BT_COMPLEX ? "c" : "", m->name);
     880                 :         161 :       else if (gfc_real_kinds[n].c_long_double)
     881                 :           0 :         snprintf (name, sizeof (name), "%s%s%s",
     882                 :           0 :                   ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
     883                 :         161 :       else if (gfc_real_kinds[n].c_float128)
     884                 :         161 :         snprintf (name, sizeof (name), "%s%s%s",
     885                 :         161 :                   ts->type == BT_COMPLEX ? "c" : "", m->name,
     886                 :         161 :                   gfc_real_kinds[n].use_iec_60559 ? "f128" : "q");
     887                 :             :       else
     888                 :           0 :         gcc_unreachable ();
     889                 :             :     }
     890                 :             :   else
     891                 :             :     {
     892                 :         354 :       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
     893                 :         177 :                 ts->type == BT_COMPLEX ? 'c' : 'r',
     894                 :             :                 gfc_type_abi_kind (ts));
     895                 :             :     }
     896                 :             : 
     897                 :         338 :   argtypes = NULL;
     898                 :         692 :   for (actual = expr->value.function.actual; actual; actual = actual->next)
     899                 :             :     {
     900                 :         354 :       type = gfc_typenode_for_spec (&actual->expr->ts);
     901                 :         354 :       vec_safe_push (argtypes, type);
     902                 :             :     }
     903                 :        1014 :   type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
     904                 :         338 :   fndecl = build_decl (input_location,
     905                 :             :                        FUNCTION_DECL, get_identifier (name), type);
     906                 :             : 
     907                 :             :   /* Mark the decl as external.  */
     908                 :         338 :   DECL_EXTERNAL (fndecl) = 1;
     909                 :         338 :   TREE_PUBLIC (fndecl) = 1;
     910                 :             : 
     911                 :             :   /* Mark it __attribute__((const)), if possible.  */
     912                 :         338 :   TREE_READONLY (fndecl) = m->is_constant;
     913                 :             : 
     914                 :         338 :   rest_of_decl_compilation (fndecl, 1, 0);
     915                 :             : 
     916                 :         338 :   (*pdecl) = fndecl;
     917                 :         338 :   return fndecl;
     918                 :             : }
     919                 :             : 
     920                 :             : 
     921                 :             : /* Convert an intrinsic function into an external or builtin call.  */
     922                 :             : 
     923                 :             : static void
     924                 :        3858 : gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
     925                 :             : {
     926                 :        3858 :   gfc_intrinsic_map_t *m;
     927                 :        3858 :   tree fndecl;
     928                 :        3858 :   tree rettype;
     929                 :        3858 :   tree *args;
     930                 :        3858 :   unsigned int num_args;
     931                 :        3858 :   gfc_isym_id id;
     932                 :             : 
     933                 :        3858 :   id = expr->value.function.isym->id;
     934                 :             :   /* Find the entry for this function.  */
     935                 :       55913 :   for (m = gfc_intrinsic_map;
     936                 :       55913 :        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
     937                 :             :     {
     938                 :       55913 :       if (id == m->id)
     939                 :             :         break;
     940                 :             :     }
     941                 :             : 
     942                 :        3858 :   if (m->id == GFC_ISYM_NONE)
     943                 :             :     {
     944                 :           0 :       gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
     945                 :             :                           expr->value.function.name, id);
     946                 :             :     }
     947                 :             : 
     948                 :             :   /* Get the decl and generate the call.  */
     949                 :        3858 :   num_args = gfc_intrinsic_argument_list_length (expr);
     950                 :        3858 :   args = XALLOCAVEC (tree, num_args);
     951                 :             : 
     952                 :        3858 :   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
     953                 :        3858 :   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
     954                 :        3858 :   rettype = TREE_TYPE (TREE_TYPE (fndecl));
     955                 :             : 
     956                 :        3858 :   fndecl = build_addr (fndecl);
     957                 :        3858 :   se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
     958                 :        3858 : }
     959                 :             : 
     960                 :             : 
     961                 :             : /* If bounds-checking is enabled, create code to verify at runtime that the
     962                 :             :    string lengths for both expressions are the same (needed for e.g. MERGE).
     963                 :             :    If bounds-checking is not enabled, does nothing.  */
     964                 :             : 
     965                 :             : void
     966                 :        1304 : gfc_trans_same_strlen_check (const char* intr_name, locus* where,
     967                 :             :                              tree a, tree b, stmtblock_t* target)
     968                 :             : {
     969                 :        1304 :   tree cond;
     970                 :        1304 :   tree name;
     971                 :             : 
     972                 :             :   /* If bounds-checking is disabled, do nothing.  */
     973                 :        1304 :   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
     974                 :             :     return;
     975                 :             : 
     976                 :             :   /* Compare the two string lengths.  */
     977                 :          37 :   cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, a, b);
     978                 :             : 
     979                 :             :   /* Output the runtime-check.  */
     980                 :          37 :   name = gfc_build_cstring_const (intr_name);
     981                 :          37 :   name = gfc_build_addr_expr (pchar_type_node, name);
     982                 :          37 :   gfc_trans_runtime_check (true, false, cond, target, where,
     983                 :             :                            "Unequal character lengths (%ld/%ld) in %s",
     984                 :             :                            fold_convert (long_integer_type_node, a),
     985                 :             :                            fold_convert (long_integer_type_node, b), name);
     986                 :             : }
     987                 :             : 
     988                 :             : 
     989                 :             : /* The EXPONENT(X) intrinsic function is translated into
     990                 :             :        int ret;
     991                 :             :        return isfinite(X) ? (frexp (X, &ret) , ret) : huge
     992                 :             :    so that if X is a NaN or infinity, the result is HUGE(0).
     993                 :             :  */
     994                 :             : 
     995                 :             : static void
     996                 :         228 : gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
     997                 :             : {
     998                 :         228 :   tree arg, type, res, tmp, frexp, cond, huge;
     999                 :         228 :   int i;
    1000                 :             : 
    1001                 :         456 :   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
    1002                 :         228 :                                        expr->value.function.actual->expr->ts.kind);
    1003                 :             : 
    1004                 :         228 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    1005                 :         228 :   arg = gfc_evaluate_now (arg, &se->pre);
    1006                 :             : 
    1007                 :         228 :   i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
    1008                 :         228 :   huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
    1009                 :         228 :   cond = build_call_expr_loc (input_location,
    1010                 :             :                               builtin_decl_explicit (BUILT_IN_ISFINITE),
    1011                 :             :                               1, arg);
    1012                 :             : 
    1013                 :         228 :   res = gfc_create_var (integer_type_node, NULL);
    1014                 :         228 :   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
    1015                 :             :                              gfc_build_addr_expr (NULL_TREE, res));
    1016                 :         228 :   tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
    1017                 :             :                          tmp, res);
    1018                 :         228 :   se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
    1019                 :             :                               cond, tmp, huge);
    1020                 :             : 
    1021                 :         228 :   type = gfc_typenode_for_spec (&expr->ts);
    1022                 :         228 :   se->expr = fold_convert (type, se->expr);
    1023                 :         228 : }
    1024                 :             : 
    1025                 :             : 
    1026                 :             : /* Fill in the following structure
    1027                 :             :      struct caf_vector_t {
    1028                 :             :        size_t nvec;  // size of the vector
    1029                 :             :        union {
    1030                 :             :          struct {
    1031                 :             :            void *vector;
    1032                 :             :            int kind;
    1033                 :             :          } v;
    1034                 :             :          struct {
    1035                 :             :            ptrdiff_t lower_bound;
    1036                 :             :            ptrdiff_t upper_bound;
    1037                 :             :            ptrdiff_t stride;
    1038                 :             :          } triplet;
    1039                 :             :        } u;
    1040                 :             :      }  */
    1041                 :             : 
    1042                 :             : static void
    1043                 :           0 : conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
    1044                 :             :                                 tree lower, tree upper, tree stride,
    1045                 :             :                                 tree vector, int kind, tree nvec)
    1046                 :             : {
    1047                 :           0 :   tree field, type, tmp;
    1048                 :             : 
    1049                 :           0 :   desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
    1050                 :           0 :   type = TREE_TYPE (desc);
    1051                 :             : 
    1052                 :           0 :   field = gfc_advance_chain (TYPE_FIELDS (type), 0);
    1053                 :           0 :   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1054                 :             :                          desc, field, NULL_TREE);
    1055                 :           0 :   gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
    1056                 :             : 
    1057                 :             :   /* Access union.  */
    1058                 :           0 :   field = gfc_advance_chain (TYPE_FIELDS (type), 1);
    1059                 :           0 :   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1060                 :             :                           desc, field, NULL_TREE);
    1061                 :           0 :   type = TREE_TYPE (desc);
    1062                 :             : 
    1063                 :             :   /* Access the inner struct.  */
    1064                 :           0 :   field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
    1065                 :           0 :   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1066                 :             :                       desc, field, NULL_TREE);
    1067                 :           0 :   type = TREE_TYPE (desc);
    1068                 :             : 
    1069                 :           0 :   if (vector != NULL_TREE)
    1070                 :             :     {
    1071                 :             :       /* Set vector and kind.  */
    1072                 :           0 :       field = gfc_advance_chain (TYPE_FIELDS (type), 0);
    1073                 :           0 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1074                 :             :                          desc, field, NULL_TREE);
    1075                 :           0 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
    1076                 :           0 :       field = gfc_advance_chain (TYPE_FIELDS (type), 1);
    1077                 :           0 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1078                 :             :                          desc, field, NULL_TREE);
    1079                 :           0 :       gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
    1080                 :             :     }
    1081                 :             :   else
    1082                 :             :     {
    1083                 :             :       /* Set dim.lower/upper/stride.  */
    1084                 :           0 :       field = gfc_advance_chain (TYPE_FIELDS (type), 0);
    1085                 :           0 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1086                 :             :                              desc, field, NULL_TREE);
    1087                 :           0 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
    1088                 :             : 
    1089                 :           0 :       field = gfc_advance_chain (TYPE_FIELDS (type), 1);
    1090                 :           0 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1091                 :             :                              desc, field, NULL_TREE);
    1092                 :           0 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
    1093                 :             : 
    1094                 :           0 :       field = gfc_advance_chain (TYPE_FIELDS (type), 2);
    1095                 :           0 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1096                 :             :                              desc, field, NULL_TREE);
    1097                 :           0 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
    1098                 :             :     }
    1099                 :           0 : }
    1100                 :             : 
    1101                 :             : 
    1102                 :             : static tree
    1103                 :           0 : conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
    1104                 :             : {
    1105                 :           0 :   gfc_se argse;
    1106                 :           0 :   tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
    1107                 :           0 :   tree lbound, ubound, tmp;
    1108                 :           0 :   int i;
    1109                 :             : 
    1110                 :           0 :   var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
    1111                 :             : 
    1112                 :           0 :   for (i = 0; i < ar->dimen; i++)
    1113                 :           0 :     switch (ar->dimen_type[i])
    1114                 :             :       {
    1115                 :           0 :       case DIMEN_RANGE:
    1116                 :           0 :         if (ar->end[i])
    1117                 :             :           {
    1118                 :           0 :             gfc_init_se (&argse, NULL);
    1119                 :           0 :             gfc_conv_expr (&argse, ar->end[i]);
    1120                 :           0 :             gfc_add_block_to_block (block, &argse.pre);
    1121                 :           0 :             upper = gfc_evaluate_now (argse.expr, block);
    1122                 :             :           }
    1123                 :             :         else
    1124                 :           0 :           upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
    1125                 :           0 :         if (ar->stride[i])
    1126                 :             :           {
    1127                 :           0 :             gfc_init_se (&argse, NULL);
    1128                 :           0 :             gfc_conv_expr (&argse, ar->stride[i]);
    1129                 :           0 :             gfc_add_block_to_block (block, &argse.pre);
    1130                 :           0 :             stride = gfc_evaluate_now (argse.expr, block);
    1131                 :             :           }
    1132                 :             :         else
    1133                 :           0 :           stride = gfc_index_one_node;
    1134                 :             : 
    1135                 :             :         /* Fall through.  */
    1136                 :           0 :       case DIMEN_ELEMENT:
    1137                 :           0 :         if (ar->start[i])
    1138                 :             :           {
    1139                 :           0 :             gfc_init_se (&argse, NULL);
    1140                 :           0 :             gfc_conv_expr (&argse, ar->start[i]);
    1141                 :           0 :             gfc_add_block_to_block (block, &argse.pre);
    1142                 :           0 :             lower = gfc_evaluate_now (argse.expr, block);
    1143                 :             :           }
    1144                 :             :         else
    1145                 :           0 :           lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
    1146                 :           0 :         if (ar->dimen_type[i] == DIMEN_ELEMENT)
    1147                 :             :           {
    1148                 :           0 :             upper = lower;
    1149                 :           0 :             stride = gfc_index_one_node;
    1150                 :             :           }
    1151                 :           0 :         vector = NULL_TREE;
    1152                 :           0 :         nvec = size_zero_node;
    1153                 :           0 :         conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
    1154                 :             :                                         vector, 0, nvec);
    1155                 :           0 :         break;
    1156                 :             : 
    1157                 :           0 :       case DIMEN_VECTOR:
    1158                 :           0 :         gfc_init_se (&argse, NULL);
    1159                 :           0 :         argse.descriptor_only = 1;
    1160                 :           0 :         gfc_conv_expr_descriptor (&argse, ar->start[i]);
    1161                 :           0 :         gfc_add_block_to_block (block, &argse.pre);
    1162                 :           0 :         vector = argse.expr;
    1163                 :           0 :         lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
    1164                 :           0 :         ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
    1165                 :           0 :         nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
    1166                 :           0 :         tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
    1167                 :           0 :         nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    1168                 :           0 :                                 TREE_TYPE (nvec), nvec, tmp);
    1169                 :           0 :         lower = gfc_index_zero_node;
    1170                 :           0 :         upper = gfc_index_zero_node;
    1171                 :           0 :         stride = gfc_index_zero_node;
    1172                 :           0 :         vector = gfc_conv_descriptor_data_get (vector);
    1173                 :           0 :         conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
    1174                 :           0 :                                         vector, ar->start[i]->ts.kind, nvec);
    1175                 :           0 :         break;
    1176                 :           0 :       default:
    1177                 :           0 :         gcc_unreachable();
    1178                 :             :     }
    1179                 :           0 :   return gfc_build_addr_expr (NULL_TREE, var);
    1180                 :             : }
    1181                 :             : 
    1182                 :             : 
    1183                 :             : static tree
    1184                 :        1846 : compute_component_offset (tree field, tree type)
    1185                 :             : {
    1186                 :        1846 :   tree tmp;
    1187                 :        1846 :   if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
    1188                 :        1846 :       && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
    1189                 :             :     {
    1190                 :        1106 :       tmp = fold_build2 (TRUNC_DIV_EXPR, type,
    1191                 :             :                          DECL_FIELD_BIT_OFFSET (field),
    1192                 :             :                          bitsize_unit_node);
    1193                 :        1106 :       return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
    1194                 :             :     }
    1195                 :             :   else
    1196                 :         740 :     return DECL_FIELD_OFFSET (field);
    1197                 :             : }
    1198                 :             : 
    1199                 :             : 
    1200                 :             : static tree
    1201                 :         749 : conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
    1202                 :             : {
    1203                 :         749 :   gfc_ref *ref = expr->ref, *last_comp_ref;
    1204                 :         749 :   tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
    1205                 :             :       field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
    1206                 :             :       start, end, stride, vector, nvec;
    1207                 :         749 :   gfc_se se;
    1208                 :         749 :   bool ref_static_array = false;
    1209                 :         749 :   tree last_component_ref_tree = NULL_TREE;
    1210                 :         749 :   int i, last_type_n;
    1211                 :             : 
    1212                 :         749 :   if (expr->symtree)
    1213                 :             :     {
    1214                 :         749 :       last_component_ref_tree = expr->symtree->n.sym->backend_decl;
    1215                 :         749 :       ref_static_array = !expr->symtree->n.sym->attr.allocatable
    1216                 :         749 :           && !expr->symtree->n.sym->attr.pointer;
    1217                 :             :     }
    1218                 :             : 
    1219                 :             :   /* Prevent uninit-warning.  */
    1220                 :         749 :   reference_type = NULL_TREE;
    1221                 :             : 
    1222                 :             :   /* Skip refs upto the first coarray-ref.  */
    1223                 :         749 :   last_comp_ref = NULL;
    1224                 :         761 :   while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
    1225                 :             :     {
    1226                 :             :       /* Remember the type of components skipped.  */
    1227                 :          12 :       if (ref->type == REF_COMPONENT)
    1228                 :          12 :         last_comp_ref = ref;
    1229                 :          12 :       ref = ref->next;
    1230                 :             :     }
    1231                 :             :   /* When a component was skipped, get the type information of the last
    1232                 :             :      component ref, else get the type from the symbol.  */
    1233                 :         749 :   if (last_comp_ref)
    1234                 :             :     {
    1235                 :          12 :       last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
    1236                 :          12 :       last_type_n = last_comp_ref->u.c.component->ts.type;
    1237                 :             :     }
    1238                 :             :   else
    1239                 :             :     {
    1240                 :         737 :       last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
    1241                 :         737 :       last_type_n = expr->symtree->n.sym->ts.type;
    1242                 :             :     }
    1243                 :             : 
    1244                 :        3236 :   while (ref)
    1245                 :             :     {
    1246                 :        2487 :       if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
    1247                 :         749 :           && ref->u.ar.dimen == 0)
    1248                 :             :         {
    1249                 :             :           /* Skip pure coindexes.  */
    1250                 :         746 :           ref = ref->next;
    1251                 :         746 :           continue;
    1252                 :             :         }
    1253                 :        1741 :       tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
    1254                 :        1741 :       reference_type = TREE_TYPE (tmp);
    1255                 :             : 
    1256                 :        1741 :       if (caf_ref == NULL_TREE)
    1257                 :         749 :         caf_ref = tmp;
    1258                 :             : 
    1259                 :             :       /* Construct the chain of refs.  */
    1260                 :        1741 :       if (prev_caf_ref != NULL_TREE)
    1261                 :             :         {
    1262                 :         992 :           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
    1263                 :         992 :           tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1264                 :         992 :                                   TREE_TYPE (field), prev_caf_ref, field,
    1265                 :             :                                   NULL_TREE);
    1266                 :         992 :           gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
    1267                 :             :                                                             tmp));
    1268                 :             :         }
    1269                 :        1741 :       prev_caf_ref = tmp;
    1270                 :             : 
    1271                 :        1741 :       switch (ref->type)
    1272                 :             :         {
    1273                 :        1076 :         case REF_COMPONENT:
    1274                 :        1076 :           last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
    1275                 :        1076 :           last_type_n = ref->u.c.component->ts.type;
    1276                 :             :           /* Set the type of the ref.  */
    1277                 :        1076 :           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
    1278                 :        1076 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1279                 :        1076 :                                  TREE_TYPE (field), prev_caf_ref, field,
    1280                 :             :                                  NULL_TREE);
    1281                 :        1076 :           gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
    1282                 :        1076 :                                                      GFC_CAF_REF_COMPONENT));
    1283                 :             : 
    1284                 :             :           /* Ref the c in union u.  */
    1285                 :        1076 :           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
    1286                 :        1076 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1287                 :        1076 :                                  TREE_TYPE (field), prev_caf_ref, field,
    1288                 :             :                                  NULL_TREE);
    1289                 :        1076 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
    1290                 :        1076 :           inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
    1291                 :        1076 :                                        TREE_TYPE (field), tmp, field,
    1292                 :             :                                        NULL_TREE);
    1293                 :             : 
    1294                 :             :           /* Set the offset.  */
    1295                 :        1076 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
    1296                 :        1076 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1297                 :        1076 :                                  TREE_TYPE (field), inner_struct, field,
    1298                 :             :                                  NULL_TREE);
    1299                 :             :           /* Computing the offset is somewhat harder.  The bit_offset has to be
    1300                 :             :              taken into account.  When the bit_offset in the field_decl is non-
    1301                 :             :              null, divide it by the bitsize_unit and add it to the regular
    1302                 :             :              offset.  */
    1303                 :        1076 :           tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
    1304                 :        1076 :                                            TREE_TYPE (tmp));
    1305                 :        1076 :           gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
    1306                 :             : 
    1307                 :             :           /* Set caf_token_offset.  */
    1308                 :        1076 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
    1309                 :        1076 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1310                 :        1076 :                                  TREE_TYPE (field), inner_struct, field,
    1311                 :             :                                  NULL_TREE);
    1312                 :        1076 :           if ((ref->u.c.component->attr.allocatable
    1313                 :        1076 :                || ref->u.c.component->attr.pointer)
    1314                 :         770 :               && ref->u.c.component->attr.dimension)
    1315                 :             :             {
    1316                 :         464 :               tree arr_desc_token_offset;
    1317                 :             :               /* Get the token field from the descriptor.  */
    1318                 :         464 :               arr_desc_token_offset = TREE_OPERAND (
    1319                 :             :                     gfc_conv_descriptor_token (ref->u.c.component->backend_decl), 1);
    1320                 :         464 :               arr_desc_token_offset
    1321                 :         464 :                   = compute_component_offset (arr_desc_token_offset,
    1322                 :         464 :                                               TREE_TYPE (tmp));
    1323                 :         464 :               tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
    1324                 :         464 :                                       TREE_TYPE (tmp2), tmp2,
    1325                 :             :                                       arr_desc_token_offset);
    1326                 :         464 :             }
    1327                 :         612 :           else if (ref->u.c.component->caf_token)
    1328                 :         306 :             tmp2 = compute_component_offset (ref->u.c.component->caf_token,
    1329                 :         306 :                                              TREE_TYPE (tmp));
    1330                 :             :           else
    1331                 :         306 :             tmp2 = integer_zero_node;
    1332                 :        1076 :           gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
    1333                 :             : 
    1334                 :             :           /* Remember whether this ref was to a non-allocatable/non-pointer
    1335                 :             :              component so the next array ref can be tailored correctly.  */
    1336                 :        1076 :           ref_static_array = !ref->u.c.component->attr.allocatable
    1337                 :        1076 :               && !ref->u.c.component->attr.pointer;
    1338                 :        1076 :           last_component_ref_tree = ref_static_array
    1339                 :        1076 :               ? ref->u.c.component->backend_decl : NULL_TREE;
    1340                 :             :           break;
    1341                 :         665 :         case REF_ARRAY:
    1342                 :         665 :           if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
    1343                 :         467 :             ref_static_array = false;
    1344                 :             :           /* Set the type of the ref.  */
    1345                 :         665 :           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
    1346                 :         665 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1347                 :         665 :                                  TREE_TYPE (field), prev_caf_ref, field,
    1348                 :             :                                  NULL_TREE);
    1349                 :         665 :           gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
    1350                 :             :                                                      ref_static_array
    1351                 :        1132 :                                                      ? GFC_CAF_REF_STATIC_ARRAY
    1352                 :             :                                                      : GFC_CAF_REF_ARRAY));
    1353                 :             : 
    1354                 :             :           /* Ref the a in union u.  */
    1355                 :         665 :           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
    1356                 :         665 :           tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1357                 :         665 :                                  TREE_TYPE (field), prev_caf_ref, field,
    1358                 :             :                                  NULL_TREE);
    1359                 :         665 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
    1360                 :         665 :           inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
    1361                 :         665 :                                        TREE_TYPE (field), tmp, field,
    1362                 :             :                                        NULL_TREE);
    1363                 :             : 
    1364                 :             :           /* Set the static_array_type in a for static arrays.  */
    1365                 :         665 :           if (ref_static_array)
    1366                 :             :             {
    1367                 :         198 :               field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
    1368                 :             :                                          1);
    1369                 :         198 :               tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1370                 :         198 :                                      TREE_TYPE (field), inner_struct, field,
    1371                 :             :                                      NULL_TREE);
    1372                 :         198 :               gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
    1373                 :             :                                                          last_type_n));
    1374                 :             :             }
    1375                 :             :           /* Ref the mode in the inner_struct.  */
    1376                 :         665 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
    1377                 :         665 :           mode = fold_build3_loc (input_location, COMPONENT_REF,
    1378                 :         665 :                                   TREE_TYPE (field), inner_struct, field,
    1379                 :             :                                   NULL_TREE);
    1380                 :             :           /* Ref the dim in the inner_struct.  */
    1381                 :         665 :           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
    1382                 :        1330 :           dim_array = fold_build3_loc (input_location, COMPONENT_REF,
    1383                 :         665 :                                        TREE_TYPE (field), inner_struct, field,
    1384                 :             :                                        NULL_TREE);
    1385                 :        2398 :           for (i = 0; i < ref->u.ar.dimen; ++i)
    1386                 :             :             {
    1387                 :             :               /* Ref dim i.  */
    1388                 :        1068 :               dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
    1389                 :        1068 :               dim_type = TREE_TYPE (dim);
    1390                 :        1068 :               mode_rhs = start = end = stride = NULL_TREE;
    1391                 :        1068 :               switch (ref->u.ar.dimen_type[i])
    1392                 :             :                 {
    1393                 :         810 :                 case DIMEN_RANGE:
    1394                 :         810 :                   if (ref->u.ar.end[i])
    1395                 :             :                     {
    1396                 :          92 :                       gfc_init_se (&se, NULL);
    1397                 :          92 :                       gfc_conv_expr (&se, ref->u.ar.end[i]);
    1398                 :          92 :                       gfc_add_block_to_block (block, &se.pre);
    1399                 :          92 :                       if (ref_static_array)
    1400                 :             :                         {
    1401                 :             :                           /* Make the index zero-based, when reffing a static
    1402                 :             :                              array.  */
    1403                 :          42 :                           end = se.expr;
    1404                 :          42 :                           gfc_init_se (&se, NULL);
    1405                 :          42 :                           gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
    1406                 :          42 :                           gfc_add_block_to_block (block, &se.pre);
    1407                 :          42 :                           se.expr = fold_build2 (MINUS_EXPR,
    1408                 :             :                                                  gfc_array_index_type,
    1409                 :             :                                                  end, fold_convert (
    1410                 :             :                                                    gfc_array_index_type,
    1411                 :             :                                                    se.expr));
    1412                 :             :                         }
    1413                 :          92 :                       end = gfc_evaluate_now (fold_convert (
    1414                 :             :                                                 gfc_array_index_type,
    1415                 :             :                                                 se.expr),
    1416                 :             :                                               block);
    1417                 :             :                     }
    1418                 :         718 :                   else if (ref_static_array)
    1419                 :         324 :                     end = fold_build2 (MINUS_EXPR,
    1420                 :             :                                        gfc_array_index_type,
    1421                 :             :                                        gfc_conv_array_ubound (
    1422                 :             :                                          last_component_ref_tree, i),
    1423                 :             :                                        gfc_conv_array_lbound (
    1424                 :             :                                          last_component_ref_tree, i));
    1425                 :             :                   else
    1426                 :             :                     {
    1427                 :         394 :                       end = NULL_TREE;
    1428                 :         394 :                       mode_rhs = build_int_cst (unsigned_char_type_node,
    1429                 :         394 :                                                 GFC_CAF_ARR_REF_OPEN_END);
    1430                 :             :                     }
    1431                 :         810 :                   if (ref->u.ar.stride[i])
    1432                 :             :                     {
    1433                 :          96 :                       gfc_init_se (&se, NULL);
    1434                 :          96 :                       gfc_conv_expr (&se, ref->u.ar.stride[i]);
    1435                 :          96 :                       gfc_add_block_to_block (block, &se.pre);
    1436                 :          96 :                       stride = gfc_evaluate_now (fold_convert (
    1437                 :             :                                                    gfc_array_index_type,
    1438                 :             :                                                    se.expr),
    1439                 :             :                                                  block);
    1440                 :          96 :                       if (ref_static_array)
    1441                 :             :                         {
    1442                 :             :                           /* Make the index zero-based, when reffing a static
    1443                 :             :                              array.  */
    1444                 :          24 :                           stride = fold_build2 (MULT_EXPR,
    1445                 :             :                                                 gfc_array_index_type,
    1446                 :             :                                                 gfc_conv_array_stride (
    1447                 :             :                                                   last_component_ref_tree,
    1448                 :             :                                                   i),
    1449                 :             :                                                 stride);
    1450                 :          24 :                           gcc_assert (end != NULL_TREE);
    1451                 :             :                           /* Multiply with the product of array's stride and
    1452                 :             :                              the step of the ref to a virtual upper bound.
    1453                 :             :                              We cannot compute the actual upper bound here or
    1454                 :             :                              the caflib would compute the extend
    1455                 :             :                              incorrectly.  */
    1456                 :          24 :                           end = fold_build2 (MULT_EXPR, gfc_array_index_type,
    1457                 :             :                                              end, gfc_conv_array_stride (
    1458                 :             :                                                last_component_ref_tree,
    1459                 :             :                                                i));
    1460                 :          24 :                           end = gfc_evaluate_now (end, block);
    1461                 :          24 :                           stride = gfc_evaluate_now (stride, block);
    1462                 :             :                         }
    1463                 :             :                     }
    1464                 :         714 :                   else if (ref_static_array)
    1465                 :             :                     {
    1466                 :         342 :                       stride = gfc_conv_array_stride (last_component_ref_tree,
    1467                 :             :                                                       i);
    1468                 :         342 :                       end = fold_build2 (MULT_EXPR, gfc_array_index_type,
    1469                 :             :                                          end, stride);
    1470                 :         342 :                       end = gfc_evaluate_now (end, block);
    1471                 :             :                     }
    1472                 :             :                   else
    1473                 :             :                     /* Always set a ref stride of one to make caflib's
    1474                 :             :                        handling easier.  */
    1475                 :         372 :                     stride = gfc_index_one_node;
    1476                 :             : 
    1477                 :             :                   /* Fall through.  */
    1478                 :        1044 :                 case DIMEN_ELEMENT:
    1479                 :        1044 :                   if (ref->u.ar.start[i])
    1480                 :             :                     {
    1481                 :         302 :                       gfc_init_se (&se, NULL);
    1482                 :         302 :                       gfc_conv_expr (&se, ref->u.ar.start[i]);
    1483                 :         302 :                       gfc_add_block_to_block (block, &se.pre);
    1484                 :         302 :                       if (ref_static_array)
    1485                 :             :                         {
    1486                 :             :                           /* Make the index zero-based, when reffing a static
    1487                 :             :                              array.  */
    1488                 :          18 :                           start = fold_convert (gfc_array_index_type, se.expr);
    1489                 :          18 :                           gfc_init_se (&se, NULL);
    1490                 :          18 :                           gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
    1491                 :          18 :                           gfc_add_block_to_block (block, &se.pre);
    1492                 :          18 :                           se.expr = fold_build2 (MINUS_EXPR,
    1493                 :             :                                                  gfc_array_index_type,
    1494                 :             :                                                  start, fold_convert (
    1495                 :             :                                                    gfc_array_index_type,
    1496                 :             :                                                    se.expr));
    1497                 :             :                           /* Multiply with the stride.  */
    1498                 :          18 :                           se.expr = fold_build2 (MULT_EXPR,
    1499                 :             :                                                  gfc_array_index_type,
    1500                 :             :                                                  se.expr,
    1501                 :             :                                                  gfc_conv_array_stride (
    1502                 :             :                                                    last_component_ref_tree,
    1503                 :             :                                                    i));
    1504                 :             :                         }
    1505                 :         302 :                       start = gfc_evaluate_now (fold_convert (
    1506                 :             :                                                   gfc_array_index_type,
    1507                 :             :                                                   se.expr),
    1508                 :             :                                                 block);
    1509                 :         302 :                       if (mode_rhs == NULL_TREE)
    1510                 :         290 :                         mode_rhs = build_int_cst (unsigned_char_type_node,
    1511                 :         290 :                                                   ref->u.ar.dimen_type[i]
    1512                 :             :                                                   == DIMEN_ELEMENT
    1513                 :         346 :                                                   ? GFC_CAF_ARR_REF_SINGLE
    1514                 :             :                                                   : GFC_CAF_ARR_REF_RANGE);
    1515                 :             :                     }
    1516                 :         742 :                   else if (ref_static_array)
    1517                 :             :                     {
    1518                 :         348 :                       start = integer_zero_node;
    1519                 :         348 :                       mode_rhs = build_int_cst (unsigned_char_type_node,
    1520                 :             :                                                 ref->u.ar.start[i] == NULL
    1521                 :         348 :                                                 ? GFC_CAF_ARR_REF_FULL
    1522                 :             :                                                 : GFC_CAF_ARR_REF_RANGE);
    1523                 :             :                     }
    1524                 :         394 :                   else if (end == NULL_TREE)
    1525                 :         382 :                     mode_rhs = build_int_cst (unsigned_char_type_node,
    1526                 :         382 :                                               GFC_CAF_ARR_REF_FULL);
    1527                 :             :                   else
    1528                 :          12 :                     mode_rhs = build_int_cst (unsigned_char_type_node,
    1529                 :          12 :                                               GFC_CAF_ARR_REF_OPEN_START);
    1530                 :             : 
    1531                 :             :                   /* Ref the s in dim.  */
    1532                 :        1044 :                   field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
    1533                 :        1044 :                   tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1534                 :        1044 :                                          TREE_TYPE (field), dim, field,
    1535                 :             :                                          NULL_TREE);
    1536                 :             : 
    1537                 :             :                   /* Set start in s.  */
    1538                 :        1044 :                   if (start != NULL_TREE)
    1539                 :             :                     {
    1540                 :         650 :                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
    1541                 :             :                                                  0);
    1542                 :         650 :                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1543                 :         650 :                                               TREE_TYPE (field), tmp, field,
    1544                 :             :                                               NULL_TREE);
    1545                 :         650 :                       gfc_add_modify (block, tmp2,
    1546                 :         650 :                                       fold_convert (TREE_TYPE (tmp2), start));
    1547                 :             :                     }
    1548                 :             : 
    1549                 :             :                   /* Set end in s.  */
    1550                 :        1044 :                   if (end != NULL_TREE)
    1551                 :             :                     {
    1552                 :         416 :                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
    1553                 :             :                                                  1);
    1554                 :         416 :                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1555                 :         416 :                                               TREE_TYPE (field), tmp, field,
    1556                 :             :                                               NULL_TREE);
    1557                 :         416 :                       gfc_add_modify (block, tmp2,
    1558                 :         416 :                                       fold_convert (TREE_TYPE (tmp2), end));
    1559                 :             :                     }
    1560                 :             : 
    1561                 :             :                   /* Set end in s.  */
    1562                 :        1044 :                   if (stride != NULL_TREE)
    1563                 :             :                     {
    1564                 :         810 :                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
    1565                 :             :                                                  2);
    1566                 :         810 :                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1567                 :         810 :                                               TREE_TYPE (field), tmp, field,
    1568                 :             :                                               NULL_TREE);
    1569                 :         810 :                       gfc_add_modify (block, tmp2,
    1570                 :         810 :                                       fold_convert (TREE_TYPE (tmp2), stride));
    1571                 :             :                     }
    1572                 :             :                   break;
    1573                 :          24 :                 case DIMEN_VECTOR:
    1574                 :             :                   /* TODO: In case of static array.  */
    1575                 :          24 :                   gcc_assert (!ref_static_array);
    1576                 :          48 :                   mode_rhs = build_int_cst (unsigned_char_type_node,
    1577                 :          24 :                                             GFC_CAF_ARR_REF_VECTOR);
    1578                 :          24 :                   gfc_init_se (&se, NULL);
    1579                 :          24 :                   se.descriptor_only = 1;
    1580                 :          24 :                   gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
    1581                 :          24 :                   gfc_add_block_to_block (block, &se.pre);
    1582                 :          24 :                   vector = se.expr;
    1583                 :          24 :                   tmp = gfc_conv_descriptor_lbound_get (vector,
    1584                 :             :                                                         gfc_rank_cst[0]);
    1585                 :          24 :                   tmp2 = gfc_conv_descriptor_ubound_get (vector,
    1586                 :             :                                                          gfc_rank_cst[0]);
    1587                 :          24 :                   nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
    1588                 :          24 :                   tmp = gfc_conv_descriptor_stride_get (vector,
    1589                 :             :                                                         gfc_rank_cst[0]);
    1590                 :          24 :                   nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    1591                 :          24 :                                           TREE_TYPE (nvec), nvec, tmp);
    1592                 :          24 :                   vector = gfc_conv_descriptor_data_get (vector);
    1593                 :             : 
    1594                 :             :                   /* Ref the v in dim.  */
    1595                 :          24 :                   field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
    1596                 :          24 :                   tmp = fold_build3_loc (input_location, COMPONENT_REF,
    1597                 :          24 :                                          TREE_TYPE (field), dim, field,
    1598                 :             :                                          NULL_TREE);
    1599                 :             : 
    1600                 :             :                   /* Set vector in v.  */
    1601                 :          24 :                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
    1602                 :          24 :                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1603                 :          24 :                                           TREE_TYPE (field), tmp, field,
    1604                 :             :                                           NULL_TREE);
    1605                 :          24 :                   gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
    1606                 :             :                                                              vector));
    1607                 :             : 
    1608                 :             :                   /* Set nvec in v.  */
    1609                 :          24 :                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
    1610                 :          24 :                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1611                 :          24 :                                           TREE_TYPE (field), tmp, field,
    1612                 :             :                                           NULL_TREE);
    1613                 :          24 :                   gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
    1614                 :             :                                                              nvec));
    1615                 :             : 
    1616                 :             :                   /* Set kind in v.  */
    1617                 :          24 :                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
    1618                 :          24 :                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
    1619                 :          24 :                                           TREE_TYPE (field), tmp, field,
    1620                 :             :                                           NULL_TREE);
    1621                 :          24 :                   gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
    1622                 :          24 :                                                   ref->u.ar.start[i]->ts.kind));
    1623                 :          24 :                   break;
    1624                 :           0 :                 default:
    1625                 :           0 :                   gcc_unreachable ();
    1626                 :             :                 }
    1627                 :             :               /* Set the mode for dim i.  */
    1628                 :        1068 :               tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
    1629                 :        1068 :               gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
    1630                 :             :                                                         mode_rhs));
    1631                 :             :             }
    1632                 :             : 
    1633                 :             :           /* Set the mode for dim i+1 to GFC_ARR_REF_NONE.  */
    1634                 :         665 :           if (i < GFC_MAX_DIMENSIONS)
    1635                 :             :             {
    1636                 :         665 :               tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
    1637                 :         665 :               gfc_add_modify (block, tmp,
    1638                 :             :                               build_int_cst (unsigned_char_type_node,
    1639                 :         665 :                                              GFC_CAF_ARR_REF_NONE));
    1640                 :             :             }
    1641                 :             :           break;
    1642                 :           0 :         default:
    1643                 :           0 :           gcc_unreachable ();
    1644                 :             :         }
    1645                 :             : 
    1646                 :             :       /* Set the size of the current type.  */
    1647                 :        1741 :       field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
    1648                 :        1741 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1649                 :             :                              prev_caf_ref, field, NULL_TREE);
    1650                 :        1741 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
    1651                 :             :                                                 TYPE_SIZE_UNIT (last_type)));
    1652                 :             : 
    1653                 :        1741 :       ref = ref->next;
    1654                 :             :     }
    1655                 :             : 
    1656                 :         749 :   if (prev_caf_ref != NULL_TREE)
    1657                 :             :     {
    1658                 :         749 :       field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
    1659                 :         749 :       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
    1660                 :             :                              prev_caf_ref, field, NULL_TREE);
    1661                 :         749 :       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
    1662                 :             :                                                   null_pointer_node));
    1663                 :             :     }
    1664                 :         749 :   return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
    1665                 :         749 :                               : NULL_TREE;
    1666                 :             : }
    1667                 :             : 
    1668                 :             : /* Get data from a remote coarray.  */
    1669                 :             : 
    1670                 :             : static void
    1671                 :         791 : gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
    1672                 :             :                             tree may_require_tmp, bool may_realloc,
    1673                 :             :                             symbol_attribute *caf_attr)
    1674                 :             : {
    1675                 :         791 :   gfc_expr *array_expr, *tmp_stat;
    1676                 :         791 :   gfc_se argse;
    1677                 :         791 :   tree caf_decl, token, offset, image_index, tmp;
    1678                 :         791 :   tree res_var, dst_var, type, kind, vec, stat;
    1679                 :         791 :   tree caf_reference;
    1680                 :         791 :   symbol_attribute caf_attr_store;
    1681                 :             : 
    1682                 :         791 :   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
    1683                 :             : 
    1684                 :         791 :   if (se->ss && se->ss->info->useflags)
    1685                 :             :     {
    1686                 :             :        /* Access the previously obtained result.  */
    1687                 :         272 :        gfc_conv_tmp_array_ref (se);
    1688                 :         915 :        return;
    1689                 :             :     }
    1690                 :             : 
    1691                 :             :   /* If lhs is set, the CAF_GET intrinsic has already been stripped.  */
    1692                 :         519 :   array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
    1693                 :         519 :   type = gfc_typenode_for_spec (&array_expr->ts);
    1694                 :             : 
    1695                 :         519 :   if (caf_attr == NULL)
    1696                 :             :     {
    1697                 :         370 :       caf_attr_store = gfc_caf_attr (array_expr);
    1698                 :         370 :       caf_attr = &caf_attr_store;
    1699                 :             :     }
    1700                 :             : 
    1701                 :         519 :   res_var = lhs;
    1702                 :         519 :   dst_var = lhs;
    1703                 :             : 
    1704                 :         519 :   vec = null_pointer_node;
    1705                 :         519 :   tmp_stat = gfc_find_stat_co (expr);
    1706                 :             : 
    1707                 :         519 :   if (tmp_stat)
    1708                 :             :     {
    1709                 :          11 :       gfc_se stat_se;
    1710                 :          11 :       gfc_init_se (&stat_se, NULL);
    1711                 :          11 :       gfc_conv_expr_reference (&stat_se, tmp_stat);
    1712                 :          11 :       stat = stat_se.expr;
    1713                 :          11 :       gfc_add_block_to_block (&se->pre, &stat_se.pre);
    1714                 :          11 :       gfc_add_block_to_block (&se->post, &stat_se.post);
    1715                 :             :     }
    1716                 :             :   else
    1717                 :         508 :     stat = null_pointer_node;
    1718                 :             : 
    1719                 :             :   /* Only use the new get_by_ref () where it is necessary.  I.e., when the lhs
    1720                 :             :      is reallocatable or the right-hand side has allocatable components.  */
    1721                 :         519 :   if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
    1722                 :             :     {
    1723                 :             :       /* Get using caf_get_by_ref.  */
    1724                 :         371 :       caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
    1725                 :             : 
    1726                 :         371 :       if (caf_reference != NULL_TREE)
    1727                 :             :         {
    1728                 :         371 :           if (lhs == NULL_TREE)
    1729                 :             :             {
    1730                 :         320 :               if (array_expr->ts.type == BT_CHARACTER)
    1731                 :           0 :                 gfc_init_se (&argse, NULL);
    1732                 :         320 :               if (array_expr->rank == 0)
    1733                 :             :                 {
    1734                 :          78 :                   symbol_attribute attr;
    1735                 :          78 :                   gfc_clear_attr (&attr);
    1736                 :          78 :                   if (array_expr->ts.type == BT_CHARACTER)
    1737                 :             :                     {
    1738                 :           0 :                       res_var = gfc_conv_string_tmp (se,
    1739                 :             :                                                      build_pointer_type (type),
    1740                 :           0 :                                              array_expr->ts.u.cl->backend_decl);
    1741                 :           0 :                       argse.string_length = array_expr->ts.u.cl->backend_decl;
    1742                 :             :                     }
    1743                 :             :                   else
    1744                 :          78 :                     res_var = gfc_create_var (type, "caf_res");
    1745                 :          78 :                   dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
    1746                 :          78 :                   dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
    1747                 :             :                 }
    1748                 :             :               else
    1749                 :             :                 {
    1750                 :             :                   /* Create temporary.  */
    1751                 :         242 :                   if (array_expr->ts.type == BT_CHARACTER)
    1752                 :           0 :                     gfc_conv_expr_descriptor (&argse, array_expr);
    1753                 :         242 :                   may_realloc = gfc_trans_create_temp_array (&se->pre,
    1754                 :             :                                                              &se->post,
    1755                 :             :                                                              se->ss, type,
    1756                 :             :                                                              NULL_TREE, false,
    1757                 :             :                                                              false, false,
    1758                 :             :                                                              &array_expr->where)
    1759                 :             :                       == NULL_TREE;
    1760                 :         242 :                   res_var = se->ss->info->data.array.descriptor;
    1761                 :         242 :                   dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
    1762                 :         242 :                   if (may_realloc)
    1763                 :             :                     {
    1764                 :          26 :                       tmp = gfc_conv_descriptor_data_get (res_var);
    1765                 :          26 :                       tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
    1766                 :             :                                                         NULL_TREE, NULL_TREE,
    1767                 :             :                                                         NULL_TREE, true,
    1768                 :             :                                                         NULL,
    1769                 :             :                                                      GFC_CAF_COARRAY_NOCOARRAY);
    1770                 :          26 :                       gfc_add_expr_to_block (&se->post, tmp);
    1771                 :             :                     }
    1772                 :             :                 }
    1773                 :             :             }
    1774                 :             : 
    1775                 :         371 :           kind = build_int_cst (integer_type_node, expr->ts.kind);
    1776                 :         371 :           if (lhs_kind == NULL_TREE)
    1777                 :         320 :             lhs_kind = kind;
    1778                 :             : 
    1779                 :         371 :           caf_decl = gfc_get_tree_for_caf_expr (array_expr);
    1780                 :         371 :           if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
    1781                 :           0 :             caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
    1782                 :         371 :           image_index = gfc_caf_get_image_index (&se->pre, array_expr,
    1783                 :             :                                                  caf_decl);
    1784                 :         371 :           gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
    1785                 :             :                                     array_expr);
    1786                 :             : 
    1787                 :             :           /* No overlap possible as we have generated a temporary.  */
    1788                 :         371 :           if (lhs == NULL_TREE)
    1789                 :         320 :             may_require_tmp = boolean_false_node;
    1790                 :             : 
    1791                 :             :           /* It guarantees memory consistency within the same segment.  */
    1792                 :         371 :           tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
    1793                 :         371 :           tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    1794                 :             :                             gfc_build_string_const (1, ""), NULL_TREE,
    1795                 :             :                             NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
    1796                 :             :                             NULL_TREE);
    1797                 :         371 :           ASM_VOLATILE_P (tmp) = 1;
    1798                 :         371 :           gfc_add_expr_to_block (&se->pre, tmp);
    1799                 :             : 
    1800                 :         371 :           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
    1801                 :             :                                      10, token, image_index, dst_var,
    1802                 :             :                                      caf_reference, lhs_kind, kind,
    1803                 :             :                                      may_require_tmp,
    1804                 :             :                                      may_realloc ? boolean_true_node :
    1805                 :             :                                                    boolean_false_node,
    1806                 :             :                                      stat, build_int_cst (integer_type_node,
    1807                 :         371 :                                                           array_expr->ts.type));
    1808                 :             : 
    1809                 :         371 :           gfc_add_expr_to_block (&se->pre, tmp);
    1810                 :             : 
    1811                 :         371 :           if (se->ss)
    1812                 :         242 :             gfc_advance_se_ss_chain (se);
    1813                 :             : 
    1814                 :         371 :           se->expr = res_var;
    1815                 :         371 :           if (array_expr->ts.type == BT_CHARACTER)
    1816                 :           0 :             se->string_length = argse.string_length;
    1817                 :             : 
    1818                 :         371 :           return;
    1819                 :             :         }
    1820                 :             :     }
    1821                 :             : 
    1822                 :         148 :   gfc_init_se (&argse, NULL);
    1823                 :         148 :   if (array_expr->rank == 0)
    1824                 :             :     {
    1825                 :          73 :       symbol_attribute attr;
    1826                 :             : 
    1827                 :          73 :       gfc_clear_attr (&attr);
    1828                 :          73 :       gfc_conv_expr (&argse, array_expr);
    1829                 :             : 
    1830                 :          73 :       if (lhs == NULL_TREE)
    1831                 :             :         {
    1832                 :          19 :           gfc_clear_attr (&attr);
    1833                 :          19 :           if (array_expr->ts.type == BT_CHARACTER)
    1834                 :           9 :             res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
    1835                 :             :                                            argse.string_length);
    1836                 :             :           else
    1837                 :          10 :             res_var = gfc_create_var (type, "caf_res");
    1838                 :          19 :           dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
    1839                 :          19 :           dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
    1840                 :             :         }
    1841                 :          73 :       argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
    1842                 :          73 :       argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
    1843                 :             :     }
    1844                 :             :   else
    1845                 :             :     {
    1846                 :             :       /* If has_vector, pass descriptor for whole array and the
    1847                 :             :          vector bounds separately.  */
    1848                 :          75 :       gfc_array_ref *ar, ar2;
    1849                 :          75 :       bool has_vector = false;
    1850                 :             : 
    1851                 :          75 :       if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
    1852                 :             :         {
    1853                 :           0 :           has_vector = true;
    1854                 :           0 :           ar = gfc_find_array_ref (expr);
    1855                 :           0 :           ar2 = *ar;
    1856                 :           0 :           memset (ar, '\0', sizeof (*ar));
    1857                 :           0 :           ar->as = ar2.as;
    1858                 :           0 :           ar->type = AR_FULL;
    1859                 :             :         }
    1860                 :             :       // TODO: Check whether argse.want_coarray = 1 can help with the below.
    1861                 :          75 :       gfc_conv_expr_descriptor (&argse, array_expr);
    1862                 :             :       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
    1863                 :             :          has the wrong type if component references are done.  */
    1864                 :          75 :       gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
    1865                 :             :                       gfc_get_dtype_rank_type (has_vector ? ar2.dimen
    1866                 :             :                                                           : array_expr->rank,
    1867                 :             :                                                type));
    1868                 :          75 :       if (has_vector)
    1869                 :             :         {
    1870                 :           0 :           vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
    1871                 :           0 :           *ar = ar2;
    1872                 :             :         }
    1873                 :             : 
    1874                 :          75 :       if (lhs == NULL_TREE)
    1875                 :             :         {
    1876                 :             :           /* Create temporary.  */
    1877                 :          62 :           for (int n = 0; n < se->ss->loop->dimen; n++)
    1878                 :          31 :             if (se->loop->to[n] == NULL_TREE)
    1879                 :             :               {
    1880                 :          12 :                 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
    1881                 :             :                                                                gfc_rank_cst[n]);
    1882                 :          12 :                 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
    1883                 :             :                                                                gfc_rank_cst[n]);
    1884                 :             :               }
    1885                 :          31 :           gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
    1886                 :             :                                        NULL_TREE, false, true, false,
    1887                 :             :                                        &array_expr->where);
    1888                 :          31 :           res_var = se->ss->info->data.array.descriptor;
    1889                 :          31 :           dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
    1890                 :             :         }
    1891                 :          75 :       argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
    1892                 :             :     }
    1893                 :             : 
    1894                 :         148 :   kind = build_int_cst (integer_type_node, expr->ts.kind);
    1895                 :         148 :   if (lhs_kind == NULL_TREE)
    1896                 :          50 :     lhs_kind = kind;
    1897                 :             : 
    1898                 :         148 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    1899                 :         148 :   gfc_add_block_to_block (&se->post, &argse.post);
    1900                 :             : 
    1901                 :         148 :   caf_decl = gfc_get_tree_for_caf_expr (array_expr);
    1902                 :         148 :   if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
    1903                 :           1 :     caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
    1904                 :         148 :   image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
    1905                 :         148 :   gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
    1906                 :             :                             array_expr);
    1907                 :             : 
    1908                 :             :   /* No overlap possible as we have generated a temporary.  */
    1909                 :         148 :   if (lhs == NULL_TREE)
    1910                 :          50 :     may_require_tmp = boolean_false_node;
    1911                 :             : 
    1912                 :             :   /* It guarantees memory consistency within the same segment.  */
    1913                 :         148 :   tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
    1914                 :         148 :   tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    1915                 :             :                     gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
    1916                 :             :                     tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
    1917                 :         148 :   ASM_VOLATILE_P (tmp) = 1;
    1918                 :         148 :   gfc_add_expr_to_block (&se->pre, tmp);
    1919                 :             : 
    1920                 :         148 :   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
    1921                 :             :                              token, offset, image_index, argse.expr, vec,
    1922                 :             :                              dst_var, kind, lhs_kind, may_require_tmp, stat);
    1923                 :             : 
    1924                 :         148 :   gfc_add_expr_to_block (&se->pre, tmp);
    1925                 :             : 
    1926                 :         148 :   if (se->ss)
    1927                 :          31 :     gfc_advance_se_ss_chain (se);
    1928                 :             : 
    1929                 :         148 :   se->expr = res_var;
    1930                 :         148 :   if (array_expr->ts.type == BT_CHARACTER)
    1931                 :          25 :     se->string_length = argse.string_length;
    1932                 :             : }
    1933                 :             : 
    1934                 :             : 
    1935                 :             : /* Send data to a remote coarray.  */
    1936                 :             : 
    1937                 :             : static tree
    1938                 :         528 : conv_caf_send (gfc_code *code) {
    1939                 :         528 :   gfc_expr *lhs_expr, *rhs_expr, *tmp_stat, *tmp_team;
    1940                 :         528 :   gfc_se lhs_se, rhs_se;
    1941                 :         528 :   stmtblock_t block;
    1942                 :         528 :   tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
    1943                 :         528 :   tree may_require_tmp, src_stat, dst_stat, dst_team;
    1944                 :         528 :   tree lhs_type = NULL_TREE;
    1945                 :         528 :   tree vec = null_pointer_node, rhs_vec = null_pointer_node;
    1946                 :         528 :   symbol_attribute lhs_caf_attr, rhs_caf_attr;
    1947                 :             : 
    1948                 :         528 :   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
    1949                 :             : 
    1950                 :         528 :   lhs_expr = code->ext.actual->expr;
    1951                 :         528 :   rhs_expr = code->ext.actual->next->expr;
    1952                 :         528 :   may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
    1953                 :         528 :                     ? boolean_false_node : boolean_true_node;
    1954                 :         528 :   gfc_init_block (&block);
    1955                 :             : 
    1956                 :         528 :   lhs_caf_attr = gfc_caf_attr (lhs_expr);
    1957                 :         528 :   rhs_caf_attr = gfc_caf_attr (rhs_expr);
    1958                 :         528 :   src_stat = dst_stat = null_pointer_node;
    1959                 :         528 :   dst_team = null_pointer_node;
    1960                 :             : 
    1961                 :             :   /* LHS.  */
    1962                 :         528 :   gfc_init_se (&lhs_se, NULL);
    1963                 :         528 :   if (lhs_expr->rank == 0)
    1964                 :             :     {
    1965                 :         217 :       if (lhs_expr->ts.type == BT_CHARACTER && lhs_expr->ts.deferred)
    1966                 :             :         {
    1967                 :           4 :           lhs_se.expr = gfc_get_tree_for_caf_expr (lhs_expr);
    1968                 :           4 :           lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
    1969                 :             :         }
    1970                 :             :       else
    1971                 :             :         {
    1972                 :         213 :           symbol_attribute attr;
    1973                 :         213 :           gfc_clear_attr (&attr);
    1974                 :         213 :           gfc_conv_expr (&lhs_se, lhs_expr);
    1975                 :         213 :           lhs_type = TREE_TYPE (lhs_se.expr);
    1976                 :         213 :           lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr,
    1977                 :             :                                                        attr);
    1978                 :         213 :           lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
    1979                 :             :         }
    1980                 :             :     }
    1981                 :         311 :   else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
    1982                 :         168 :            && lhs_caf_attr.codimension)
    1983                 :             :     {
    1984                 :         168 :       lhs_se.want_pointer = 1;
    1985                 :         168 :       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
    1986                 :             :       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
    1987                 :             :          has the wrong type if component references are done.  */
    1988                 :         168 :       lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
    1989                 :         168 :       tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
    1990                 :         168 :       gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
    1991                 :             :                       gfc_get_dtype_rank_type (
    1992                 :         168 :                         gfc_has_vector_subscript (lhs_expr)
    1993                 :           0 :                         ? gfc_find_array_ref (lhs_expr)->dimen
    1994                 :             :                         : lhs_expr->rank,
    1995                 :             :                       lhs_type));
    1996                 :             :     }
    1997                 :             :   else
    1998                 :             :     {
    1999                 :         143 :       bool has_vector = gfc_has_vector_subscript (lhs_expr);
    2000                 :             : 
    2001                 :         143 :       if (gfc_is_coindexed (lhs_expr) || !has_vector)
    2002                 :             :         {
    2003                 :             :           /* If has_vector, pass descriptor for whole array and the
    2004                 :             :              vector bounds separately.  */
    2005                 :         139 :           gfc_array_ref *ar, ar2;
    2006                 :         139 :           bool has_tmp_lhs_array = false;
    2007                 :         139 :           if (has_vector)
    2008                 :             :             {
    2009                 :           0 :               has_tmp_lhs_array = true;
    2010                 :           0 :               ar = gfc_find_array_ref (lhs_expr);
    2011                 :           0 :               ar2 = *ar;
    2012                 :           0 :               memset (ar, '\0', sizeof (*ar));
    2013                 :           0 :               ar->as = ar2.as;
    2014                 :           0 :               ar->type = AR_FULL;
    2015                 :             :             }
    2016                 :         139 :           lhs_se.want_pointer = 1;
    2017                 :         139 :           gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
    2018                 :             :           /* Using gfc_conv_expr_descriptor, we only get the descriptor, but
    2019                 :             :              that has the wrong type if component references are done.  */
    2020                 :         139 :           lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
    2021                 :         139 :           tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
    2022                 :         139 :           gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
    2023                 :             :                           gfc_get_dtype_rank_type (has_vector ? ar2.dimen
    2024                 :             :                                                               : lhs_expr->rank,
    2025                 :             :                                                    lhs_type));
    2026                 :         139 :           if (has_tmp_lhs_array)
    2027                 :             :             {
    2028                 :           0 :               vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
    2029                 :           0 :               *ar = ar2;
    2030                 :             :             }
    2031                 :             :         }
    2032                 :             :       else
    2033                 :             :         {
    2034                 :             :           /* Special casing for arr1 ([...]) = arr2[...], i.e. caf_get to
    2035                 :             :              indexed array expression.  This is rewritten to:
    2036                 :             : 
    2037                 :             :              tmp_array = arr2[...]
    2038                 :             :              arr1 ([...]) = tmp_array
    2039                 :             : 
    2040                 :             :              because using the standard gfc_conv_expr (lhs_expr) did the
    2041                 :             :              assignment with lhs and rhs exchanged.  */
    2042                 :             : 
    2043                 :           4 :           gfc_ss *lss_for_tmparray, *lss_real;
    2044                 :           4 :           gfc_loopinfo loop;
    2045                 :           4 :           gfc_se se;
    2046                 :           4 :           stmtblock_t body;
    2047                 :           4 :           tree tmparr_desc, src;
    2048                 :           4 :           tree index = gfc_index_zero_node;
    2049                 :           4 :           tree stride = gfc_index_zero_node;
    2050                 :           4 :           int n;
    2051                 :             : 
    2052                 :             :           /* Walk both sides of the assignment, once to get the shape of the
    2053                 :             :              temporary array to create right.  */
    2054                 :           4 :           lss_for_tmparray = gfc_walk_expr (lhs_expr);
    2055                 :             :           /* And a second time to be able to create an assignment of the
    2056                 :             :              temporary to the lhs_expr.  gfc_trans_create_temp_array replaces
    2057                 :             :              the tree in the descriptor with the one for the temporary
    2058                 :             :              array.  */
    2059                 :           4 :           lss_real = gfc_walk_expr (lhs_expr);
    2060                 :           4 :           gfc_init_loopinfo (&loop);
    2061                 :           4 :           gfc_add_ss_to_loop (&loop, lss_for_tmparray);
    2062                 :           4 :           gfc_add_ss_to_loop (&loop, lss_real);
    2063                 :           4 :           gfc_conv_ss_startstride (&loop);
    2064                 :           4 :           gfc_conv_loop_setup (&loop, &lhs_expr->where);
    2065                 :           4 :           lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
    2066                 :           4 :           gfc_trans_create_temp_array (&lhs_se.pre, &lhs_se.post,
    2067                 :             :                                        lss_for_tmparray, lhs_type, NULL_TREE,
    2068                 :             :                                        false, true, false,
    2069                 :             :                                        &lhs_expr->where);
    2070                 :           4 :           tmparr_desc = lss_for_tmparray->info->data.array.descriptor;
    2071                 :           4 :           gfc_start_scalarized_body (&loop, &body);
    2072                 :           4 :           gfc_init_se (&se, NULL);
    2073                 :           4 :           gfc_copy_loopinfo_to_se (&se, &loop);
    2074                 :           4 :           se.ss = lss_real;
    2075                 :           4 :           gfc_conv_expr (&se, lhs_expr);
    2076                 :           4 :           gfc_add_block_to_block (&body, &se.pre);
    2077                 :             : 
    2078                 :             :           /* Walk over all indexes of the loop.  */
    2079                 :           4 :           for (n = loop.dimen - 1; n > 0; --n)
    2080                 :             :             {
    2081                 :           0 :               tmp = loop.loopvar[n];
    2082                 :           0 :               tmp = fold_build2_loc (input_location, MINUS_EXPR,
    2083                 :             :                                      gfc_array_index_type, tmp, loop.from[n]);
    2084                 :           0 :               tmp = fold_build2_loc (input_location, PLUS_EXPR,
    2085                 :             :                                      gfc_array_index_type, tmp, index);
    2086                 :             : 
    2087                 :           0 :               stride = fold_build2_loc (input_location, MINUS_EXPR,
    2088                 :             :                                         gfc_array_index_type,
    2089                 :           0 :                                         loop.to[n - 1], loop.from[n - 1]);
    2090                 :           0 :               stride = fold_build2_loc (input_location, PLUS_EXPR,
    2091                 :             :                                         gfc_array_index_type,
    2092                 :             :                                         stride, gfc_index_one_node);
    2093                 :             : 
    2094                 :           0 :               index = fold_build2_loc (input_location, MULT_EXPR,
    2095                 :             :                                        gfc_array_index_type, tmp, stride);
    2096                 :             :             }
    2097                 :             : 
    2098                 :           4 :           index = fold_build2_loc (input_location, MINUS_EXPR,
    2099                 :             :                                    gfc_array_index_type,
    2100                 :             :                                    index, loop.from[0]);
    2101                 :             : 
    2102                 :           4 :           index = fold_build2_loc (input_location, PLUS_EXPR,
    2103                 :             :                                    gfc_array_index_type,
    2104                 :             :                                    loop.loopvar[0], index);
    2105                 :             : 
    2106                 :           4 :           src = build_fold_indirect_ref (gfc_conv_array_data (tmparr_desc));
    2107                 :           4 :           src = gfc_build_array_ref (src, index, NULL);
    2108                 :             :           /* Now create the assignment of lhs_expr = tmp_array.  */
    2109                 :           4 :           gfc_add_modify (&body, se.expr, src);
    2110                 :           4 :           gfc_add_block_to_block (&body, &se.post);
    2111                 :           4 :           lhs_se.expr = gfc_build_addr_expr (NULL_TREE, tmparr_desc);
    2112                 :           4 :           gfc_trans_scalarizing_loops (&loop, &body);
    2113                 :           4 :           gfc_add_block_to_block (&loop.pre, &loop.post);
    2114                 :           4 :           gfc_add_expr_to_block (&lhs_se.post, gfc_finish_block (&loop.pre));
    2115                 :           4 :           gfc_free_ss (lss_for_tmparray);
    2116                 :           4 :           gfc_free_ss (lss_real);
    2117                 :             :         }
    2118                 :             :     }
    2119                 :             : 
    2120                 :         528 :   lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
    2121                 :             : 
    2122                 :             :   /* Special case: RHS is a coarray but LHS is not; this code path avoids a
    2123                 :             :      temporary and a loop.  */
    2124                 :         528 :   if (!gfc_is_coindexed (lhs_expr)
    2125                 :         528 :       && (!lhs_caf_attr.codimension
    2126                 :          38 :           || !(lhs_expr->rank > 0
    2127                 :          29 :                && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
    2128                 :             :     {
    2129                 :         149 :       bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
    2130                 :         149 :       gcc_assert (gfc_is_coindexed (rhs_expr));
    2131                 :         149 :       gfc_init_se (&rhs_se, NULL);
    2132                 :         149 :       if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
    2133                 :             :         {
    2134                 :           0 :           gfc_se scal_se;
    2135                 :           0 :           gfc_init_se (&scal_se, NULL);
    2136                 :           0 :           scal_se.want_pointer = 1;
    2137                 :           0 :           gfc_conv_expr (&scal_se, lhs_expr);
    2138                 :             :           /* Ensure scalar on lhs is allocated.  */
    2139                 :           0 :           gfc_add_block_to_block (&block, &scal_se.pre);
    2140                 :             : 
    2141                 :           0 :           gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
    2142                 :           0 :                                     TYPE_SIZE_UNIT (
    2143                 :             :                                        gfc_typenode_for_spec (&lhs_expr->ts)),
    2144                 :             :                                     NULL_TREE);
    2145                 :           0 :           tmp = fold_build2 (EQ_EXPR, logical_type_node, scal_se.expr,
    2146                 :             :                              null_pointer_node);
    2147                 :           0 :           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
    2148                 :             :                                  tmp, gfc_finish_block (&scal_se.pre),
    2149                 :             :                                  build_empty_stmt (input_location));
    2150                 :           0 :           gfc_add_expr_to_block (&block, tmp);
    2151                 :           0 :         }
    2152                 :             :       else
    2153                 :         149 :         lhs_may_realloc = lhs_may_realloc
    2154                 :         149 :             && gfc_full_array_ref_p (lhs_expr->ref, NULL);
    2155                 :         149 :       gfc_add_block_to_block (&block, &lhs_se.pre);
    2156                 :         149 :       gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
    2157                 :             :                                   may_require_tmp, lhs_may_realloc,
    2158                 :             :                                   &rhs_caf_attr);
    2159                 :         149 :       gfc_add_block_to_block (&block, &rhs_se.pre);
    2160                 :         149 :       gfc_add_block_to_block (&block, &rhs_se.post);
    2161                 :         149 :       gfc_add_block_to_block (&block, &lhs_se.post);
    2162                 :         149 :       return gfc_finish_block (&block);
    2163                 :             :     }
    2164                 :             : 
    2165                 :         379 :   gfc_add_block_to_block (&block, &lhs_se.pre);
    2166                 :             : 
    2167                 :             :   /* Obtain token, offset and image index for the LHS.  */
    2168                 :         379 :   caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
    2169                 :         379 :   if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
    2170                 :           0 :     caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
    2171                 :         379 :   image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
    2172                 :         379 :   tmp = lhs_se.expr;
    2173                 :         379 :   if (lhs_caf_attr.alloc_comp)
    2174                 :         192 :     gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
    2175                 :             :                               NULL);
    2176                 :             :   else
    2177                 :         187 :     gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
    2178                 :             :                               lhs_expr);
    2179                 :         379 :   lhs_se.expr = tmp;
    2180                 :             : 
    2181                 :             :   /* RHS.  */
    2182                 :         379 :   gfc_init_se (&rhs_se, NULL);
    2183                 :         379 :   if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
    2184                 :           0 :       && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
    2185                 :           0 :     rhs_expr = rhs_expr->value.function.actual->expr;
    2186                 :         379 :   if (rhs_expr->rank == 0)
    2187                 :             :     {
    2188                 :         215 :       symbol_attribute attr;
    2189                 :         215 :       gfc_clear_attr (&attr);
    2190                 :         215 :       gfc_conv_expr (&rhs_se, rhs_expr);
    2191                 :         215 :       rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
    2192                 :         215 :       rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
    2193                 :             :     }
    2194                 :         164 :   else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
    2195                 :          24 :            && rhs_caf_attr.codimension)
    2196                 :             :     {
    2197                 :          24 :       tree tmp2;
    2198                 :          24 :       rhs_se.want_pointer = 1;
    2199                 :          24 :       gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
    2200                 :             :       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
    2201                 :             :          has the wrong type if component references are done.  */
    2202                 :          24 :       tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
    2203                 :          24 :       tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
    2204                 :          24 :       gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
    2205                 :             :                       gfc_get_dtype_rank_type (
    2206                 :          24 :                         gfc_has_vector_subscript (rhs_expr)
    2207                 :           0 :                         ? gfc_find_array_ref (rhs_expr)->dimen
    2208                 :             :                         : rhs_expr->rank,
    2209                 :             :                       tmp2));
    2210                 :          24 :     }
    2211                 :             :   else
    2212                 :             :     {
    2213                 :             :       /* If has_vector, pass descriptor for whole array and the
    2214                 :             :          vector bounds separately.  */
    2215                 :         140 :       gfc_array_ref *ar, ar2;
    2216                 :         140 :       bool has_vector = false;
    2217                 :         140 :       tree tmp2;
    2218                 :             : 
    2219                 :         140 :       if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
    2220                 :             :         {
    2221                 :           0 :           has_vector = true;
    2222                 :           0 :           ar = gfc_find_array_ref (rhs_expr);
    2223                 :           0 :           ar2 = *ar;
    2224                 :           0 :           memset (ar, '\0', sizeof (*ar));
    2225                 :           0 :           ar->as = ar2.as;
    2226                 :           0 :           ar->type = AR_FULL;
    2227                 :             :         }
    2228                 :         140 :       rhs_se.want_pointer = 1;
    2229                 :         140 :       gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
    2230                 :             :       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
    2231                 :             :          has the wrong type if component references are done.  */
    2232                 :         140 :       tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
    2233                 :         140 :       tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
    2234                 :         140 :       gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
    2235                 :             :                       gfc_get_dtype_rank_type (has_vector ? ar2.dimen
    2236                 :             :                                                           : rhs_expr->rank,
    2237                 :             :                       tmp2));
    2238                 :         140 :       if (has_vector)
    2239                 :             :         {
    2240                 :           0 :           rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
    2241                 :           0 :           *ar = ar2;
    2242                 :             :         }
    2243                 :             :     }
    2244                 :             : 
    2245                 :         379 :   gfc_add_block_to_block (&block, &rhs_se.pre);
    2246                 :             : 
    2247                 :         379 :   rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
    2248                 :             : 
    2249                 :         379 :   tmp_stat = gfc_find_stat_co (lhs_expr);
    2250                 :             : 
    2251                 :         379 :   if (tmp_stat)
    2252                 :             :     {
    2253                 :           0 :       gfc_se stat_se;
    2254                 :           0 :       gfc_init_se (&stat_se, NULL);
    2255                 :           0 :       gfc_conv_expr_reference (&stat_se, tmp_stat);
    2256                 :           0 :       dst_stat = stat_se.expr;
    2257                 :           0 :       gfc_add_block_to_block (&block, &stat_se.pre);
    2258                 :           0 :       gfc_add_block_to_block (&block, &stat_se.post);
    2259                 :             :     }
    2260                 :             : 
    2261                 :         379 :   tmp_team = gfc_find_team_co (lhs_expr);
    2262                 :             : 
    2263                 :         379 :   if (tmp_team)
    2264                 :             :     {
    2265                 :           0 :       gfc_se team_se;
    2266                 :           0 :       gfc_init_se (&team_se, NULL);
    2267                 :           0 :       gfc_conv_expr_reference (&team_se, tmp_team);
    2268                 :           0 :       dst_team = team_se.expr;
    2269                 :           0 :       gfc_add_block_to_block (&block, &team_se.pre);
    2270                 :           0 :       gfc_add_block_to_block (&block, &team_se.post);
    2271                 :             :     }
    2272                 :             : 
    2273                 :         379 :   if (!gfc_is_coindexed (rhs_expr))
    2274                 :             :     {
    2275                 :         289 :       if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
    2276                 :             :         {
    2277                 :         222 :           tree reference, dst_realloc;
    2278                 :         222 :           reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
    2279                 :         222 :           dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
    2280                 :             :                                              : boolean_false_node;
    2281                 :         222 :           tmp = build_call_expr_loc (input_location,
    2282                 :             :                                      gfor_fndecl_caf_send_by_ref,
    2283                 :             :                                      10, token, image_index, rhs_se.expr,
    2284                 :             :                                      reference, lhs_kind, rhs_kind,
    2285                 :             :                                      may_require_tmp, dst_realloc, src_stat,
    2286                 :             :                                      build_int_cst (integer_type_node,
    2287                 :         222 :                                                     lhs_expr->ts.type));
    2288                 :             :           }
    2289                 :             :       else
    2290                 :          67 :         tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 11,
    2291                 :             :                                    token, offset, image_index, lhs_se.expr, vec,
    2292                 :             :                                    rhs_se.expr, lhs_kind, rhs_kind,
    2293                 :             :                                    may_require_tmp, src_stat, dst_team);
    2294                 :             :     }
    2295                 :             :   else
    2296                 :             :     {
    2297                 :          90 :       tree rhs_token, rhs_offset, rhs_image_index;
    2298                 :             : 
    2299                 :             :       /* It guarantees memory consistency within the same segment.  */
    2300                 :          90 :       tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
    2301                 :          90 :       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    2302                 :             :                           gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
    2303                 :             :                           tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
    2304                 :          90 :       ASM_VOLATILE_P (tmp) = 1;
    2305                 :          90 :       gfc_add_expr_to_block (&block, tmp);
    2306                 :             : 
    2307                 :          90 :       caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
    2308                 :          90 :       if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
    2309                 :           0 :         caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
    2310                 :          90 :       rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
    2311                 :          90 :       tmp = rhs_se.expr;
    2312                 :          90 :       if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
    2313                 :             :         {
    2314                 :          48 :           tmp_stat = gfc_find_stat_co (lhs_expr);
    2315                 :             : 
    2316                 :          48 :           if (tmp_stat)
    2317                 :             :             {
    2318                 :           0 :               gfc_se stat_se;
    2319                 :           0 :               gfc_init_se (&stat_se, NULL);
    2320                 :           0 :               gfc_conv_expr_reference (&stat_se, tmp_stat);
    2321                 :           0 :               src_stat = stat_se.expr;
    2322                 :           0 :               gfc_add_block_to_block (&block, &stat_se.pre);
    2323                 :           0 :               gfc_add_block_to_block (&block, &stat_se.post);
    2324                 :             :             }
    2325                 :             : 
    2326                 :          48 :           gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
    2327                 :             :                                     NULL_TREE, NULL);
    2328                 :          48 :           tree lhs_reference, rhs_reference;
    2329                 :          48 :           lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
    2330                 :          48 :           rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
    2331                 :          48 :           tmp = build_call_expr_loc (input_location,
    2332                 :             :                                      gfor_fndecl_caf_sendget_by_ref, 13,
    2333                 :             :                                      token, image_index, lhs_reference,
    2334                 :             :                                      rhs_token, rhs_image_index, rhs_reference,
    2335                 :             :                                      lhs_kind, rhs_kind, may_require_tmp,
    2336                 :             :                                      dst_stat, src_stat,
    2337                 :             :                                      build_int_cst (integer_type_node,
    2338                 :          48 :                                                     lhs_expr->ts.type),
    2339                 :             :                                      build_int_cst (integer_type_node,
    2340                 :          48 :                                                     rhs_expr->ts.type));
    2341                 :             :         }
    2342                 :             :       else
    2343                 :             :         {
    2344                 :          42 :           gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
    2345                 :             :                                     tmp, rhs_expr);
    2346                 :          42 :           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
    2347                 :             :                                      14, token, offset, image_index,
    2348                 :             :                                      lhs_se.expr, vec, rhs_token, rhs_offset,
    2349                 :             :                                      rhs_image_index, tmp, rhs_vec, lhs_kind,
    2350                 :             :                                      rhs_kind, may_require_tmp, src_stat);
    2351                 :             :         }
    2352                 :             :     }
    2353                 :         379 :   gfc_add_expr_to_block (&block, tmp);
    2354                 :         379 :   gfc_add_block_to_block (&block, &lhs_se.post);
    2355                 :         379 :   gfc_add_block_to_block (&block, &rhs_se.post);
    2356                 :             : 
    2357                 :             :   /* It guarantees memory consistency within the same segment.  */
    2358                 :         379 :   tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
    2359                 :         379 :   tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
    2360                 :             :                     gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
    2361                 :             :                     tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
    2362                 :         379 :   ASM_VOLATILE_P (tmp) = 1;
    2363                 :         379 :   gfc_add_expr_to_block (&block, tmp);
    2364                 :             : 
    2365                 :         379 :   return gfc_finish_block (&block);
    2366                 :             : }
    2367                 :             : 
    2368                 :             : 
    2369                 :             : static void
    2370                 :         637 : trans_this_image (gfc_se * se, gfc_expr *expr)
    2371                 :             : {
    2372                 :         637 :   stmtblock_t loop;
    2373                 :         637 :   tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
    2374                 :             :        lbound, ubound, extent, ml;
    2375                 :         637 :   gfc_se argse;
    2376                 :         637 :   int rank, corank;
    2377                 :         637 :   gfc_expr *distance = expr->value.function.actual->next->next->expr;
    2378                 :             : 
    2379                 :         637 :   if (expr->value.function.actual->expr
    2380                 :         637 :       && !gfc_is_coarray (expr->value.function.actual->expr))
    2381                 :           1 :     distance = expr->value.function.actual->expr;
    2382                 :             : 
    2383                 :             :   /* The case -fcoarray=single is handled elsewhere.  */
    2384                 :         637 :   gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
    2385                 :             : 
    2386                 :             :   /* Argument-free version: THIS_IMAGE().  */
    2387                 :         637 :   if (distance || expr->value.function.actual->expr == NULL)
    2388                 :             :     {
    2389                 :         491 :       if (distance)
    2390                 :             :         {
    2391                 :           2 :           gfc_init_se (&argse, NULL);
    2392                 :           2 :           gfc_conv_expr_val (&argse, distance);
    2393                 :           2 :           gfc_add_block_to_block (&se->pre, &argse.pre);
    2394                 :           2 :           gfc_add_block_to_block (&se->post, &argse.post);
    2395                 :           2 :           tmp = fold_convert (integer_type_node, argse.expr);
    2396                 :             :         }
    2397                 :             :       else
    2398                 :         491 :         tmp = integer_zero_node;
    2399                 :         493 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
    2400                 :             :                                  tmp);
    2401                 :         493 :       se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
    2402                 :             :                                tmp);
    2403                 :         497 :       return;
    2404                 :             :     }
    2405                 :             : 
    2406                 :             :   /* Coarray-argument version: THIS_IMAGE(coarray [, dim]).  */
    2407                 :             : 
    2408                 :         144 :   type = gfc_get_int_type (gfc_default_integer_kind);
    2409                 :         144 :   corank = gfc_get_corank (expr->value.function.actual->expr);
    2410                 :         144 :   rank = expr->value.function.actual->expr->rank;
    2411                 :             : 
    2412                 :             :   /* Obtain the descriptor of the COARRAY.  */
    2413                 :         144 :   gfc_init_se (&argse, NULL);
    2414                 :         144 :   argse.want_coarray = 1;
    2415                 :         144 :   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
    2416                 :         144 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    2417                 :         144 :   gfc_add_block_to_block (&se->post, &argse.post);
    2418                 :         144 :   desc = argse.expr;
    2419                 :             : 
    2420                 :         144 :   if (se->ss)
    2421                 :             :     {
    2422                 :             :       /* Create an implicit second parameter from the loop variable.  */
    2423                 :          28 :       gcc_assert (!expr->value.function.actual->next->expr);
    2424                 :          28 :       gcc_assert (corank > 0);
    2425                 :          28 :       gcc_assert (se->loop->dimen == 1);
    2426                 :          28 :       gcc_assert (se->ss->info->expr == expr);
    2427                 :             : 
    2428                 :          28 :       dim_arg = se->loop->loopvar[0];
    2429                 :          28 :       dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
    2430                 :             :                                  gfc_array_index_type, dim_arg,
    2431                 :          28 :                                  build_int_cst (TREE_TYPE (dim_arg), 1));
    2432                 :          28 :       gfc_advance_se_ss_chain (se);
    2433                 :             :     }
    2434                 :             :   else
    2435                 :             :     {
    2436                 :             :       /* Use the passed DIM= argument.  */
    2437                 :         116 :       gcc_assert (expr->value.function.actual->next->expr);
    2438                 :         116 :       gfc_init_se (&argse, NULL);
    2439                 :         116 :       gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
    2440                 :             :                           gfc_array_index_type);
    2441                 :         116 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2442                 :         116 :       dim_arg = argse.expr;
    2443                 :             : 
    2444                 :         116 :       if (INTEGER_CST_P (dim_arg))
    2445                 :             :         {
    2446                 :          58 :           if (wi::ltu_p (wi::to_wide (dim_arg), 1)
    2447                 :         116 :               || wi::gtu_p (wi::to_wide (dim_arg),
    2448                 :          58 :                             GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
    2449                 :           0 :             gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
    2450                 :           0 :                        "dimension index", expr->value.function.isym->name,
    2451                 :             :                        &expr->where);
    2452                 :             :         }
    2453                 :          58 :      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    2454                 :             :         {
    2455                 :           0 :           dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
    2456                 :           0 :           cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    2457                 :             :                                   dim_arg,
    2458                 :           0 :                                   build_int_cst (TREE_TYPE (dim_arg), 1));
    2459                 :           0 :           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
    2460                 :           0 :           tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    2461                 :             :                                  dim_arg, tmp);
    2462                 :           0 :           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    2463                 :             :                                   logical_type_node, cond, tmp);
    2464                 :           0 :           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
    2465                 :             :                                    gfc_msg_fault);
    2466                 :             :         }
    2467                 :             :     }
    2468                 :             : 
    2469                 :             :   /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
    2470                 :             :      one always has a dim_arg argument.
    2471                 :             : 
    2472                 :             :      m = this_image() - 1
    2473                 :             :      if (corank == 1)
    2474                 :             :        {
    2475                 :             :          sub(1) = m + lcobound(corank)
    2476                 :             :          return;
    2477                 :             :        }
    2478                 :             :      i = rank
    2479                 :             :      min_var = min (rank + corank - 2, rank + dim_arg - 1)
    2480                 :             :      for (;;)
    2481                 :             :        {
    2482                 :             :          extent = gfc_extent(i)
    2483                 :             :          ml = m
    2484                 :             :          m  = m/extent
    2485                 :             :          if (i >= min_var)
    2486                 :             :            goto exit_label
    2487                 :             :          i++
    2488                 :             :        }
    2489                 :             :      exit_label:
    2490                 :             :      sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
    2491                 :             :                                        : m + lcobound(corank)
    2492                 :             :   */
    2493                 :             : 
    2494                 :             :   /* this_image () - 1.  */
    2495                 :         144 :   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
    2496                 :             :                              integer_zero_node);
    2497                 :         144 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
    2498                 :         144 :                          fold_convert (type, tmp), build_int_cst (type, 1));
    2499                 :         144 :   if (corank == 1)
    2500                 :             :     {
    2501                 :             :       /* sub(1) = m + lcobound(corank).  */
    2502                 :           4 :       lbound = gfc_conv_descriptor_lbound_get (desc,
    2503                 :           4 :                         build_int_cst (TREE_TYPE (gfc_array_index_type),
    2504                 :           4 :                                        corank+rank-1));
    2505                 :           4 :       lbound = fold_convert (type, lbound);
    2506                 :           4 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
    2507                 :             : 
    2508                 :           4 :       se->expr = tmp;
    2509                 :           4 :       return;
    2510                 :             :     }
    2511                 :             : 
    2512                 :         140 :   m = gfc_create_var (type, NULL);
    2513                 :         140 :   ml = gfc_create_var (type, NULL);
    2514                 :         140 :   loop_var = gfc_create_var (integer_type_node, NULL);
    2515                 :         140 :   min_var = gfc_create_var (integer_type_node, NULL);
    2516                 :             : 
    2517                 :             :   /* m = this_image () - 1.  */
    2518                 :         140 :   gfc_add_modify (&se->pre, m, tmp);
    2519                 :             : 
    2520                 :             :   /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */
    2521                 :         140 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
    2522                 :             :                          fold_convert (integer_type_node, dim_arg),
    2523                 :         140 :                          build_int_cst (integer_type_node, rank - 1));
    2524                 :         140 :   tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
    2525                 :         140 :                          build_int_cst (integer_type_node, rank + corank - 2),
    2526                 :             :                          tmp);
    2527                 :         140 :   gfc_add_modify (&se->pre, min_var, tmp);
    2528                 :             : 
    2529                 :             :   /* i = rank.  */
    2530                 :         140 :   tmp = build_int_cst (integer_type_node, rank);
    2531                 :         140 :   gfc_add_modify (&se->pre, loop_var, tmp);
    2532                 :             : 
    2533                 :         140 :   exit_label = gfc_build_label_decl (NULL_TREE);
    2534                 :         140 :   TREE_USED (exit_label) = 1;
    2535                 :             : 
    2536                 :             :   /* Loop body.  */
    2537                 :         140 :   gfc_init_block (&loop);
    2538                 :             : 
    2539                 :             :   /* ml = m.  */
    2540                 :         140 :   gfc_add_modify (&loop, ml, m);
    2541                 :             : 
    2542                 :             :   /* extent = ...  */
    2543                 :         140 :   lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
    2544                 :         140 :   ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
    2545                 :         140 :   extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
    2546                 :         140 :   extent = fold_convert (type, extent);
    2547                 :             : 
    2548                 :             :   /* m = m/extent.  */
    2549                 :         140 :   gfc_add_modify (&loop, m,
    2550                 :             :                   fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
    2551                 :             :                           m, extent));
    2552                 :             : 
    2553                 :             :   /* Exit condition:  if (i >= min_var) goto exit_label.  */
    2554                 :         140 :   cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, loop_var,
    2555                 :             :                   min_var);
    2556                 :         140 :   tmp = build1_v (GOTO_EXPR, exit_label);
    2557                 :         140 :   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
    2558                 :             :                          build_empty_stmt (input_location));
    2559                 :         140 :   gfc_add_expr_to_block (&loop, tmp);
    2560                 :             : 
    2561                 :             :   /* Increment loop variable: i++.  */
    2562                 :         140 :   gfc_add_modify (&loop, loop_var,
    2563                 :             :                   fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
    2564                 :             :                                    loop_var,
    2565                 :         140 :                                    build_int_cst (integer_type_node, 1)));
    2566                 :             : 
    2567                 :             :   /* Making the loop... actually loop!  */
    2568                 :         140 :   tmp = gfc_finish_block (&loop);
    2569                 :         140 :   tmp = build1_v (LOOP_EXPR, tmp);
    2570                 :         140 :   gfc_add_expr_to_block (&se->pre, tmp);
    2571                 :             : 
    2572                 :             :   /* The exit label.  */
    2573                 :         140 :   tmp = build1_v (LABEL_EXPR, exit_label);
    2574                 :         140 :   gfc_add_expr_to_block (&se->pre, tmp);
    2575                 :             : 
    2576                 :             :   /*  sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
    2577                 :             :                                       : m + lcobound(corank) */
    2578                 :             : 
    2579                 :         140 :   cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node, dim_arg,
    2580                 :         140 :                           build_int_cst (TREE_TYPE (dim_arg), corank));
    2581                 :             : 
    2582                 :         140 :   lbound = gfc_conv_descriptor_lbound_get (desc,
    2583                 :             :                 fold_build2_loc (input_location, PLUS_EXPR,
    2584                 :             :                                  gfc_array_index_type, dim_arg,
    2585                 :         140 :                                  build_int_cst (TREE_TYPE (dim_arg), rank-1)));
    2586                 :         140 :   lbound = fold_convert (type, lbound);
    2587                 :             : 
    2588                 :         140 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
    2589                 :             :                          fold_build2_loc (input_location, MULT_EXPR, type,
    2590                 :             :                                           m, extent));
    2591                 :         140 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
    2592                 :             : 
    2593                 :         140 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
    2594                 :             :                               fold_build2_loc (input_location, PLUS_EXPR, type,
    2595                 :             :                                                m, lbound));
    2596                 :             : }
    2597                 :             : 
    2598                 :             : 
    2599                 :             : /* Convert a call to image_status.  */
    2600                 :             : 
    2601                 :             : static void
    2602                 :          16 : conv_intrinsic_image_status (gfc_se *se, gfc_expr *expr)
    2603                 :             : {
    2604                 :          16 :   unsigned int num_args;
    2605                 :          16 :   tree *args, tmp;
    2606                 :             : 
    2607                 :          16 :   num_args = gfc_intrinsic_argument_list_length (expr);
    2608                 :          16 :   args = XALLOCAVEC (tree, num_args);
    2609                 :          16 :   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
    2610                 :             :   /* In args[0] the number of the image the status is desired for has to be
    2611                 :             :      given.  */
    2612                 :             : 
    2613                 :          16 :   if (flag_coarray == GFC_FCOARRAY_SINGLE)
    2614                 :             :     {
    2615                 :           0 :       tree arg;
    2616                 :           0 :       arg = gfc_evaluate_now (args[0], &se->pre);
    2617                 :           0 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    2618                 :             :                              fold_convert (integer_type_node, arg),
    2619                 :             :                              integer_one_node);
    2620                 :           0 :       tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
    2621                 :             :                              tmp, integer_zero_node,
    2622                 :             :                              build_int_cst (integer_type_node,
    2623                 :           0 :                                             GFC_STAT_STOPPED_IMAGE));
    2624                 :             :     }
    2625                 :          16 :   else if (flag_coarray == GFC_FCOARRAY_LIB)
    2626                 :          16 :     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_image_status, 2,
    2627                 :          16 :                                args[0], build_int_cst (integer_type_node, -1));
    2628                 :             :   else
    2629                 :           0 :     gcc_unreachable ();
    2630                 :             : 
    2631                 :          16 :   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
    2632                 :          16 : }
    2633                 :             : 
    2634                 :             : static void
    2635                 :          31 : conv_intrinsic_team_number (gfc_se *se, gfc_expr *expr)
    2636                 :             : {
    2637                 :          31 :   unsigned int num_args;
    2638                 :             : 
    2639                 :          31 :   tree *args, tmp;
    2640                 :             : 
    2641                 :          31 :   num_args = gfc_intrinsic_argument_list_length (expr);
    2642                 :          31 :   args = XALLOCAVEC (tree, num_args);
    2643                 :          31 :   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
    2644                 :             : 
    2645                 :          31 :   if (flag_coarray ==
    2646                 :          30 :       GFC_FCOARRAY_SINGLE && expr->value.function.actual->expr)
    2647                 :             :     {
    2648                 :           0 :       tree arg;
    2649                 :             : 
    2650                 :           0 :       arg = gfc_evaluate_now (args[0], &se->pre);
    2651                 :           0 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    2652                 :             :                              fold_convert (integer_type_node, arg),
    2653                 :             :                              integer_one_node);
    2654                 :           0 :       tmp = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
    2655                 :             :                              tmp, integer_zero_node,
    2656                 :             :                              build_int_cst (integer_type_node,
    2657                 :           0 :                                             GFC_STAT_STOPPED_IMAGE));
    2658                 :           0 :     }
    2659                 :          31 :   else if (flag_coarray == GFC_FCOARRAY_SINGLE)
    2660                 :             :     {
    2661                 :             :       // the value -1 represents that no team has been created yet
    2662                 :          30 :       tmp = build_int_cst (integer_type_node, -1);
    2663                 :             :     }
    2664                 :           1 :   else if (flag_coarray == GFC_FCOARRAY_LIB && expr->value.function.actual->expr)
    2665                 :           0 :     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
    2666                 :           0 :                                args[0], build_int_cst (integer_type_node, -1));
    2667                 :           1 :   else if (flag_coarray == GFC_FCOARRAY_LIB)
    2668                 :           1 :     tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_team_number, 1,
    2669                 :           1 :                 integer_zero_node, build_int_cst (integer_type_node, -1));
    2670                 :             :   else
    2671                 :           0 :     gcc_unreachable ();
    2672                 :             : 
    2673                 :          31 :   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
    2674                 :          31 : }
    2675                 :             : 
    2676                 :             : 
    2677                 :             : static void
    2678                 :         152 : trans_image_index (gfc_se * se, gfc_expr *expr)
    2679                 :             : {
    2680                 :         152 :   tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
    2681                 :             :        tmp, invalid_bound;
    2682                 :         152 :   gfc_se argse, subse;
    2683                 :         152 :   int rank, corank, codim;
    2684                 :             : 
    2685                 :         152 :   type = gfc_get_int_type (gfc_default_integer_kind);
    2686                 :         152 :   corank = gfc_get_corank (expr->value.function.actual->expr);
    2687                 :         152 :   rank = expr->value.function.actual->expr->rank;
    2688                 :             : 
    2689                 :             :   /* Obtain the descriptor of the COARRAY.  */
    2690                 :         152 :   gfc_init_se (&argse, NULL);
    2691                 :         152 :   argse.want_coarray = 1;
    2692                 :         152 :   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
    2693                 :         152 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    2694                 :         152 :   gfc_add_block_to_block (&se->post, &argse.post);
    2695                 :         152 :   desc = argse.expr;
    2696                 :             : 
    2697                 :             :   /* Obtain a handle to the SUB argument.  */
    2698                 :         152 :   gfc_init_se (&subse, NULL);
    2699                 :         152 :   gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
    2700                 :         152 :   gfc_add_block_to_block (&se->pre, &subse.pre);
    2701                 :         152 :   gfc_add_block_to_block (&se->post, &subse.post);
    2702                 :         152 :   subdesc = build_fold_indirect_ref_loc (input_location,
    2703                 :             :                         gfc_conv_descriptor_data_get (subse.expr));
    2704                 :             : 
    2705                 :             :   /* Fortran 2008 does not require that the values remain in the cobounds,
    2706                 :             :      thus we need explicitly check this - and return 0 if they are exceeded.  */
    2707                 :             : 
    2708                 :         152 :   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
    2709                 :         152 :   tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
    2710                 :         152 :   invalid_bound = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    2711                 :             :                                  fold_convert (gfc_array_index_type, tmp),
    2712                 :             :                                  lbound);
    2713                 :             : 
    2714                 :         352 :   for (codim = corank + rank - 2; codim >= rank; codim--)
    2715                 :             :     {
    2716                 :         200 :       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
    2717                 :         200 :       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
    2718                 :         200 :       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
    2719                 :         200 :       cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    2720                 :             :                               fold_convert (gfc_array_index_type, tmp),
    2721                 :             :                               lbound);
    2722                 :         200 :       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    2723                 :             :                                        logical_type_node, invalid_bound, cond);
    2724                 :         200 :       cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    2725                 :             :                               fold_convert (gfc_array_index_type, tmp),
    2726                 :             :                               ubound);
    2727                 :         200 :       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    2728                 :             :                                        logical_type_node, invalid_bound, cond);
    2729                 :             :     }
    2730                 :             : 
    2731                 :         152 :   invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
    2732                 :             : 
    2733                 :             :   /* See Fortran 2008, C.10 for the following algorithm.  */
    2734                 :             : 
    2735                 :             :   /* coindex = sub(corank) - lcobound(n).  */
    2736                 :         152 :   coindex = fold_convert (gfc_array_index_type,
    2737                 :             :                           gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
    2738                 :             :                                                NULL));
    2739                 :         152 :   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
    2740                 :         152 :   coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    2741                 :             :                              fold_convert (gfc_array_index_type, coindex),
    2742                 :             :                              lbound);
    2743                 :             : 
    2744                 :         352 :   for (codim = corank + rank - 2; codim >= rank; codim--)
    2745                 :             :     {
    2746                 :         200 :       tree extent, ubound;
    2747                 :             : 
    2748                 :             :       /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
    2749                 :         200 :       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
    2750                 :         200 :       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
    2751                 :         200 :       extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
    2752                 :             : 
    2753                 :             :       /* coindex *= extent.  */
    2754                 :         200 :       coindex = fold_build2_loc (input_location, MULT_EXPR,
    2755                 :             :                                  gfc_array_index_type, coindex, extent);
    2756                 :             : 
    2757                 :             :       /* coindex += sub(codim).  */
    2758                 :         200 :       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
    2759                 :         200 :       coindex = fold_build2_loc (input_location, PLUS_EXPR,
    2760                 :             :                                  gfc_array_index_type, coindex,
    2761                 :             :                                  fold_convert (gfc_array_index_type, tmp));
    2762                 :             : 
    2763                 :             :       /* coindex -= lbound(codim).  */
    2764                 :         200 :       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
    2765                 :         200 :       coindex = fold_build2_loc (input_location, MINUS_EXPR,
    2766                 :             :                                  gfc_array_index_type, coindex, lbound);
    2767                 :             :     }
    2768                 :             : 
    2769                 :         152 :   coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
    2770                 :             :                              fold_convert(type, coindex),
    2771                 :         152 :                              build_int_cst (type, 1));
    2772                 :             : 
    2773                 :             :   /* Return 0 if "coindex" exceeds num_images().  */
    2774                 :             : 
    2775                 :         152 :   if (flag_coarray == GFC_FCOARRAY_SINGLE)
    2776                 :         108 :     num_images = build_int_cst (type, 1);
    2777                 :             :   else
    2778                 :             :     {
    2779                 :          44 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
    2780                 :             :                                  integer_zero_node,
    2781                 :          44 :                                  build_int_cst (integer_type_node, -1));
    2782                 :          44 :       num_images = fold_convert (type, tmp);
    2783                 :             :     }
    2784                 :             : 
    2785                 :         152 :   tmp = gfc_create_var (type, NULL);
    2786                 :         152 :   gfc_add_modify (&se->pre, tmp, coindex);
    2787                 :             : 
    2788                 :         152 :   cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, tmp,
    2789                 :             :                           num_images);
    2790                 :         152 :   cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, logical_type_node,
    2791                 :             :                           cond,
    2792                 :             :                           fold_convert (logical_type_node, invalid_bound));
    2793                 :         152 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
    2794                 :         152 :                               build_int_cst (type, 0), tmp);
    2795                 :         152 : }
    2796                 :             : 
    2797                 :             : static void
    2798                 :         395 : trans_num_images (gfc_se * se, gfc_expr *expr)
    2799                 :             : {
    2800                 :         395 :   tree tmp, distance, failed;
    2801                 :         395 :   gfc_se argse;
    2802                 :             : 
    2803                 :         395 :   if (expr->value.function.actual->expr)
    2804                 :             :     {
    2805                 :           3 :       gfc_init_se (&argse, NULL);
    2806                 :           3 :       gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
    2807                 :           3 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2808                 :           3 :       gfc_add_block_to_block (&se->post, &argse.post);
    2809                 :           3 :       distance = fold_convert (integer_type_node, argse.expr);
    2810                 :             :     }
    2811                 :             :   else
    2812                 :         392 :     distance = integer_zero_node;
    2813                 :             : 
    2814                 :         395 :   if (expr->value.function.actual->next->expr)
    2815                 :             :     {
    2816                 :           2 :       gfc_init_se (&argse, NULL);
    2817                 :           2 :       gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
    2818                 :           2 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2819                 :           2 :       gfc_add_block_to_block (&se->post, &argse.post);
    2820                 :           2 :       failed = fold_convert (integer_type_node, argse.expr);
    2821                 :             :     }
    2822                 :             :   else
    2823                 :         393 :     failed = build_int_cst (integer_type_node, -1);
    2824                 :         395 :   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
    2825                 :             :                              distance, failed);
    2826                 :         395 :   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
    2827                 :         395 : }
    2828                 :             : 
    2829                 :             : 
    2830                 :             : static void
    2831                 :        9335 : gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
    2832                 :             : {
    2833                 :        9335 :   gfc_se argse;
    2834                 :             : 
    2835                 :        9335 :   gfc_init_se (&argse, NULL);
    2836                 :        9335 :   argse.data_not_needed = 1;
    2837                 :        9335 :   argse.descriptor_only = 1;
    2838                 :             : 
    2839                 :        9335 :   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
    2840                 :        9335 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    2841                 :        9335 :   gfc_add_block_to_block (&se->post, &argse.post);
    2842                 :             : 
    2843                 :        9335 :   se->expr = gfc_conv_descriptor_rank (argse.expr);
    2844                 :        9335 :   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
    2845                 :             :                            se->expr);
    2846                 :        9335 : }
    2847                 :             : 
    2848                 :             : 
    2849                 :             : static void
    2850                 :         525 : gfc_conv_intrinsic_is_contiguous (gfc_se * se, gfc_expr * expr)
    2851                 :             : {
    2852                 :         525 :   gfc_expr *arg;
    2853                 :         525 :   arg = expr->value.function.actual->expr;
    2854                 :         525 :   gfc_conv_is_contiguous_expr (se, arg);
    2855                 :         525 :   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
    2856                 :         525 : }
    2857                 :             : 
    2858                 :             : /* This function does the work for gfc_conv_intrinsic_is_contiguous,
    2859                 :             :    plus it can be called directly.  */
    2860                 :             : 
    2861                 :             : void
    2862                 :        1815 : gfc_conv_is_contiguous_expr (gfc_se *se, gfc_expr *arg)
    2863                 :             : {
    2864                 :        1815 :   gfc_ss *ss;
    2865                 :        1815 :   gfc_se argse;
    2866                 :        1815 :   tree desc, tmp, stride, extent, cond;
    2867                 :        1815 :   int i;
    2868                 :        1815 :   tree fncall0;
    2869                 :        1815 :   gfc_array_spec *as;
    2870                 :             : 
    2871                 :        1815 :   if (arg->ts.type == BT_CLASS)
    2872                 :           0 :     gfc_add_class_array_ref (arg);
    2873                 :             : 
    2874                 :        1815 :   ss = gfc_walk_expr (arg);
    2875                 :        1815 :   gcc_assert (ss != gfc_ss_terminator);
    2876                 :        1815 :   gfc_init_se (&argse, NULL);
    2877                 :        1815 :   argse.data_not_needed = 1;
    2878                 :        1815 :   gfc_conv_expr_descriptor (&argse, arg);
    2879                 :             : 
    2880                 :        1815 :   as = gfc_get_full_arrayspec_from_expr (arg);
    2881                 :             : 
    2882                 :             :   /* Create:  stride[0] == 1 && stride[1] == extend[0]*stride[0] && ...
    2883                 :             :      Note in addition that zero-sized arrays don't count as contiguous.  */
    2884                 :             : 
    2885                 :        1815 :   if (as && as->type == AS_ASSUMED_RANK)
    2886                 :             :     {
    2887                 :             :       /* Build the call to is_contiguous0.  */
    2888                 :         243 :       argse.want_pointer = 1;
    2889                 :         243 :       gfc_conv_expr_descriptor (&argse, arg);
    2890                 :         243 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2891                 :         243 :       gfc_add_block_to_block (&se->post, &argse.post);
    2892                 :         243 :       desc = gfc_evaluate_now (argse.expr, &se->pre);
    2893                 :         243 :       fncall0 = build_call_expr_loc (input_location,
    2894                 :             :                                      gfor_fndecl_is_contiguous0, 1, desc);
    2895                 :         243 :       se->expr = fncall0;
    2896                 :         243 :       se->expr = convert (logical_type_node, se->expr);
    2897                 :             :     }
    2898                 :             :   else
    2899                 :             :     {
    2900                 :        1572 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2901                 :        1572 :       gfc_add_block_to_block (&se->post, &argse.post);
    2902                 :        1572 :       desc = gfc_evaluate_now (argse.expr, &se->pre);
    2903                 :             : 
    2904                 :        1572 :       stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[0]);
    2905                 :        1572 :       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
    2906                 :        1572 :                               stride, build_int_cst (TREE_TYPE (stride), 1));
    2907                 :             : 
    2908                 :        1876 :       for (i = 0; i < arg->rank - 1; i++)
    2909                 :             :         {
    2910                 :         304 :           tmp = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
    2911                 :         304 :           extent = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
    2912                 :         304 :           extent = fold_build2_loc (input_location, MINUS_EXPR,
    2913                 :             :                                     gfc_array_index_type, extent, tmp);
    2914                 :         304 :           extent = fold_build2_loc (input_location, PLUS_EXPR,
    2915                 :             :                                     gfc_array_index_type, extent,
    2916                 :             :                                     gfc_index_one_node);
    2917                 :         304 :           tmp = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i]);
    2918                 :         304 :           tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp),
    2919                 :             :                                  tmp, extent);
    2920                 :         304 :           stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[i+1]);
    2921                 :         304 :           tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
    2922                 :             :                                  stride, tmp);
    2923                 :         304 :           cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    2924                 :             :                                   boolean_type_node, cond, tmp);
    2925                 :             :         }
    2926                 :        1572 :       se->expr = cond;
    2927                 :             :     }
    2928                 :        1815 : }
    2929                 :             : 
    2930                 :             : 
    2931                 :             : /* Evaluate a single upper or lower bound.  */
    2932                 :             : /* TODO: bound intrinsic generates way too much unnecessary code.  */
    2933                 :             : 
    2934                 :             : static void
    2935                 :       11214 : gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, enum gfc_isym_id op)
    2936                 :             : {
    2937                 :       11214 :   gfc_actual_arglist *arg;
    2938                 :       11214 :   gfc_actual_arglist *arg2;
    2939                 :       11214 :   tree desc;
    2940                 :       11214 :   tree type;
    2941                 :       11214 :   tree bound;
    2942                 :       11214 :   tree tmp;
    2943                 :       11214 :   tree cond, cond1;
    2944                 :       11214 :   tree ubound;
    2945                 :       11214 :   tree lbound;
    2946                 :       11214 :   tree size;
    2947                 :       11214 :   gfc_se argse;
    2948                 :       11214 :   gfc_array_spec * as;
    2949                 :       11214 :   bool assumed_rank_lb_one;
    2950                 :             : 
    2951                 :       11214 :   arg = expr->value.function.actual;
    2952                 :       11214 :   arg2 = arg->next;
    2953                 :             : 
    2954                 :       11214 :   if (se->ss)
    2955                 :             :     {
    2956                 :             :       /* Create an implicit second parameter from the loop variable.  */
    2957                 :        3027 :       gcc_assert (!arg2->expr || op == GFC_ISYM_SHAPE);
    2958                 :        3027 :       gcc_assert (se->loop->dimen == 1);
    2959                 :        3027 :       gcc_assert (se->ss->info->expr == expr);
    2960                 :        3027 :       gfc_advance_se_ss_chain (se);
    2961                 :        3027 :       bound = se->loop->loopvar[0];
    2962                 :        3027 :       bound = fold_build2_loc (input_location, MINUS_EXPR,
    2963                 :             :                                gfc_array_index_type, bound,
    2964                 :             :                                se->loop->from[0]);
    2965                 :             :     }
    2966                 :             :   else
    2967                 :             :     {
    2968                 :             :       /* use the passed argument.  */
    2969                 :        8187 :       gcc_assert (arg2->expr);
    2970                 :        8187 :       gfc_init_se (&argse, NULL);
    2971                 :        8187 :       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
    2972                 :        8187 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    2973                 :        8187 :       bound = argse.expr;
    2974                 :             :       /* Convert from one based to zero based.  */
    2975                 :        8187 :       bound = fold_build2_loc (input_location, MINUS_EXPR,
    2976                 :             :                                gfc_array_index_type, bound,
    2977                 :             :                                gfc_index_one_node);
    2978                 :             :     }
    2979                 :             : 
    2980                 :             :   /* TODO: don't re-evaluate the descriptor on each iteration.  */
    2981                 :             :   /* Get a descriptor for the first parameter.  */
    2982                 :       11214 :   gfc_init_se (&argse, NULL);
    2983                 :       11214 :   gfc_conv_expr_descriptor (&argse, arg->expr);
    2984                 :       11214 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    2985                 :       11214 :   gfc_add_block_to_block (&se->post, &argse.post);
    2986                 :             : 
    2987                 :       11214 :   desc = argse.expr;
    2988                 :             : 
    2989                 :       11214 :   as = gfc_get_full_arrayspec_from_expr (arg->expr);
    2990                 :             : 
    2991                 :       11214 :   if (INTEGER_CST_P (bound))
    2992                 :             :     {
    2993                 :        8067 :       gcc_assert (op != GFC_ISYM_SHAPE);
    2994                 :        7830 :       if (((!as || as->type != AS_ASSUMED_RANK)
    2995                 :        7207 :            && wi::geu_p (wi::to_wide (bound),
    2996                 :        7207 :                          GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
    2997                 :       16134 :           || wi::gtu_p (wi::to_wide (bound), GFC_MAX_DIMENSIONS))
    2998                 :           0 :         gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
    2999                 :             :                    "dimension index",
    3000                 :             :                    (op == GFC_ISYM_UBOUND) ? "UBOUND" : "LBOUND",
    3001                 :             :                    &expr->where);
    3002                 :             :     }
    3003                 :             : 
    3004                 :       11214 :   if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
    3005                 :             :     {
    3006                 :        4007 :       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    3007                 :             :         {
    3008                 :         639 :           bound = gfc_evaluate_now (bound, &se->pre);
    3009                 :         639 :           cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3010                 :         639 :                                   bound, build_int_cst (TREE_TYPE (bound), 0));
    3011                 :         639 :           if (as && as->type == AS_ASSUMED_RANK)
    3012                 :         546 :             tmp = gfc_conv_descriptor_rank (desc);
    3013                 :             :           else
    3014                 :          93 :             tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
    3015                 :         639 :           tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    3016                 :         639 :                                  bound, fold_convert(TREE_TYPE (bound), tmp));
    3017                 :         639 :           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    3018                 :             :                                   logical_type_node, cond, tmp);
    3019                 :         639 :           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
    3020                 :             :                                    gfc_msg_fault);
    3021                 :             :         }
    3022                 :             :     }
    3023                 :             : 
    3024                 :             :   /* Take care of the lbound shift for assumed-rank arrays that are
    3025                 :             :      nonallocatable and nonpointers. Those have a lbound of 1.  */
    3026                 :       10740 :   assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
    3027                 :        6084 :                         && ((arg->expr->ts.type != BT_CLASS
    3028                 :        1909 :                              && !arg->expr->symtree->n.sym->attr.allocatable
    3029                 :        1909 :                              && !arg->expr->symtree->n.sym->attr.pointer)
    3030                 :         890 :                             || (arg->expr->ts.type == BT_CLASS
    3031                 :         168 :                              && !CLASS_DATA (arg->expr)->attr.allocatable
    3032                 :         168 :                              && !CLASS_DATA (arg->expr)->attr.class_pointer));
    3033                 :             : 
    3034                 :       11214 :   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
    3035                 :       11214 :   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
    3036                 :       11214 :   size = fold_build2_loc (input_location, MINUS_EXPR,
    3037                 :             :                           gfc_array_index_type, ubound, lbound);
    3038                 :       11214 :   size = fold_build2_loc (input_location, PLUS_EXPR,
    3039                 :             :                           gfc_array_index_type, size, gfc_index_one_node);
    3040                 :             : 
    3041                 :             :   /* 13.14.53: Result value for LBOUND
    3042                 :             : 
    3043                 :             :      Case (i): For an array section or for an array expression other than a
    3044                 :             :                whole array or array structure component, LBOUND(ARRAY, DIM)
    3045                 :             :                has the value 1.  For a whole array or array structure
    3046                 :             :                component, LBOUND(ARRAY, DIM) has the value:
    3047                 :             :                  (a) equal to the lower bound for subscript DIM of ARRAY if
    3048                 :             :                      dimension DIM of ARRAY does not have extent zero
    3049                 :             :                      or if ARRAY is an assumed-size array of rank DIM,
    3050                 :             :               or (b) 1 otherwise.
    3051                 :             : 
    3052                 :             :      13.14.113: Result value for UBOUND
    3053                 :             : 
    3054                 :             :      Case (i): For an array section or for an array expression other than a
    3055                 :             :                whole array or array structure component, UBOUND(ARRAY, DIM)
    3056                 :             :                has the value equal to the number of elements in the given
    3057                 :             :                dimension; otherwise, it has a value equal to the upper bound
    3058                 :             :                for subscript DIM of ARRAY if dimension DIM of ARRAY does
    3059                 :             :                not have size zero and has value zero if dimension DIM has
    3060                 :             :                size zero.  */
    3061                 :             : 
    3062                 :       11214 :   if (op == GFC_ISYM_LBOUND && assumed_rank_lb_one)
    3063                 :         520 :     se->expr = gfc_index_one_node;
    3064                 :       10694 :   else if (as)
    3065                 :             :     {
    3066                 :       10220 :       if (op == GFC_ISYM_UBOUND)
    3067                 :             :         {
    3068                 :        4331 :           cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3069                 :             :                                   size, gfc_index_zero_node);
    3070                 :        8070 :           se->expr = fold_build3_loc (input_location, COND_EXPR,
    3071                 :             :                                       gfc_array_index_type, cond,
    3072                 :             :                                       (assumed_rank_lb_one ? size : ubound),
    3073                 :             :                                       gfc_index_zero_node);
    3074                 :             :         }
    3075                 :        5889 :       else if (op == GFC_ISYM_LBOUND)
    3076                 :             :         {
    3077                 :        4707 :           cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3078                 :             :                                   size, gfc_index_zero_node);
    3079                 :        4707 :           if (as->type == AS_ASSUMED_SIZE)
    3080                 :             :             {
    3081                 :          98 :               cond1 = fold_build2_loc (input_location, EQ_EXPR,
    3082                 :             :                                        logical_type_node, bound,
    3083                 :          98 :                                        build_int_cst (TREE_TYPE (bound),
    3084                 :          98 :                                                       arg->expr->rank - 1));
    3085                 :          98 :               cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
    3086                 :             :                                       logical_type_node, cond, cond1);
    3087                 :             :             }
    3088                 :        4707 :           se->expr = fold_build3_loc (input_location, COND_EXPR,
    3089                 :             :                                       gfc_array_index_type, cond,
    3090                 :             :                                       lbound, gfc_index_one_node);
    3091                 :             :         }
    3092                 :        1182 :       else if (op == GFC_ISYM_SHAPE)
    3093                 :        1182 :         se->expr = size;
    3094                 :             :       else
    3095                 :           0 :         gcc_unreachable ();
    3096                 :             : 
    3097                 :             :       /* According to F2018 16.9.172, para 5, an assumed rank object,
    3098                 :             :          argument associated with and assumed size array, has the ubound
    3099                 :             :          of the final dimension set to -1 and UBOUND must return this.
    3100                 :             :          Similarly for the SHAPE intrinsic.  */
    3101                 :       10220 :       if (op != GFC_ISYM_LBOUND && assumed_rank_lb_one)
    3102                 :             :         {
    3103                 :         763 :           tree minus_one = build_int_cst (gfc_array_index_type, -1);
    3104                 :         763 :           tree rank = fold_convert (gfc_array_index_type,
    3105                 :             :                                     gfc_conv_descriptor_rank (desc));
    3106                 :         763 :           rank = fold_build2_loc (input_location, PLUS_EXPR,
    3107                 :             :                                   gfc_array_index_type, rank, minus_one);
    3108                 :             : 
    3109                 :             :           /* Fix the expression to stop it from becoming even more
    3110                 :             :              complicated.  */
    3111                 :         763 :           se->expr = gfc_evaluate_now (se->expr, &se->pre);
    3112                 :             : 
    3113                 :             :           /* Descriptors for assumed-size arrays have ubound = -1
    3114                 :             :              in the last dimension.  */
    3115                 :         763 :           cond1 = fold_build2_loc (input_location, EQ_EXPR,
    3116                 :             :                                    logical_type_node, ubound, minus_one);
    3117                 :         763 :           cond = fold_build2_loc (input_location, EQ_EXPR,
    3118                 :             :                                   logical_type_node, bound, rank);
    3119                 :         763 :           cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    3120                 :             :                                   logical_type_node, cond, cond1);
    3121                 :         763 :           se->expr = fold_build3_loc (input_location, COND_EXPR,
    3122                 :             :                                       gfc_array_index_type, cond,
    3123                 :             :                                       minus_one, se->expr);
    3124                 :             :         }
    3125                 :             :     }
    3126                 :             :   else   /* as is null; this is an old-fashioned 1-based array.  */
    3127                 :             :     {
    3128                 :         474 :       if (op != GFC_ISYM_LBOUND)
    3129                 :             :         {
    3130                 :         372 :           se->expr = fold_build2_loc (input_location, MAX_EXPR,
    3131                 :             :                                       gfc_array_index_type, size,
    3132                 :             :                                       gfc_index_zero_node);
    3133                 :             :         }
    3134                 :             :       else
    3135                 :         102 :         se->expr = gfc_index_one_node;
    3136                 :             :     }
    3137                 :             : 
    3138                 :             : 
    3139                 :       11214 :   type = gfc_typenode_for_spec (&expr->ts);
    3140                 :       11214 :   se->expr = convert (type, se->expr);
    3141                 :       11214 : }
    3142                 :             : 
    3143                 :             : 
    3144                 :             : static void
    3145                 :         569 : conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
    3146                 :             : {
    3147                 :         569 :   gfc_actual_arglist *arg;
    3148                 :         569 :   gfc_actual_arglist *arg2;
    3149                 :         569 :   gfc_se argse;
    3150                 :         569 :   tree bound, resbound, resbound2, desc, cond, tmp;
    3151                 :         569 :   tree type;
    3152                 :         569 :   int corank;
    3153                 :             : 
    3154                 :         569 :   gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
    3155                 :             :               || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
    3156                 :             :               || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
    3157                 :             : 
    3158                 :         569 :   arg = expr->value.function.actual;
    3159                 :         569 :   arg2 = arg->next;
    3160                 :             : 
    3161                 :         569 :   gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
    3162                 :         569 :   corank = gfc_get_corank (arg->expr);
    3163                 :             : 
    3164                 :         569 :   gfc_init_se (&argse, NULL);
    3165                 :         569 :   argse.want_coarray = 1;
    3166                 :             : 
    3167                 :         569 :   gfc_conv_expr_descriptor (&argse, arg->expr);
    3168                 :         569 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    3169                 :         569 :   gfc_add_block_to_block (&se->post, &argse.post);
    3170                 :         569 :   desc = argse.expr;
    3171                 :             : 
    3172                 :         569 :   if (se->ss)
    3173                 :             :     {
    3174                 :             :       /* Create an implicit second parameter from the loop variable.  */
    3175                 :         179 :       gcc_assert (!arg2->expr);
    3176                 :         179 :       gcc_assert (corank > 0);
    3177                 :         179 :       gcc_assert (se->loop->dimen == 1);
    3178                 :         179 :       gcc_assert (se->ss->info->expr == expr);
    3179                 :             : 
    3180                 :         179 :       bound = se->loop->loopvar[0];
    3181                 :         358 :       bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
    3182                 :         179 :                                bound, gfc_rank_cst[arg->expr->rank]);
    3183                 :         179 :       gfc_advance_se_ss_chain (se);
    3184                 :             :     }
    3185                 :             :   else
    3186                 :             :     {
    3187                 :             :       /* use the passed argument.  */
    3188                 :         390 :       gcc_assert (arg2->expr);
    3189                 :         390 :       gfc_init_se (&argse, NULL);
    3190                 :         390 :       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
    3191                 :         390 :       gfc_add_block_to_block (&se->pre, &argse.pre);
    3192                 :         390 :       bound = argse.expr;
    3193                 :             : 
    3194                 :         390 :       if (INTEGER_CST_P (bound))
    3195                 :             :         {
    3196                 :         296 :           if (wi::ltu_p (wi::to_wide (bound), 1)
    3197                 :         592 :               || wi::gtu_p (wi::to_wide (bound),
    3198                 :         296 :                             GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
    3199                 :           0 :             gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
    3200                 :           0 :                        "dimension index", expr->value.function.isym->name,
    3201                 :             :                        &expr->where);
    3202                 :             :         }
    3203                 :          94 :       else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
    3204                 :             :         {
    3205                 :          36 :           bound = gfc_evaluate_now (bound, &se->pre);
    3206                 :          36 :           cond = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3207                 :          36 :                                   bound, build_int_cst (TREE_TYPE (bound), 1));
    3208                 :          36 :           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
    3209                 :          36 :           tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3210                 :             :                                  bound, tmp);
    3211                 :          36 :           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    3212                 :             :                                   logical_type_node, cond, tmp);
    3213                 :          36 :           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
    3214                 :             :                                    gfc_msg_fault);
    3215                 :             :         }
    3216                 :             : 
    3217                 :             : 
    3218                 :             :       /* Subtract 1 to get to zero based and add dimensions.  */
    3219                 :         390 :       switch (arg->expr->rank)
    3220                 :             :         {
    3221                 :          49 :         case 0:
    3222                 :          49 :           bound = fold_build2_loc (input_location, MINUS_EXPR,
    3223                 :             :                                    gfc_array_index_type, bound,
    3224                 :             :                                    gfc_index_one_node);
    3225                 :             :         case 1:
    3226                 :             :           break;
    3227                 :          36 :         default:
    3228                 :          36 :           bound = fold_build2_loc (input_location, PLUS_EXPR,
    3229                 :             :                                    gfc_array_index_type, bound,
    3230                 :          36 :                                    gfc_rank_cst[arg->expr->rank - 1]);
    3231                 :             :         }
    3232                 :             :     }
    3233                 :             : 
    3234                 :         569 :   resbound = gfc_conv_descriptor_lbound_get (desc, bound);
    3235                 :             : 
    3236                 :             :   /* Handle UCOBOUND with special handling of the last codimension.  */
    3237                 :         569 :   if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
    3238                 :             :     {
    3239                 :             :       /* Last codimension: For -fcoarray=single just return
    3240                 :             :          the lcobound - otherwise add
    3241                 :             :            ceiling (real (num_images ()) / real (size)) - 1
    3242                 :             :          = (num_images () + size - 1) / size - 1
    3243                 :             :          = (num_images - 1) / size(),
    3244                 :             :          where size is the product of the extent of all but the last
    3245                 :             :          codimension.  */
    3246                 :             : 
    3247                 :         185 :       if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
    3248                 :             :         {
    3249                 :          26 :           tree cosize;
    3250                 :             : 
    3251                 :          26 :           cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
    3252                 :          26 :           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
    3253                 :             :                                      2, integer_zero_node,
    3254                 :          26 :                                      build_int_cst (integer_type_node, -1));
    3255                 :          26 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    3256                 :             :                                  gfc_array_index_type,
    3257                 :             :                                  fold_convert (gfc_array_index_type, tmp),
    3258                 :          26 :                                  build_int_cst (gfc_array_index_type, 1));
    3259                 :          26 :           tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
    3260                 :             :                                  gfc_array_index_type, tmp,
    3261                 :             :                                  fold_convert (gfc_array_index_type, cosize));
    3262                 :          26 :           resbound = fold_build2_loc (input_location, PLUS_EXPR,
    3263                 :             :                                       gfc_array_index_type, resbound, tmp);
    3264                 :          26 :         }
    3265                 :         159 :       else if (flag_coarray != GFC_FCOARRAY_SINGLE)
    3266                 :             :         {
    3267                 :             :           /* ubound = lbound + num_images() - 1.  */
    3268                 :          21 :           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
    3269                 :             :                                      2, integer_zero_node,
    3270                 :          21 :                                      build_int_cst (integer_type_node, -1));
    3271                 :          21 :           tmp = fold_build2_loc (input_location, MINUS_EXPR,
    3272                 :             :                                  gfc_array_index_type,
    3273                 :             :                                  fold_convert (gfc_array_index_type, tmp),
    3274                 :          21 :                                  build_int_cst (gfc_array_index_type, 1));
    3275                 :          21 :           resbound = fold_build2_loc (input_location, PLUS_EXPR,
    3276                 :             :                                       gfc_array_index_type, resbound, tmp);
    3277                 :             :         }
    3278                 :             : 
    3279                 :         185 :       if (corank > 1)
    3280                 :             :         {
    3281                 :         131 :           cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    3282                 :             :                                   bound,
    3283                 :         131 :                                   build_int_cst (TREE_TYPE (bound),
    3284                 :         131 :                                                  arg->expr->rank + corank - 1));
    3285                 :             : 
    3286                 :         131 :           resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
    3287                 :         131 :           se->expr = fold_build3_loc (input_location, COND_EXPR,
    3288                 :             :                                       gfc_array_index_type, cond,
    3289                 :             :                                       resbound, resbound2);
    3290                 :             :         }
    3291                 :             :       else
    3292                 :          54 :         se->expr = resbound;
    3293                 :             :     }
    3294                 :             :   else
    3295                 :         384 :     se->expr = resbound;
    3296                 :             : 
    3297                 :         569 :   type = gfc_typenode_for_spec (&expr->ts);
    3298                 :         569 :   se->expr = convert (type, se->expr);
    3299                 :         569 : }
    3300                 :             : 
    3301                 :             : 
    3302                 :             : static void
    3303                 :        1660 : conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
    3304                 :             : {
    3305                 :        1660 :   gfc_actual_arglist *array_arg;
    3306                 :        1660 :   gfc_actual_arglist *dim_arg;
    3307                 :        1660 :   gfc_se argse;
    3308                 :        1660 :   tree desc, tmp;
    3309                 :             : 
    3310                 :        1660 :   array_arg = expr->value.function.actual;
    3311                 :        1660 :   dim_arg = array_arg->next;
    3312                 :             : 
    3313                 :        1660 :   gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
    3314                 :             : 
    3315                 :        1660 :   gfc_init_se (&argse, NULL);
    3316                 :        1660 :   gfc_conv_expr_descriptor (&argse, array_arg->expr);
    3317                 :        1660 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    3318                 :        1660 :   gfc_add_block_to_block (&se->post, &argse.post);
    3319                 :        1660 :   desc = argse.expr;
    3320                 :             : 
    3321                 :        1660 :   gcc_assert (dim_arg->expr);
    3322                 :        1660 :   gfc_init_se (&argse, NULL);
    3323                 :        1660 :   gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
    3324                 :        1660 :   gfc_add_block_to_block (&se->pre, &argse.pre);
    3325                 :        1660 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    3326                 :             :                          argse.expr, gfc_index_one_node);
    3327                 :        1660 :   se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
    3328                 :        1660 : }
    3329                 :             : 
    3330                 :             : static void
    3331                 :        7561 : gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
    3332                 :             : {
    3333                 :        7561 :   tree arg, cabs;
    3334                 :             : 
    3335                 :        7561 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    3336                 :             : 
    3337                 :        7561 :   switch (expr->value.function.actual->expr->ts.type)
    3338                 :             :     {
    3339                 :        6610 :     case BT_INTEGER:
    3340                 :        6610 :     case BT_REAL:
    3341                 :        6610 :       se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
    3342                 :             :                                   arg);
    3343                 :        6610 :       break;
    3344                 :             : 
    3345                 :         951 :     case BT_COMPLEX:
    3346                 :         951 :       cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
    3347                 :         951 :       se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
    3348                 :         951 :       break;
    3349                 :             : 
    3350                 :           0 :     default:
    3351                 :           0 :       gcc_unreachable ();
    3352                 :             :     }
    3353                 :        7561 : }
    3354                 :             : 
    3355                 :             : 
    3356                 :             : /* Create a complex value from one or two real components.  */
    3357                 :             : 
    3358                 :             : static void
    3359                 :         397 : gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
    3360                 :             : {
    3361                 :         397 :   tree real;
    3362                 :         397 :   tree imag;
    3363                 :         397 :   tree type;
    3364                 :         397 :   tree *args;
    3365                 :         397 :   unsigned int num_args;
    3366                 :             : 
    3367                 :         397 :   num_args = gfc_intrinsic_argument_list_length (expr);
    3368                 :         397 :   args = XALLOCAVEC (tree, num_args);
    3369                 :             : 
    3370                 :         397 :   type = gfc_typenode_for_spec (&expr->ts);
    3371                 :         397 :   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
    3372                 :         397 :   real = convert (TREE_TYPE (type), args[0]);
    3373                 :         397 :   if (both)
    3374                 :         354 :     imag = convert (TREE_TYPE (type), args[1]);
    3375                 :          43 :   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
    3376                 :             :     {
    3377                 :          30 :       imag = fold_build1_loc (input_location, IMAGPART_EXPR,
    3378                 :          30 :                               TREE_TYPE (TREE_TYPE (args[0])), args[0]);
    3379                 :          30 :       imag = convert (TREE_TYPE (type), imag);
    3380                 :             :     }
    3381                 :             :   else
    3382                 :          13 :     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
    3383                 :             : 
    3384                 :         397 :   se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
    3385                 :         397 : }
    3386                 :             : 
    3387                 :             : 
    3388                 :             : /* Remainder function MOD(A, P) = A - INT(A / P) * P
    3389                 :             :                       MODULO(A, P) = A - FLOOR (A / P) * P
    3390                 :             : 
    3391                 :             :    The obvious algorithms above are numerically instable for large
    3392                 :             :    arguments, hence these intrinsics are instead implemented via calls
    3393                 :             :    to the fmod family of functions.  It is the responsibility of the
    3394                 :             :    user to ensure that the second argument is non-zero.  */
    3395                 :             : 
    3396                 :             : static void
    3397                 :        2842 : gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
    3398                 :             : {
    3399                 :        2842 :   tree type;
    3400                 :        2842 :   tree tmp;
    3401                 :        2842 :   tree test;
    3402                 :        2842 :   tree test2;
    3403                 :        2842 :   tree fmod;
    3404                 :        2842 :   tree zero;
    3405                 :        2842 :   tree args[2];
    3406                 :             : 
    3407                 :        2842 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    3408                 :             : 
    3409                 :        2842 :   switch (expr->ts.type)
    3410                 :             :     {
    3411                 :        2719 :     case BT_INTEGER:
    3412                 :             :       /* Integer case is easy, we've got a builtin op.  */
    3413                 :        2719 :       type = TREE_TYPE (args[0]);
    3414                 :             : 
    3415                 :        2719 :       if (modulo)
    3416                 :         428 :        se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
    3417                 :             :                                    args[0], args[1]);
    3418                 :             :       else
    3419                 :        2291 :        se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
    3420                 :             :                                    args[0], args[1]);
    3421                 :        2719 :       break;
    3422                 :             : 
    3423                 :         123 :     case BT_REAL:
    3424                 :         123 :       fmod = NULL_TREE;
    3425                 :             :       /* Check if we have a builtin fmod.  */
    3426                 :         123 :       fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
    3427                 :             : 
    3428                 :             :       /* The builtin should always be available.  */
    3429                 :         123 :       gcc_assert (fmod != NULL_TREE);
    3430                 :             : 
    3431                 :         123 :       tmp = build_addr (fmod);
    3432                 :         123 :       se->expr = build_call_array_loc (input_location,
    3433                 :         123 :                                        TREE_TYPE (TREE_TYPE (fmod)),
    3434                 :             :                                        tmp, 2, args);
    3435                 :         123 :       if (modulo == 0)
    3436                 :         123 :         return;
    3437                 :             : 
    3438                 :          25 :       type = TREE_TYPE (args[0]);
    3439                 :             : 
    3440                 :          25 :       args[0] = gfc_evaluate_now (args[0], &se->pre);
    3441                 :          25 :       args[1] = gfc_evaluate_now (args[1], &se->pre);
    3442                 :             : 
    3443                 :             :       /* Definition:
    3444                 :             :          modulo = arg - floor (arg/arg2) * arg2
    3445                 :             : 
    3446                 :             :          In order to calculate the result accurately, we use the fmod
    3447                 :             :          function as follows.
    3448                 :             : 
    3449                 :             :          res = fmod (arg, arg2);
    3450                 :             :          if (res)
    3451                 :             :            {
    3452                 :             :              if ((arg < 0) xor (arg2 < 0))
    3453                 :             :                res += arg2;
    3454                 :             :            }
    3455                 :             :          else
    3456                 :             :            res = copysign (0., arg2);
    3457                 :             : 
    3458                 :             :          => As two nested ternary exprs:
    3459                 :             : 
    3460                 :             :          res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
    3461                 :             :                : copysign (0., arg2);
    3462                 :             : 
    3463                 :             :       */
    3464                 :             : 
    3465                 :          25 :       zero = gfc_build_const (type, integer_zero_node);
    3466                 :          25 :       tmp = gfc_evaluate_now (se->expr, &se->pre);
    3467                 :          25 :       if (!flag_signed_zeros)
    3468                 :             :         {
    3469                 :           1 :           test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3470                 :             :                                   args[0], zero);
    3471                 :           1 :           test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3472                 :             :                                    args[1], zero);
    3473                 :           1 :           test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
    3474                 :             :                                    logical_type_node, test, test2);
    3475                 :           1 :           test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    3476                 :             :                                   tmp, zero);
    3477                 :           1 :           test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
    3478                 :             :                                   logical_type_node, test, test2);
    3479                 :           1 :           test = gfc_evaluate_now (test, &se->pre);
    3480                 :           1 :           se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
    3481                 :             :                                       fold_build2_loc (input_location,
    3482                 :             :                                                        PLUS_EXPR,
    3483                 :             :                                                        type, tmp, args[1]),
    3484                 :             :                                       tmp);
    3485                 :             :         }
    3486                 :             :       else
    3487                 :             :         {
    3488                 :          24 :           tree expr1, copysign, cscall;
    3489                 :          24 :           copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
    3490                 :             :                                                       expr->ts.kind);
    3491                 :          24 :           test = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3492                 :             :                                   args[0], zero);
    3493                 :          24 :           test2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node,
    3494                 :             :                                    args[1], zero);
    3495                 :          24 :           test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
    3496                 :             :                                    logical_type_node, test, test2);
    3497                 :          24 :           expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
    3498                 :             :                                    fold_build2_loc (input_location,
    3499                 :             :                                                     PLUS_EXPR,
    3500                 :             :                                                     type, tmp, args[1]),
    3501                 :             :                                    tmp);
    3502                 :          24 :           test = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    3503                 :             :                                   tmp, zero);
    3504                 :          24 :           cscall = build_call_expr_loc (input_location, copysign, 2, zero,
    3505                 :             :                                         args[1]);
    3506                 :          24 :           se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
    3507                 :             :                                       expr1, cscall);
    3508                 :             :         }
    3509                 :             :       return;
    3510                 :             : 
    3511                 :           0 :     default:
    3512                 :           0 :       gcc_unreachable ();
    3513                 :             :     }
    3514                 :             : }
    3515                 :             : 
    3516                 :             : /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
    3517                 :             :    DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
    3518                 :             :    where the right shifts are logical (i.e. 0's are shifted in).
    3519                 :             :    Because SHIFT_EXPR's want shifts strictly smaller than the integral
    3520                 :             :    type width, we have to special-case both S == 0 and S == BITSIZE(J):
    3521                 :             :      DSHIFTL(I,J,0) = I
    3522                 :             :      DSHIFTL(I,J,BITSIZE) = J
    3523                 :             :      DSHIFTR(I,J,0) = J
    3524                 :             :      DSHIFTR(I,J,BITSIZE) = I.  */
    3525                 :             : 
    3526                 :             : static void
    3527                 :          60 : gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
    3528                 :             : {
    3529                 :          60 :   tree type, utype, stype, arg1, arg2, shift, res, left, right;
    3530                 :          60 :   tree args[3], cond, tmp;
    3531                 :          60 :   int bitsize;
    3532                 :             : 
    3533                 :          60 :   gfc_conv_intrinsic_function_args (se, expr, args, 3);
    3534                 :             : 
    3535                 :          60 :   gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
    3536                 :          60 :   type = TREE_TYPE (args[0]);
    3537                 :          60 :   bitsize = TYPE_PRECISION (type);
    3538                 :          60 :   utype = unsigned_type_for (type);
    3539                 :          60 :   stype = TREE_TYPE (args[2]);
    3540                 :             : 
    3541                 :          60 :   arg1 = gfc_evaluate_now (args[0], &se->pre);
    3542                 :          60 :   arg2 = gfc_evaluate_now (args[1], &se->pre);
    3543                 :          60 :   shift = gfc_evaluate_now (args[2], &se->pre);
    3544                 :             : 
    3545                 :             :   /* The generic case.  */
    3546                 :          60 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
    3547                 :             :                          build_int_cst (stype, bitsize), shift);
    3548                 :          90 :   left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    3549                 :             :                           arg1, dshiftl ? shift : tmp);
    3550                 :             : 
    3551                 :          90 :   right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
    3552                 :             :                            fold_convert (utype, arg2), dshiftl ? tmp : shift);
    3553                 :          60 :   right = fold_convert (type, right);
    3554                 :             : 
    3555                 :          60 :   res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
    3556                 :             : 
    3557                 :             :   /* Special cases.  */
    3558                 :          60 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
    3559                 :          60 :                           build_int_cst (stype, 0));
    3560                 :          90 :   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
    3561                 :             :                          dshiftl ? arg1 : arg2, res);
    3562                 :             : 
    3563                 :          60 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, shift,
    3564                 :             :                           build_int_cst (stype, bitsize));
    3565                 :          90 :   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
    3566                 :             :                          dshiftl ? arg2 : arg1, res);
    3567                 :             : 
    3568                 :          60 :   se->expr = res;
    3569                 :          60 : }
    3570                 :             : 
    3571                 :             : 
    3572                 :             : /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
    3573                 :             : 
    3574                 :             : static void
    3575                 :          96 : gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
    3576                 :             : {
    3577                 :          96 :   tree val;
    3578                 :          96 :   tree tmp;
    3579                 :          96 :   tree type;
    3580                 :          96 :   tree zero;
    3581                 :          96 :   tree args[2];
    3582                 :             : 
    3583                 :          96 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    3584                 :          96 :   type = TREE_TYPE (args[0]);
    3585                 :             : 
    3586                 :          96 :   val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
    3587                 :          96 :   val = gfc_evaluate_now (val, &se->pre);
    3588                 :             : 
    3589                 :          96 :   zero = gfc_build_const (type, integer_zero_node);
    3590                 :          96 :   tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, val, zero);
    3591                 :          96 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
    3592                 :          96 : }
    3593                 :             : 
    3594                 :             : 
    3595                 :             : /* SIGN(A, B) is absolute value of A times sign of B.
    3596                 :             :    The real value versions use library functions to ensure the correct
    3597                 :             :    handling of negative zero.  Integer case implemented as:
    3598                 :             :    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
    3599                 :             :   */
    3600                 :             : 
    3601                 :             : static void
    3602                 :         444 : gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
    3603                 :             : {
    3604                 :         444 :   tree tmp;
    3605                 :         444 :   tree type;
    3606                 :         444 :   tree args[2];
    3607                 :             : 
    3608                 :         444 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    3609                 :         444 :   if (expr->ts.type == BT_REAL)
    3610                 :             :     {
    3611                 :         182 :       tree abs;
    3612                 :             : 
    3613                 :         182 :       tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
    3614                 :         182 :       abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
    3615                 :             : 
    3616                 :             :       /* We explicitly have to ignore the minus sign. We do so by using
    3617                 :             :          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
    3618                 :         182 :       if (!flag_sign_zero
    3619                 :         218 :           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
    3620                 :             :         {
    3621                 :          12 :           tree cond, zero;
    3622                 :          12 :           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
    3623                 :          12 :           cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    3624                 :             :                                   args[1], zero);
    3625                 :          24 :           se->expr = fold_build3_loc (input_location, COND_EXPR,
    3626                 :          12 :                                   TREE_TYPE (args[0]), cond,
    3627                 :             :                                   build_call_expr_loc (input_location, abs, 1,
    3628                 :             :                                                        args[0]),
    3629                 :             :                                   build_call_expr_loc (input_location, tmp, 2,
    3630                 :             :                                                        args[0], args[1]));
    3631                 :             :         }
    3632                 :             :       else
    3633                 :         170 :         se->expr = build_call_expr_loc (input_location, tmp, 2,
    3634                 :             :                                         args[0], args[1]);
    3635                 :         182 :       return;
    3636                 :             :     }
    3637                 :             : 
    3638                 :             :   /* Having excluded floating point types, we know we are now dealing
    3639                 :             :      with signed integer types.  */
    3640                 :         262 :   type = TREE_TYPE (args[0]);
    3641                 :             : 
    3642                 :             :   /* Args[0] is used multiple times below.  */
    3643                 :         262 :   args[0] = gfc_evaluate_now (args[0], &se->pre);
    3644                 :             : 
    3645                 :             :   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
    3646                 :             :      the signs of A and B are the same, and of all ones if they differ.  */
    3647                 :         262 :   tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
    3648                 :         262 :   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
    3649                 :         262 :                          build_int_cst (type, TYPE_PRECISION (type) - 1));
    3650                 :         262 :   tmp = gfc_evaluate_now (tmp, &se->pre);
    3651                 :             : 
    3652                 :             :   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
    3653                 :             :      is all ones (i.e. -1).  */
    3654                 :         262 :   se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
    3655                 :             :                               fold_build2_loc (input_location, PLUS_EXPR,
    3656                 :             :                                                type, args[0], tmp), tmp);
    3657                 :             : }
    3658                 :             : 
    3659                 :             : 
    3660                 :             : /* Test for the presence of an optional argument.  */
    3661                 :             : 
    3662                 :             : static void
    3663                 :        4021 : gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
    3664                 :             : {
    3665                 :        4021 :   gfc_expr *arg;
    3666                 :             : 
    3667                 :        4021 :   arg = expr->value.function.actual->expr;
    3668                 :        4021 :   gcc_assert (arg->expr_type == EXPR_VARIABLE);
    3669                 :        4021 :   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
    3670                 :        4021 :   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
    3671                 :        4021 : }
    3672                 :             : 
    3673                 :             : 
    3674                 :             : /* Calculate the double precision product of two single precision values.  */
    3675                 :             : 
    3676                 :             : static void
    3677                 :          13 : gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
    3678                 :             : {
    3679                 :          13 :   tree type;
    3680                 :          13 :   tree args[2];
    3681                 :             : 
    3682                 :          13 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    3683                 :             : 
    3684                 :             :   /* Convert the args to double precision before multiplying.  */
    3685                 :          13 :   type = gfc_typenode_for_spec (&expr->ts);
    3686                 :          13 :   args[0] = convert (type, args[0]);
    3687                 :          13 :   args[1] = convert (type, args[1]);
    3688                 :          13 :   se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
    3689                 :             :                               args[1]);
    3690                 :          13 : }
    3691                 :             : 
    3692                 :             : 
    3693                 :             : /* Return a length one character string containing an ascii character.  */
    3694                 :             : 
    3695                 :             : static void
    3696                 :        2019 : gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
    3697                 :             : {
    3698                 :        2019 :   tree arg[2];
    3699                 :        2019 :   tree var;
    3700                 :        2019 :   tree type;
    3701                 :        2019 :   unsigned int num_args;
    3702                 :             : 
    3703                 :        2019 :   num_args = gfc_intrinsic_argument_list_length (expr);
    3704                 :        2019 :   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
    3705                 :             : 
    3706                 :        2019 :   type = gfc_get_char_type (expr->ts.kind);
    3707                 :        2019 :   var = gfc_create_var (type, "char");
    3708                 :             : 
    3709                 :        2019 :   arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
    3710                 :        2019 :   gfc_add_modify (&se->pre, var, arg[0]);
    3711                 :        2019 :   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
    3712                 :        2019 :   se->string_length = build_int_cst (gfc_charlen_type_node, 1);
    3713                 :        2019 : }
    3714                 :             : 
    3715                 :             : 
    3716                 :             : static void
    3717                 :           0 : gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
    3718                 :             : {
    3719                 :           0 :   tree var;
    3720                 :           0 :   tree len;
    3721                 :           0 :   tree tmp;
    3722                 :           0 :   tree cond;
    3723                 :           0 :   tree fndecl;
    3724                 :           0 :   tree *args;
    3725                 :           0 :   unsigned int num_args;
    3726                 :             : 
    3727                 :           0 :   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
    3728                 :           0 :   args = XALLOCAVEC (tree, num_args);
    3729                 :             : 
    3730                 :           0 :   var = gfc_create_var (pchar_type_node, "pstr");
    3731                 :           0 :   len = gfc_create_var (gfc_charlen_type_node, "len");
    3732                 :             : 
    3733                 :           0 :   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
    3734                 :           0 :   args[0] = gfc_build_addr_expr (NULL_TREE, var);
    3735                 :           0 :   args[1] = gfc_build_addr_expr (NULL_TREE, len);
    3736                 :             : 
    3737                 :           0 :   fndecl = build_addr (gfor_fndecl_ctime);
    3738                 :           0 :   tmp = build_call_array_loc (input_location,
    3739                 :           0 :                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
    3740                 :             :                           fndecl, num_args, args);
    3741                 :           0 :   gfc_add_expr_to_block (&se->pre, tmp);
    3742                 :             : 
    3743                 :             :   /* Free the temporary afterwards, if necessary.  */
    3744                 :           0 :   cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3745                 :           0 :                           len, build_int_cst (TREE_TYPE (len), 0));
    3746                 :           0 :   tmp = gfc_call_free (var);
    3747                 :           0 :   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    3748                 :           0 :   gfc_add_expr_to_block (&se->post, tmp);
    3749                 :             : 
    3750                 :           0 :   se->expr = var;
    3751                 :           0 :   se->string_length = len;
    3752                 :           0 : }
    3753                 :             : 
    3754                 :             : 
    3755                 :             : static void
    3756                 :           0 : gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
    3757                 :             : {
    3758                 :           0 :   tree var;
    3759                 :           0 :   tree len;
    3760                 :           0 :   tree tmp;
    3761                 :           0 :   tree cond;
    3762                 :           0 :   tree fndecl;
    3763                 :           0 :   tree *args;
    3764                 :           0 :   unsigned int num_args;
    3765                 :             : 
    3766                 :           0 :   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
    3767                 :           0 :   args = XALLOCAVEC (tree, num_args);
    3768                 :             : 
    3769                 :           0 :   var = gfc_create_var (pchar_type_node, "pstr");
    3770                 :           0 :   len = gfc_create_var (gfc_charlen_type_node, "len");
    3771                 :             : 
    3772                 :           0 :   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
    3773                 :           0 :   args[0] = gfc_build_addr_expr (NULL_TREE, var);
    3774                 :           0 :   args[1] = gfc_build_addr_expr (NULL_TREE, len);
    3775                 :             : 
    3776                 :           0 :   fndecl = build_addr (gfor_fndecl_fdate);
    3777                 :           0 :   tmp = build_call_array_loc (input_location,
    3778                 :           0 :                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
    3779                 :             :                           fndecl, num_args, args);
    3780                 :           0 :   gfc_add_expr_to_block (&se->pre, tmp);
    3781                 :             : 
    3782                 :             :   /* Free the temporary afterwards, if necessary.  */
    3783                 :           0 :   cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    3784                 :           0 :                           len, build_int_cst (TREE_TYPE (len), 0));
    3785                 :           0 :   tmp = gfc_call_free (var);
    3786                 :           0 :   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    3787                 :           0 :   gfc_add_expr_to_block (&se->post, tmp);
    3788                 :             : 
    3789                 :           0 :   se->expr = var;
    3790                 :           0 :   se->string_length = len;
    3791                 :           0 : }
    3792                 :             : 
    3793                 :             : 
    3794                 :             : /* Generate a direct call to free() for the FREE subroutine.  */
    3795                 :             : 
    3796                 :             : static tree
    3797                 :          10 : conv_intrinsic_free (gfc_code *code)
    3798                 :             : {
    3799                 :          10 :   stmtblock_t block;
    3800                 :          10 :   gfc_se argse;
    3801                 :          10 :   tree arg, call;
    3802                 :             : 
    3803                 :          10 :   gfc_init_se (&argse, NULL);
    3804                 :          10 :   gfc_conv_expr (&argse, code->ext.actual->expr);
    3805                 :          10 :   arg = fold_convert (ptr_type_node, argse.expr);
    3806                 :             : 
    3807                 :          10 :   gfc_init_block (&block);
    3808                 :          10 :   call = build_call_expr_loc (input_location,
    3809                 :             :                               builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
    3810                 :          10 :   gfc_add_expr_to_block (&block, call);
    3811                 :          10 :   return gfc_finish_block (&block);
    3812                 :             : }
    3813                 :             : 
    3814                 :             : 
    3815                 :             : /* Call the RANDOM_INIT library subroutine with a hidden argument for
    3816                 :             :    handling seeding on coarray images.  */
    3817                 :             : 
    3818                 :             : static tree
    3819                 :          90 : conv_intrinsic_random_init (gfc_code *code)
    3820                 :             : {
    3821                 :          90 :   stmtblock_t block;
    3822                 :          90 :   gfc_se se;
    3823                 :          90 :   tree arg1, arg2, tmp;
    3824                 :             :   /* On none coarray == lib compiles use LOGICAL(4) else regular LOGICAL.  */
    3825                 :          90 :   tree used_bool_type_node = flag_coarray == GFC_FCOARRAY_LIB
    3826                 :          90 :                              ? logical_type_node
    3827                 :          90 :                              : gfc_get_logical_type (4);
    3828                 :             : 
    3829                 :             :   /* Make the function call.  */
    3830                 :          90 :   gfc_init_block (&block);
    3831                 :          90 :   gfc_init_se (&se, NULL);
    3832                 :             : 
    3833                 :             :   /* Convert REPEATABLE to the desired LOGICAL entity.  */
    3834                 :          90 :   gfc_conv_expr (&se, code->ext.actual->expr);
    3835                 :          90 :   gfc_add_block_to_block (&block, &se.pre);
    3836                 :          90 :   arg1 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
    3837                 :          90 :   gfc_add_block_to_block (&block, &se.post);
    3838                 :             : 
    3839                 :             :   /* Convert IMAGE_DISTINCT to the desired LOGICAL entity.  */
    3840                 :          90 :   gfc_conv_expr (&se, code->ext.actual->next->expr);
    3841                 :          90 :   gfc_add_block_to_block (&block, &se.pre);
    3842                 :          90 :   arg2 = fold_convert (used_bool_type_node, gfc_evaluate_now (se.expr, &block));
    3843                 :          90 :   gfc_add_block_to_block (&block, &se.post);
    3844                 :             : 
    3845                 :          90 :   if (flag_coarray == GFC_FCOARRAY_LIB)
    3846                 :             :     {
    3847                 :           0 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_random_init,
    3848                 :             :                                  2, arg1, arg2);
    3849                 :             :     }
    3850                 :             :   else
    3851                 :             :     {
    3852                 :             :       /* The ABI for libgfortran needs to be maintained, so a hidden
    3853                 :             :          argument must be include if code is compiled with -fcoarray=single
    3854                 :             :          or without the option.  Set to 0.  */
    3855                 :          90 :       tree arg3 = build_int_cst (gfc_get_int_type (4), 0);
    3856                 :          90 :       tmp = build_call_expr_loc (input_location, gfor_fndecl_random_init,
    3857                 :             :                                  3, arg1, arg2, arg3);
    3858                 :             :     }
    3859                 :             : 
    3860                 :          90 :   gfc_add_expr_to_block (&block, tmp);
    3861                 :             : 
    3862                 :          90 :   return gfc_finish_block (&block);
    3863                 :             : }
    3864                 :             : 
    3865                 :             : 
    3866                 :             : /* Call the SYSTEM_CLOCK library functions, handling the type and kind
    3867                 :             :    conversions.  */
    3868                 :             : 
    3869                 :             : static tree
    3870                 :         194 : conv_intrinsic_system_clock (gfc_code *code)
    3871                 :             : {
    3872                 :         194 :   stmtblock_t block;
    3873                 :         194 :   gfc_se count_se, count_rate_se, count_max_se;
    3874                 :         194 :   tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
    3875                 :         194 :   tree tmp;
    3876                 :         194 :   int least;
    3877                 :             : 
    3878                 :         194 :   gfc_expr *count = code->ext.actual->expr;
    3879                 :         194 :   gfc_expr *count_rate = code->ext.actual->next->expr;
    3880                 :         194 :   gfc_expr *count_max = code->ext.actual->next->next->expr;
    3881                 :             : 
    3882                 :             :   /* Evaluate our arguments.  */
    3883                 :         194 :   if (count)
    3884                 :             :     {
    3885                 :         194 :       gfc_init_se (&count_se, NULL);
    3886                 :         194 :       gfc_conv_expr (&count_se, count);
    3887                 :             :     }
    3888                 :             : 
    3889                 :         194 :   if (count_rate)
    3890                 :             :     {
    3891                 :         181 :       gfc_init_se (&count_rate_se, NULL);
    3892                 :         181 :       gfc_conv_expr (&count_rate_se, count_rate);
    3893                 :             :     }
    3894                 :             : 
    3895                 :         194 :   if (count_max)
    3896                 :             :     {
    3897                 :         180 :       gfc_init_se (&count_max_se, NULL);
    3898                 :         180 :       gfc_conv_expr (&count_max_se, count_max);
    3899                 :             :     }
    3900                 :             : 
    3901                 :             :   /* Find the smallest kind found of the arguments.  */
    3902                 :         194 :   least = 16;
    3903                 :         194 :   least = (count && count->ts.kind < least) ? count->ts.kind : least;
    3904                 :         194 :   least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
    3905                 :             :                                                       : least;
    3906                 :         194 :   least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
    3907                 :             :                                                     : least;
    3908                 :             : 
    3909                 :             :   /* Prepare temporary variables.  */
    3910                 :             : 
    3911                 :         194 :   if (count)
    3912                 :             :     {
    3913                 :         194 :       if (least >= 8)
    3914                 :          18 :         arg1 = gfc_create_var (gfc_get_int_type (8), "count");
    3915                 :         176 :       else if (least == 4)
    3916                 :         152 :         arg1 = gfc_create_var (gfc_get_int_type (4), "count");
    3917                 :          24 :       else if (count->ts.kind == 1)
    3918                 :          12 :         arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
    3919                 :             :                                      count->ts.kind);
    3920                 :             :       else
    3921                 :          12 :         arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
    3922                 :             :                                      count->ts.kind);
    3923                 :             :     }
    3924                 :             : 
    3925                 :         194 :   if (count_rate)
    3926                 :             :     {
    3927                 :         181 :       if (least >= 8)
    3928                 :          18 :         arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
    3929                 :         163 :       else if (least == 4)
    3930                 :         139 :         arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
    3931                 :             :       else
    3932                 :          24 :         arg2 = integer_zero_node;
    3933                 :             :     }
    3934                 :             : 
    3935                 :         194 :   if (count_max)
    3936                 :             :     {
    3937                 :         180 :       if (least >= 8)
    3938                 :          18 :         arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
    3939                 :         162 :       else if (least == 4)
    3940                 :         138 :         arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
    3941                 :             :       else
    3942                 :          24 :         arg3 = integer_zero_node;
    3943                 :             :     }
    3944                 :             : 
    3945                 :             :   /* Make the function call.  */
    3946                 :         194 :   gfc_init_block (&block);
    3947                 :             : 
    3948                 :         194 : if (least <= 2)
    3949                 :             :   {
    3950                 :          24 :     if (least == 1)
    3951                 :             :       {
    3952                 :          12 :         arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
    3953                 :             :                : null_pointer_node;
    3954                 :          12 :         arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
    3955                 :             :                : null_pointer_node;
    3956                 :          12 :         arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
    3957                 :             :                : null_pointer_node;
    3958                 :             :       }
    3959                 :             : 
    3960                 :          24 :     if (least == 2)
    3961                 :             :       {
    3962                 :          12 :         arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
    3963                 :             :                : null_pointer_node;
    3964                 :          12 :         arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
    3965                 :             :                : null_pointer_node;
    3966                 :          12 :         arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
    3967                 :             :                : null_pointer_node;
    3968                 :             :       }
    3969                 :             :   }
    3970                 :             : else
    3971                 :             :   {
    3972                 :         170 :     if (least == 4)
    3973                 :             :       {
    3974                 :         581 :         tmp = build_call_expr_loc (input_location,
    3975                 :             :                 gfor_fndecl_system_clock4, 3,
    3976                 :         152 :                 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
    3977                 :             :                        : null_pointer_node,
    3978                 :         139 :                 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
    3979                 :             :                        : null_pointer_node,
    3980                 :         138 :                 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
    3981                 :             :                        : null_pointer_node);
    3982                 :         152 :         gfc_add_expr_to_block (&block, tmp);
    3983                 :             :       }
    3984                 :             :     /* Handle kind>=8, 10, or 16 arguments */
    3985                 :         170 :     if (least >= 8)
    3986                 :             :       {
    3987                 :          72 :         tmp = build_call_expr_loc (input_location,
    3988                 :             :                 gfor_fndecl_system_clock8, 3,
    3989                 :          18 :                 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
    3990                 :             :                        : null_pointer_node,
    3991                 :          18 :                 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
    3992                 :             :                        : null_pointer_node,
    3993                 :          18 :                 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
    3994                 :             :                        : null_pointer_node);
    3995                 :          18 :         gfc_add_expr_to_block (&block, tmp);
    3996                 :             :       }
    3997                 :             :   }
    3998                 :             : 
    3999                 :             :   /* And store values back if needed.  */
    4000                 :         194 :   if (arg1 && arg1 != count_se.expr)
    4001                 :         194 :     gfc_add_modify (&block, count_se.expr,
    4002                 :         194 :                     fold_convert (TREE_TYPE (count_se.expr), arg1));
    4003                 :         194 :   if (arg2 && arg2 != count_rate_se.expr)
    4004                 :         181 :     gfc_add_modify (&block, count_rate_se.expr,
    4005                 :         181 :                     fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
    4006                 :         194 :   if (arg3 && arg3 != count_max_se.expr)
    4007                 :         180 :     gfc_add_modify (&block, count_max_se.expr,
    4008                 :         180 :                     fold_convert (TREE_TYPE (count_max_se.expr), arg3));
    4009                 :             : 
    4010                 :         194 :   return gfc_finish_block (&block);
    4011                 :             : }
    4012                 :             : 
    4013                 :             : 
    4014                 :             : /* Return a character string containing the tty name.  */
    4015                 :             : 
    4016                 :             : static void
    4017                 :           0 : gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
    4018                 :             : {
    4019                 :           0 :   tree var;
    4020                 :           0 :   tree len;
    4021                 :           0 :   tree tmp;
    4022                 :           0 :   tree cond;
    4023                 :           0 :   tree fndecl;
    4024                 :           0 :   tree *args;
    4025                 :           0 :   unsigned int num_args;
    4026                 :             : 
    4027                 :           0 :   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
    4028                 :           0 :   args = XALLOCAVEC (tree, num_args);
    4029                 :             : 
    4030                 :           0 :   var = gfc_create_var (pchar_type_node, "pstr");
    4031                 :           0 :   len = gfc_create_var (gfc_charlen_type_node, "len");
    4032                 :             : 
    4033                 :           0 :   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
    4034                 :           0 :   args[0] = gfc_build_addr_expr (NULL_TREE, var);
    4035                 :           0 :   args[1] = gfc_build_addr_expr (NULL_TREE, len);
    4036                 :             : 
    4037                 :           0 :   fndecl = build_addr (gfor_fndecl_ttynam);
    4038                 :           0 :   tmp = build_call_array_loc (input_location,
    4039                 :           0 :                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
    4040                 :             :                           fndecl, num_args, args);
    4041                 :           0 :   gfc_add_expr_to_block (&se->pre, tmp);
    4042                 :             : 
    4043                 :             :   /* Free the temporary afterwards, if necessary.  */
    4044                 :           0 :   cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    4045                 :           0 :                           len, build_int_cst (TREE_TYPE (len), 0));
    4046                 :           0 :   tmp = gfc_call_free (var);
    4047                 :           0 :   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    4048                 :           0 :   gfc_add_expr_to_block (&se->post, tmp);
    4049                 :             : 
    4050                 :           0 :   se->expr = var;
    4051                 :           0 :   se->string_length = len;
    4052                 :           0 : }
    4053                 :             : 
    4054                 :             : 
    4055                 :             : /* Get the minimum/maximum value of all the parameters.
    4056                 :             :     minmax (a1, a2, a3, ...)
    4057                 :             :     {
    4058                 :             :       mvar = a1;
    4059                 :             :       mvar = COMP (mvar, a2)
    4060                 :             :       mvar = COMP (mvar, a3)
    4061                 :             :       ...
    4062                 :             :       return mvar;
    4063                 :             :     }
    4064                 :             :     Where COMP is MIN/MAX_EXPR for integral types or when we don't
    4065                 :             :     care about NaNs, or IFN_FMIN/MAX when the target has support for
    4066                 :             :     fast NaN-honouring min/max.  When neither holds expand a sequence
    4067                 :             :     of explicit comparisons.  */
    4068                 :             : 
    4069                 :             : /* TODO: Mismatching types can occur when specific names are used.
    4070                 :             :    These should be handled during resolution.  */
    4071                 :             : static void
    4072                 :        1257 : gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
    4073                 :             : {
    4074                 :        1257 :   tree tmp;
    4075                 :        1257 :   tree mvar;
    4076                 :        1257 :   tree val;
    4077                 :        1257 :   tree *args;
    4078                 :        1257 :   tree type;
    4079                 :        1257 :   tree argtype;
    4080                 :        1257 :   gfc_actual_arglist *argexpr;
    4081                 :        1257 :   unsigned int i, nargs;
    4082                 :             : 
    4083                 :        1257 :   nargs = gfc_intrinsic_argument_list_length (expr);
    4084                 :        1257 :   args = XALLOCAVEC (tree, nargs);
    4085                 :             : 
    4086                 :        1257 :   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
    4087                 :        1257 :   type = gfc_typenode_for_spec (&expr->ts);
    4088                 :             : 
    4089                 :             :   /* Only evaluate the argument once.  */
    4090                 :        1257 :   if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
    4091                 :         295 :     args[0] = gfc_evaluate_now (args[0], &se->pre);
    4092                 :             : 
    4093                 :             :   /* Determine suitable type of temporary, as a GNU extension allows
    4094                 :             :      different argument kinds.  */
    4095                 :        1257 :   argtype = TREE_TYPE (args[0]);
    4096                 :        1257 :   argexpr = expr->value.function.actual;
    4097                 :        2738 :   for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
    4098                 :             :     {
    4099                 :        1481 :       tree tmptype = TREE_TYPE (args[i]);
    4100                 :        1481 :       if (TYPE_PRECISION (tmptype) > TYPE_PRECISION (argtype))
    4101                 :           6 :         argtype = tmptype;
    4102                 :             :     }
    4103                 :        1257 :   mvar = gfc_create_var (argtype, "M");
    4104                 :        1257 :   gfc_add_modify (&se->pre, mvar, convert (argtype, args[0]));
    4105                 :             : 
    4106                 :        1257 :   argexpr = expr->value.function.actual;
    4107                 :        2738 :   for (i = 1, argexpr = argexpr->next; i < nargs; i++, argexpr = argexpr->next)
    4108                 :             :     {
    4109                 :        1481 :       tree cond = NULL_TREE;
    4110                 :        1481 :       val = args[i];
    4111                 :             : 
    4112                 :             :       /* Handle absent optional arguments by ignoring the comparison.  */
    4113                 :        1481 :       if (argexpr->expr->expr_type == EXPR_VARIABLE
    4114                 :         855 :           && argexpr->expr->symtree->n.sym->attr.optional
    4115                 :          39 :           && INDIRECT_REF_P (val))
    4116                 :             :         {
    4117                 :          72 :           cond = fold_build2_loc (input_location,
    4118                 :             :                                 NE_EXPR, logical_type_node,
    4119                 :          36 :                                 TREE_OPERAND (val, 0),
    4120                 :          36 :                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
    4121                 :             :         }
    4122                 :        1445 :       else if (!VAR_P (val) && !TREE_CONSTANT (val))
    4123                 :             :         /* Only evaluate the argument once.  */
    4124                 :         571 :         val = gfc_evaluate_now (val, &se->pre);
    4125                 :             : 
    4126                 :        1481 :       tree calc;
    4127                 :             :       /* For floating point types, the question is what MAX(a, NaN) or
    4128                 :             :          MIN(a, NaN) should return (where "a" is a normal number).
    4129                 :             :          There are valid use case for returning either one, but the
    4130                 :             :          Fortran standard doesn't specify which one should be chosen.
    4131                 :             :          Also, there is no consensus among other tested compilers.  In
    4132                 :             :          short, it's a mess.  So lets just do whatever is fastest.  */
    4133                 :        1481 :       tree_code code = op == GT_EXPR ? MAX_EXPR : MIN_EXPR;
    4134                 :        1481 :       calc = fold_build2_loc (input_location, code, argtype,
    4135                 :             :                               convert (argtype, val), mvar);
    4136                 :        1481 :       tmp = build2_v (MODIFY_EXPR, mvar, calc);
    4137                 :             : 
    4138                 :        1481 :       if (cond != NULL_TREE)
    4139                 :          36 :         tmp = build3_v (COND_EXPR, cond, tmp,
    4140                 :             :                         build_empty_stmt (input_location));
    4141                 :        1481 :       gfc_add_expr_to_block (&se->pre, tmp);
    4142                 :             :     }
    4143                 :        1257 :   se->expr = convert (type, mvar);
    4144                 :        1257 : }
    4145                 :             : 
    4146                 :             : 
    4147                 :             : /* Generate library calls for MIN and MAX intrinsics for character
    4148                 :             :    variables.  */
    4149                 :             : static void
    4150                 :         282 : gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
    4151                 :             : {
    4152                 :         282 :   tree *args;
    4153                 :         282 :   tree var, len, fndecl, tmp, cond, function;
    4154                 :         282 :   unsigned int nargs;
    4155                 :             : 
    4156                 :         282 :   nargs = gfc_intrinsic_argument_list_length (expr);
    4157                 :         282 :   args = XALLOCAVEC (tree, nargs + 4);
    4158                 :         282 :   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
    4159                 :             : 
    4160                 :             :   /* Create the result variables.  */
    4161                 :         282 :   len = gfc_create_var (gfc_charlen_type_node, "len");
    4162                 :         282 :   args[0] = gfc_build_addr_expr (NULL_TREE, len);
    4163                 :         282 :   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
    4164                 :         282 :   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
    4165                 :         282 :   args[2] = build_int_cst (integer_type_node, op);
    4166                 :         282 :   args[3] = build_int_cst (integer_type_node, nargs / 2);
    4167                 :             : 
    4168                 :         282 :   if (expr->ts.kind == 1)
    4169                 :         210 :     function = gfor_fndecl_string_minmax;
    4170                 :          72 :   else if (expr->ts.kind == 4)
    4171                 :          72 :     function = gfor_fndecl_string_minmax_char4;
    4172                 :             :   else
    4173                 :           0 :     gcc_unreachable ();
    4174                 :             : 
    4175                 :             :   /* Make the function call.  */
    4176                 :         282 :   fndecl = build_addr (function);
    4177                 :         282 :   tmp = build_call_array_loc (input_location,
    4178                 :         282 :                           TREE_TYPE (TREE_TYPE (function)), fndecl,
    4179                 :             :                           nargs + 4, args);
    4180                 :         282 :   gfc_add_expr_to_block (&se->pre, tmp);
    4181                 :             : 
    4182                 :             :   /* Free the temporary afterwards, if necessary.  */
    4183                 :         282 :   cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    4184                 :         282 :                           len, build_int_cst (TREE_TYPE (len), 0));
    4185                 :         282 :   tmp = gfc_call_free (var);
    4186                 :         282 :   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    4187                 :         282 :   gfc_add_expr_to_block (&se->post, tmp);
    4188                 :             : 
    4189                 :         282 :   se->expr = var;
    4190                 :         282 :   se->string_length = len;
    4191                 :         282 : }
    4192                 :             : 
    4193                 :             : 
    4194                 :             : /* Create a symbol node for this intrinsic.  The symbol from the frontend
    4195                 :             :    has the generic name.  */
    4196                 :             : 
    4197                 :             : static gfc_symbol *
    4198                 :        8891 : gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
    4199                 :             : {
    4200                 :        8891 :   gfc_symbol *sym;
    4201                 :             : 
    4202                 :             :   /* TODO: Add symbols for intrinsic function to the global namespace.  */
    4203                 :        8891 :   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
    4204                 :        8891 :   sym = gfc_new_symbol (expr->value.function.name, NULL);
    4205                 :             : 
    4206                 :        8891 :   sym->ts = expr->ts;
    4207                 :        8891 :   sym->attr.external = 1;
    4208                 :        8891 :   sym->attr.function = 1;
    4209                 :        8891 :   sym->attr.always_explicit = 1;
    4210                 :        8891 :   sym->attr.proc = PROC_INTRINSIC;
    4211                 :        8891 :   sym->attr.flavor = FL_PROCEDURE;
    4212                 :        8891 :   sym->result = sym;
    4213                 :        8891 :   if (expr->rank > 0)
    4214                 :             :     {
    4215                 :        7679 :       sym->attr.dimension = 1;
    4216                 :        7679 :       sym->as = gfc_get_array_spec ();
    4217                 :        7679 :       sym->as->type = AS_ASSUMED_SHAPE;
    4218                 :        7679 :       sym->as->rank = expr->rank;
    4219                 :             :     }
    4220                 :             : 
    4221                 :        8891 :   gfc_copy_formal_args_intr (sym, expr->value.function.isym,
    4222                 :             :                              ignore_optional ? expr->value.function.actual
    4223                 :             :                                              : NULL);
    4224                 :             : 
    4225                 :        8891 :   return sym;
    4226                 :             : }
    4227                 :             : 
    4228                 :             : /* Remove empty actual arguments.  */
    4229                 :             : 
    4230                 :             : static void
    4231                 :        6419 : remove_empty_actual_arguments (gfc_actual_arglist **ap)
    4232                 :             : {
    4233                 :       33794 :   while (*ap)
    4234                 :             :     {
    4235                 :       27375 :       if ((*ap)->expr == NULL)
    4236                 :             :         {
    4237                 :        8358 :           gfc_actual_arglist *r = *ap;
    4238                 :        8358 :           *ap = r->next;
    4239                 :        8358 :           r->next = NULL;
    4240                 :        8358 :           gfc_free_actual_arglist (r);
    4241                 :             :         }
    4242                 :             :       else
    4243                 :       19017 :         ap = &((*ap)->next);
    4244                 :             :     }
    4245                 :        6419 : }
    4246                 :             : 
    4247                 :             : #define MAX_SPEC_ARG 12
    4248                 :             : 
    4249                 :             : /* Make up an fn spec that's right for intrinsic functions that we
    4250                 :             :    want to call.  */
    4251                 :             : 
    4252                 :             : static char *
    4253                 :        1284 : intrinsic_fnspec (gfc_expr *expr)
    4254                 :             : {
    4255                 :        1284 :   static char fnspec_buf[MAX_SPEC_ARG*2+1];
    4256                 :        1284 :   char *fp;
    4257                 :        1284 :   int i;
    4258                 :        1284 :   int num_char_args;
    4259                 :             : 
    4260                 :             : #define ADD_CHAR(c) do { *fp++ = c; *fp++ = ' '; } while(0)
    4261                 :             : 
    4262                 :             :   /* Set the fndecl.  */
    4263                 :        1284 :   fp = fnspec_buf;
    4264                 :             :   /* Function return value.  FIXME: Check if the second letter could
    4265                 :             :      be something other than a space, for further optimization.  */
    4266                 :        1284 :   ADD_CHAR ('.');
    4267                 :        1284 :   if (expr->rank == 0)
    4268                 :             :     {
    4269                 :         166 :       if (expr->ts.type == BT_CHARACTER)
    4270                 :             :         {
    4271                 :          84 :           ADD_CHAR ('w');  /* Address of character.  */
    4272                 :          84 :           ADD_CHAR ('.');  /* Length of character.  */
    4273                 :             :         }
    4274                 :             :     }
    4275                 :             :   else
    4276                 :        1118 :     ADD_CHAR ('w');  /* Return value is a descriptor.  */
    4277                 :             : 
    4278                 :        1284 :   num_char_args = 0;
    4279                 :        6572 :   for (gfc_actual_arglist *a = expr->value.function.actual; a; a = a->next)
    4280                 :             :     {
    4281                 :        5288 :       if (a->expr == NULL)
    4282                 :        1764 :         continue;
    4283                 :             : 
    4284                 :        3524 :       if (a->name && strcmp (a->name,"%VAL") == 0)
    4285                 :         790 :         ADD_CHAR ('.');
    4286                 :             :       else
    4287                 :             :         {
    4288                 :        2734 :           if (a->expr->rank > 0)
    4289                 :        1699 :             ADD_CHAR ('r');
    4290                 :             :           else
    4291                 :        1035 :             ADD_CHAR ('R');
    4292                 :             :         }
    4293                 :        3524 :       num_char_args += a->expr->ts.type == BT_CHARACTER;
    4294                 :        3524 :       gcc_assert (fp - fnspec_buf + num_char_args <= MAX_SPEC_ARG*2);
    4295                 :             :     }
    4296                 :             : 
    4297                 :        1704 :   for (i = 0; i < num_char_args; i++)
    4298                 :         420 :     ADD_CHAR ('.');
    4299                 :             : 
    4300                 :        1284 :   *fp = '\0';
    4301                 :        1284 :   return fnspec_buf;
    4302                 :             : }
    4303                 :             : 
    4304                 :             : #undef MAX_SPEC_ARG
    4305                 :             : #undef ADD_CHAR
    4306                 :             : 
    4307                 :             : /* Generate the right symbol for the specific intrinsic function and
    4308                 :             :  modify the expr accordingly.  This assumes that absent optional
    4309                 :             :  arguments should be removed.  */
    4310                 :             : 
    4311                 :             : gfc_symbol *
    4312                 :        6419 : specific_intrinsic_symbol (gfc_expr *expr)
    4313                 :             : {
    4314                 :        6419 :   gfc_symbol *sym;
    4315                 :             : 
    4316                 :        6419 :   sym = gfc_find_intrinsic_symbol (expr);
    4317                 :        6419 :   if (sym == NULL)
    4318                 :             :     {
    4319                 :        1284 :       sym = gfc_get_intrinsic_function_symbol (expr);
    4320                 :        1284 :       sym->ts = expr->ts;
    4321                 :        1284 :       if (sym->ts.type == BT_CHARACTER && sym->ts.u.cl)
    4322                 :         156 :         sym->ts.u.cl = gfc_new_charlen (sym->ns, NULL);
    4323                 :             : 
    4324                 :        1284 :       gfc_copy_formal_args_intr (sym, expr->value.function.isym,
    4325                 :             :                                  expr->value.function.actual, true);
    4326                 :        1284 :       sym->backend_decl
    4327                 :        1284 :         = gfc_get_extern_function_decl (sym, expr->value.function.actual,
    4328                 :        1284 :                                         intrinsic_fnspec (expr));
    4329                 :             :     }
    4330                 :             : 
    4331                 :        6419 :   remove_empty_actual_arguments (&(expr->value.function.actual));
    4332                 :             : 
    4333                 :        6419 :   return sym;
    4334                 :             : }
    4335                 :             : 
    4336                 :             : /* Generate a call to an external intrinsic function.  FIXME: So far,
    4337                 :             :    this only works for functions which are called with well-defined
    4338                 :             :    types; CSHIFT and friends will come later.  */
    4339                 :             : 
    4340                 :             : static void
    4341                 :       11320 : gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
    4342                 :             : {
    4343                 :       11320 :   gfc_symbol *sym;
    4344                 :       11320 :   vec<tree, va_gc> *append_args;
    4345                 :       11320 :   bool specific_symbol;
    4346                 :             : 
    4347                 :       11320 :   gcc_assert (!se->ss || se->ss->info->expr == expr);
    4348                 :             : 
    4349                 :       11320 :   if (se->ss)
    4350                 :        9798 :     gcc_assert (expr->rank > 0);
    4351                 :             :   else
    4352                 :        1522 :     gcc_assert (expr->rank == 0);
    4353                 :             : 
    4354                 :       11320 :   switch (expr->value.function.isym->id)
    4355                 :             :     {
    4356                 :             :     case GFC_ISYM_ANY:
    4357                 :             :     case GFC_ISYM_ALL:
    4358                 :             :     case GFC_ISYM_FINDLOC:
    4359                 :             :     case GFC_ISYM_MAXLOC:
    4360                 :             :     case GFC_ISYM_MINLOC:
    4361                 :             :     case GFC_ISYM_MAXVAL:
    4362                 :             :     case GFC_ISYM_MINVAL:
    4363                 :             :     case GFC_ISYM_NORM2:
    4364                 :             :     case GFC_ISYM_PRODUCT:
    4365                 :             :     case GFC_ISYM_SUM:
    4366                 :             :       specific_symbol = true;
    4367                 :             :       break;
    4368                 :        4901 :     default:
    4369                 :        4901 :       specific_symbol = false;
    4370                 :             :     }
    4371                 :             : 
    4372                 :       11320 :   if (specific_symbol)
    4373                 :             :     {
    4374                 :             :       /* Need to copy here because specific_intrinsic_symbol modifies
    4375                 :             :          expr to omit the absent optional arguments.  */
    4376                 :        6419 :       expr = gfc_copy_expr (expr);
    4377                 :        6419 :       sym = specific_intrinsic_symbol (expr);
    4378                 :             :     }
    4379                 :             :   else
    4380                 :        4901 :     sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
    4381                 :             : 
    4382                 :             :   /* Calls to libgfortran_matmul need to be appended special arguments,
    4383                 :             :      to be able to call the BLAS ?gemm functions if required and possible.  */
    4384                 :       11320 :   append_args = NULL;
    4385                 :       11320 :   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
    4386                 :         908 :       && !expr->external_blas
    4387                 :         871 :       && sym->ts.type != BT_LOGICAL)
    4388                 :             :     {
    4389                 :         855 :       tree cint = gfc_get_int_type (gfc_c_int_kind);
    4390                 :             : 
    4391                 :         855 :       if (flag_external_blas
    4392                 :           0 :           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
    4393                 :           0 :           && (sym->ts.kind == 4 || sym->ts.kind == 8))
    4394                 :             :         {
    4395                 :           0 :           tree gemm_fndecl;
    4396                 :             : 
    4397                 :           0 :           if (sym->ts.type == BT_REAL)
    4398                 :             :             {
    4399                 :           0 :               if (sym->ts.kind == 4)
    4400                 :           0 :                 gemm_fndecl = gfor_fndecl_sgemm;
    4401                 :             :               else
    4402                 :           0 :                 gemm_fndecl = gfor_fndecl_dgemm;
    4403                 :             :             }
    4404                 :             :           else
    4405                 :             :             {
    4406                 :           0 :               if (sym->ts.kind == 4)
    4407                 :           0 :                 gemm_fndecl = gfor_fndecl_cgemm;
    4408                 :             :               else
    4409                 :           0 :                 gemm_fndecl = gfor_fndecl_zgemm;
    4410                 :             :             }
    4411                 :             : 
    4412                 :           0 :           vec_alloc (append_args, 3);
    4413                 :           0 :           append_args->quick_push (build_int_cst (cint, 1));
    4414                 :           0 :           append_args->quick_push (build_int_cst (cint,
    4415                 :             :                                                   flag_blas_matmul_limit));
    4416                 :           0 :           append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
    4417                 :             :                                                         gemm_fndecl));
    4418                 :           0 :         }
    4419                 :             :       else
    4420                 :             :         {
    4421                 :         855 :           vec_alloc (append_args, 3);
    4422                 :         855 :           append_args->quick_push (build_int_cst (cint, 0));
    4423                 :         855 :           append_args->quick_push (build_int_cst (cint, 0));
    4424                 :         855 :           append_args->quick_push (null_pointer_node);
    4425                 :             :         }
    4426                 :             :     }
    4427                 :             : 
    4428                 :       11320 :   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
    4429                 :             :                           append_args);
    4430                 :             : 
    4431                 :       11320 :   if (specific_symbol)
    4432                 :        6419 :     gfc_free_expr (expr);
    4433                 :             :   else
    4434                 :        4901 :     gfc_free_symbol (sym);
    4435                 :       11320 : }
    4436                 :             : 
    4437                 :             : /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
    4438                 :             :    Implemented as
    4439                 :             :     any(a)
    4440                 :             :     {
    4441                 :             :       forall (i=...)
    4442                 :             :         if (a[i] != 0)
    4443                 :             :           return 1
    4444                 :             :       end forall
    4445                 :             :       return 0
    4446                 :             :     }
    4447                 :             :     all(a)
    4448                 :             :     {
    4449                 :             :       forall (i=...)
    4450                 :             :         if (a[i] == 0)
    4451                 :             :           return 0
    4452                 :             :       end forall
    4453                 :             :       return 1
    4454                 :             :     }
    4455                 :             :  */
    4456                 :             : static void
    4457                 :       27249 : gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
    4458                 :             : {
    4459                 :       27249 :   tree resvar;
    4460                 :       27249 :   stmtblock_t block;
    4461                 :       27249 :   stmtblock_t body;
    4462                 :       27249 :   tree type;
    4463                 :       27249 :   tree tmp;
    4464                 :       27249 :   tree found;
    4465                 :       27249 :   gfc_loopinfo loop;
    4466                 :       27249 :   gfc_actual_arglist *actual;
    4467                 :       27249 :   gfc_ss *arrayss;
    4468                 :       27249 :   gfc_se arrayse;
    4469                 :       27249 :   tree exit_label;
    4470                 :             : 
    4471                 :       27249 :   if (se->ss)
    4472                 :             :     {
    4473                 :           0 :       gfc_conv_intrinsic_funcall (se, expr);
    4474                 :           0 :       return;
    4475                 :             :     }
    4476                 :             : 
    4477                 :       27249 :   actual = expr->value.function.actual;
    4478                 :       27249 :   type = gfc_typenode_for_spec (&expr->ts);
    4479                 :             :   /* Initialize the result.  */
    4480                 :       27249 :   resvar = gfc_create_var (type, "test");
    4481                 :       27249 :   if (op == EQ_EXPR)
    4482                 :         433 :     tmp = convert (type, boolean_true_node);
    4483                 :             :   else
    4484                 :       26816 :     tmp = convert (type, boolean_false_node);
    4485                 :       27249 :   gfc_add_modify (&se->pre, resvar, tmp);
    4486                 :             : 
    4487                 :             :   /* Walk the arguments.  */
    4488                 :       27249 :   arrayss = gfc_walk_expr (actual->expr);
    4489                 :       27249 :   gcc_assert (arrayss != gfc_ss_terminator);
    4490                 :             : 
    4491                 :             :   /* Initialize the scalarizer.  */
    4492                 :       27249 :   gfc_init_loopinfo (&loop);
    4493                 :       27249 :   exit_label = gfc_build_label_decl (NULL_TREE);
    4494                 :       27249 :   TREE_USED (exit_label) = 1;
    4495                 :       27249 :   gfc_add_ss_to_loop (&loop, arrayss);
    4496                 :             : 
    4497                 :             :   /* Initialize the loop.  */
    4498                 :       27249 :   gfc_conv_ss_startstride (&loop);
    4499                 :       27249 :   gfc_conv_loop_setup (&loop, &expr->where);
    4500                 :             : 
    4501                 :       27249 :   gfc_mark_ss_chain_used (arrayss, 1);
    4502                 :             :   /* Generate the loop body.  */
    4503                 :       27249 :   gfc_start_scalarized_body (&loop, &body);
    4504                 :             : 
    4505                 :             :   /* If the condition matches then set the return value.  */
    4506                 :       27249 :   gfc_start_block (&block);
    4507                 :       27249 :   if (op == EQ_EXPR)
    4508                 :         433 :     tmp = convert (type, boolean_false_node);
    4509                 :             :   else
    4510                 :       26816 :     tmp = convert (type, boolean_true_node);
    4511                 :       27249 :   gfc_add_modify (&block, resvar, tmp);
    4512                 :             : 
    4513                 :             :   /* And break out of the loop.  */
    4514                 :       27249 :   tmp = build1_v (GOTO_EXPR, exit_label);
    4515                 :       27249 :   gfc_add_expr_to_block (&block, tmp);
    4516                 :             : 
    4517                 :       27249 :   found = gfc_finish_block (&block);
    4518                 :             : 
    4519                 :             :   /* Check this element.  */
    4520                 :       27249 :   gfc_init_se (&arrayse, NULL);
    4521                 :       27249 :   gfc_copy_loopinfo_to_se (&arrayse, &loop);
    4522                 :       27249 :   arrayse.ss = arrayss;
    4523                 :       27249 :   gfc_conv_expr_val (&arrayse, actual->expr);
    4524                 :             : 
    4525                 :       27249 :   gfc_add_block_to_block (&body, &arrayse.pre);
    4526                 :       27249 :   tmp = fold_build2_loc (input_location, op, logical_type_node, arrayse.expr,
    4527                 :       27249 :                          build_int_cst (TREE_TYPE (arrayse.expr), 0));
    4528                 :       27249 :   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
    4529                 :       27249 :   gfc_add_expr_to_block (&body, tmp);
    4530                 :       27249 :   gfc_add_block_to_block (&body, &arrayse.post);
    4531                 :             : 
    4532                 :       27249 :   gfc_trans_scalarizing_loops (&loop, &body);
    4533                 :             : 
    4534                 :             :   /* Add the exit label.  */
    4535                 :       27249 :   tmp = build1_v (LABEL_EXPR, exit_label);
    4536                 :       27249 :   gfc_add_expr_to_block (&loop.pre, tmp);
    4537                 :             : 
    4538                 :       27249 :   gfc_add_block_to_block (&se->pre, &loop.pre);
    4539                 :       27249 :   gfc_add_block_to_block (&se->pre, &loop.post);
    4540                 :       27249 :   gfc_cleanup_loop (&loop);
    4541                 :             : 
    4542                 :       27249 :   se->expr = resvar;
    4543                 :             : }
    4544                 :             : 
    4545                 :             : 
    4546                 :             : /* Generate the constant 180 / pi, which is used in the conversion
    4547                 :             :    of acosd(), asind(), atand(), atan2d().  */
    4548                 :             : 
    4549                 :             : static tree
    4550                 :         288 : rad2deg (int kind)
    4551                 :             : {
    4552                 :         288 :   tree retval;
    4553                 :         288 :   mpfr_t pi, t0;
    4554                 :             : 
    4555                 :         288 :   gfc_set_model_kind (kind);
    4556                 :         288 :   mpfr_init (pi);
    4557                 :         288 :   mpfr_init (t0);
    4558                 :         288 :   mpfr_set_si (t0, 180, GFC_RND_MODE);
    4559                 :         288 :   mpfr_const_pi (pi, GFC_RND_MODE);
    4560                 :         288 :   mpfr_div (t0, t0, pi, GFC_RND_MODE);
    4561                 :         288 :   retval = gfc_conv_mpfr_to_tree (t0, kind, 0);
    4562                 :         288 :   mpfr_clear (t0);
    4563                 :         288 :   mpfr_clear (pi);
    4564                 :         288 :   return retval;
    4565                 :             : }
    4566                 :             : 
    4567                 :             : 
    4568                 :             : static gfc_intrinsic_map_t *
    4569                 :         498 : gfc_lookup_intrinsic (gfc_isym_id id)
    4570                 :             : {
    4571                 :         498 :   gfc_intrinsic_map_t *m = gfc_intrinsic_map;
    4572                 :        8400 :   for (; m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
    4573                 :        8400 :     if (id == m->id)
    4574                 :             :       break;
    4575                 :         498 :   gcc_assert (id == m->id);
    4576                 :         498 :   return m;
    4577                 :             : }
    4578                 :             : 
    4579                 :             : 
    4580                 :             : /* ACOSD(x) is translated into ACOS(x) * 180 / pi.
    4581                 :             :    ASIND(x) is translated into ASIN(x) * 180 / pi.
    4582                 :             :    ATAND(x) is translated into ATAN(x) * 180 / pi.  */
    4583                 :             : 
    4584                 :             : static void
    4585                 :         216 : gfc_conv_intrinsic_atrigd (gfc_se * se, gfc_expr * expr, gfc_isym_id id)
    4586                 :             : {
    4587                 :         216 :   tree arg;
    4588                 :         216 :   tree atrigd;
    4589                 :         216 :   tree type;
    4590                 :         216 :   gfc_intrinsic_map_t *m;
    4591                 :             : 
    4592                 :         216 :   type = gfc_typenode_for_spec (&expr->ts);
    4593                 :             : 
    4594                 :         216 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    4595                 :             : 
    4596                 :         216 :   switch (id)
    4597                 :             :     {
    4598                 :          72 :     case GFC_ISYM_ACOSD:
    4599                 :          72 :       m = gfc_lookup_intrinsic (GFC_ISYM_ACOS);
    4600                 :          72 :       break;
    4601                 :          72 :     case GFC_ISYM_ASIND:
    4602                 :          72 :       m = gfc_lookup_intrinsic (GFC_ISYM_ASIN);
    4603                 :          72 :       break;
    4604                 :          72 :     case GFC_ISYM_ATAND:
    4605                 :          72 :       m = gfc_lookup_intrinsic (GFC_ISYM_ATAN);
    4606                 :          72 :       break;
    4607                 :           0 :     default:
    4608                 :           0 :       gcc_unreachable ();
    4609                 :             :     }
    4610                 :         216 :   atrigd = gfc_get_intrinsic_lib_fndecl (m, expr);
    4611                 :         216 :   atrigd = build_call_expr_loc (input_location, atrigd, 1, arg);
    4612                 :             : 
    4613                 :         216 :   se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atrigd,
    4614                 :             :                               fold_convert (type, rad2deg (expr->ts.kind)));
    4615                 :         216 : }
    4616                 :             : 
    4617                 :             : 
    4618                 :             : /* COTAN(X) is translated into -TAN(X+PI/2) for REAL argument and
    4619                 :             :    COS(X) / SIN(X) for COMPLEX argument.  */
    4620                 :             : 
    4621                 :             : static void
    4622                 :         102 : gfc_conv_intrinsic_cotan (gfc_se *se, gfc_expr *expr)
    4623                 :             : {
    4624                 :         102 :   gfc_intrinsic_map_t *m;
    4625                 :         102 :   tree arg;
    4626                 :         102 :   tree type;
    4627                 :             : 
    4628                 :         102 :   type = gfc_typenode_for_spec (&expr->ts);
    4629                 :         102 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    4630                 :             : 
    4631                 :         102 :   if (expr->ts.type == BT_REAL)
    4632                 :             :     {
    4633                 :         102 :       tree tan;
    4634                 :         102 :       tree tmp;
    4635                 :         102 :       mpfr_t pio2;
    4636                 :             : 
    4637                 :             :       /* Create pi/2.  */
    4638                 :         102 :       gfc_set_model_kind (expr->ts.kind);
    4639                 :         102 :       mpfr_init (pio2);
    4640                 :         102 :       mpfr_const_pi (pio2, GFC_RND_MODE);
    4641                 :         102 :       mpfr_div_ui (pio2, pio2, 2, GFC_RND_MODE);
    4642                 :         102 :       tmp = gfc_conv_mpfr_to_tree (pio2, expr->ts.kind, 0);
    4643                 :         102 :       mpfr_clear (pio2);
    4644                 :             : 
    4645                 :             :       /* Find tan builtin function.  */
    4646                 :         102 :       m = gfc_lookup_intrinsic (GFC_ISYM_TAN);
    4647                 :         102 :       tan = gfc_get_intrinsic_lib_fndecl (m, expr);
    4648                 :         102 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, arg, tmp);
    4649                 :         102 :       tan = build_call_expr_loc (input_location, tan, 1, tmp);
    4650                 :         102 :       se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tan);
    4651                 :             :     }
    4652                 :             :   else
    4653                 :             :     {
    4654                 :           0 :       tree sin;
    4655                 :           0 :       tree cos;
    4656                 :             : 
    4657                 :             :       /* Find cos builtin function.  */
    4658                 :           0 :       m = gfc_lookup_intrinsic (GFC_ISYM_COS);
    4659                 :           0 :       cos = gfc_get_intrinsic_lib_fndecl (m, expr);
    4660                 :           0 :       cos = build_call_expr_loc (input_location, cos, 1, arg);
    4661                 :             : 
    4662                 :             :       /* Find sin builtin function.  */
    4663                 :           0 :       m = gfc_lookup_intrinsic (GFC_ISYM_SIN);
    4664                 :           0 :       sin = gfc_get_intrinsic_lib_fndecl (m, expr);
    4665                 :           0 :       sin = build_call_expr_loc (input_location, sin, 1, arg);
    4666                 :             : 
    4667                 :             :       /* Divide cos by sin. */
    4668                 :           0 :       se->expr = fold_build2_loc (input_location, RDIV_EXPR, type, cos, sin);
    4669                 :             :    }
    4670                 :         102 : }
    4671                 :             : 
    4672                 :             : 
    4673                 :             : /* COTAND(X) is translated into -TAND(X+90) for REAL argument.  */
    4674                 :             : 
    4675                 :             : static void
    4676                 :         108 : gfc_conv_intrinsic_cotand (gfc_se *se, gfc_expr *expr)
    4677                 :             : {
    4678                 :         108 :   tree arg;
    4679                 :         108 :   tree type;
    4680                 :         108 :   tree ninety_tree;
    4681                 :         108 :   mpfr_t ninety;
    4682                 :             : 
    4683                 :         108 :   type = gfc_typenode_for_spec (&expr->ts);
    4684                 :         108 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    4685                 :             : 
    4686                 :         108 :   gfc_set_model_kind (expr->ts.kind);
    4687                 :             : 
    4688                 :             :   /* Build the tree for x + 90.  */
    4689                 :         108 :   mpfr_init_set_ui (ninety, 90, GFC_RND_MODE);
    4690                 :         108 :   ninety_tree = gfc_conv_mpfr_to_tree (ninety, expr->ts.kind, 0);
    4691                 :         108 :   arg = fold_build2_loc (input_location, PLUS_EXPR, type, arg, ninety_tree);
    4692                 :         108 :   mpfr_clear (ninety);
    4693                 :             : 
    4694                 :             :   /* Find tand.  */
    4695                 :         108 :   gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_TAND);
    4696                 :         108 :   tree tand = gfc_get_intrinsic_lib_fndecl (m, expr);
    4697                 :         108 :   tand = build_call_expr_loc (input_location, tand, 1, arg);
    4698                 :             : 
    4699                 :         108 :   se->expr = fold_build1_loc (input_location, NEGATE_EXPR, type, tand);
    4700                 :         108 : }
    4701                 :             : 
    4702                 :             : 
    4703                 :             : /* ATAN2D(Y,X) is translated into ATAN2(Y,X) * 180 / PI. */
    4704                 :             : 
    4705                 :             : static void
    4706                 :          72 : gfc_conv_intrinsic_atan2d (gfc_se *se, gfc_expr *expr)
    4707                 :             : {
    4708                 :          72 :   tree args[2];
    4709                 :          72 :   tree atan2d;
    4710                 :          72 :   tree type;
    4711                 :             : 
    4712                 :          72 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    4713                 :          72 :   type = TREE_TYPE (args[0]);
    4714                 :             : 
    4715                 :          72 :   gfc_intrinsic_map_t *m = gfc_lookup_intrinsic (GFC_ISYM_ATAN2);
    4716                 :          72 :   atan2d = gfc_get_intrinsic_lib_fndecl (m, expr);
    4717                 :          72 :   atan2d = build_call_expr_loc (input_location, atan2d, 2, args[0], args[1]);
    4718                 :             : 
    4719                 :          72 :   se->expr = fold_build2_loc (input_location, MULT_EXPR, type, atan2d,
    4720                 :             :                               rad2deg (expr->ts.kind));
    4721                 :          72 : }
    4722                 :             : 
    4723                 :             : 
    4724                 :             : /* COUNT(A) = Number of true elements in A.  */
    4725                 :             : static void
    4726                 :         142 : gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
    4727                 :             : {
    4728                 :         142 :   tree resvar;
    4729                 :         142 :   tree type;
    4730                 :         142 :   stmtblock_t body;
    4731                 :         142 :   tree tmp;
    4732                 :         142 :   gfc_loopinfo loop;
    4733                 :         142 :   gfc_actual_arglist *actual;
    4734                 :         142 :   gfc_ss *arrayss;
    4735                 :         142 :   gfc_se arrayse;
    4736                 :             : 
    4737                 :         142 :   if (se->ss)
    4738                 :             :     {
    4739                 :           0 :       gfc_conv_intrinsic_funcall (se, expr);
    4740                 :           0 :       return;
    4741                 :             :     }
    4742                 :             : 
    4743                 :         142 :   actual = expr->value.function.actual;
    4744                 :             : 
    4745                 :         142 :   type = gfc_typenode_for_spec (&expr->ts);
    4746                 :             :   /* Initialize the result.  */
    4747                 :         142 :   resvar = gfc_create_var (type, "count");
    4748                 :         142 :   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
    4749                 :             : 
    4750                 :             :   /* Walk the arguments.  */
    4751                 :         142 :   arrayss = gfc_walk_expr (actual->expr);
    4752                 :         142 :   gcc_assert (arrayss != gfc_ss_terminator);
    4753                 :             : 
    4754                 :             :   /* Initialize the scalarizer.  */
    4755                 :         142 :   gfc_init_loopinfo (&loop);
    4756                 :         142 :   gfc_add_ss_to_loop (&loop, arrayss);
    4757                 :             : 
    4758                 :             :   /* Initialize the loop.  */
    4759                 :         142 :   gfc_conv_ss_startstride (&loop);
    4760                 :         142 :   gfc_conv_loop_setup (&loop, &expr->where);
    4761                 :             : 
    4762                 :         142 :   gfc_mark_ss_chain_used (arrayss, 1);
    4763                 :             :   /* Generate the loop body.  */
    4764                 :         142 :   gfc_start_scalarized_body (&loop, &body);
    4765                 :             : 
    4766                 :         142 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
    4767                 :         142 :                          resvar, build_int_cst (TREE_TYPE (resvar), 1));
    4768                 :         142 :   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
    4769                 :             : 
    4770                 :         142 :   gfc_init_se (&arrayse, NULL);
    4771                 :         142 :   gfc_copy_loopinfo_to_se (&arrayse, &loop);
    4772                 :         142 :   arrayse.ss = arrayss;
    4773                 :         142 :   gfc_conv_expr_val (&arrayse, actual->expr);
    4774                 :         142 :   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
    4775                 :             :                   build_empty_stmt (input_location));
    4776                 :             : 
    4777                 :         142 :   gfc_add_block_to_block (&body, &arrayse.pre);
    4778                 :         142 :   gfc_add_expr_to_block (&body, tmp);
    4779                 :         142 :   gfc_add_block_to_block (&body, &arrayse.post);
    4780                 :             : 
    4781                 :         142 :   gfc_trans_scalarizing_loops (&loop, &body);
    4782                 :             : 
    4783                 :         142 :   gfc_add_block_to_block (&se->pre, &loop.pre);
    4784                 :         142 :   gfc_add_block_to_block (&se->pre, &loop.post);
    4785                 :         142 :   gfc_cleanup_loop (&loop);
    4786                 :             : 
    4787                 :         142 :   se->expr = resvar;
    4788                 :             : }
    4789                 :             : 
    4790                 :             : 
    4791                 :             : /* Update given gfc_se to have ss component pointing to the nested gfc_ss
    4792                 :             :    struct and return the corresponding loopinfo.  */
    4793                 :             : 
    4794                 :             : static gfc_loopinfo *
    4795                 :         563 : enter_nested_loop (gfc_se *se)
    4796                 :             : {
    4797                 :         563 :   se->ss = se->ss->nested_ss;
    4798                 :         563 :   gcc_assert (se->ss == se->ss->loop->ss);
    4799                 :             : 
    4800                 :         563 :   return se->ss->loop;
    4801                 :             : }
    4802                 :             : 
    4803                 :             : /* Build the condition for a mask, which may be optional.  */
    4804                 :             : 
    4805                 :             : static tree
    4806                 :        7187 : conv_mask_condition (gfc_se *maskse, gfc_expr *maskexpr,
    4807                 :             :                          bool optional_mask)
    4808                 :             : {
    4809                 :        7187 :   tree present;
    4810                 :        7187 :   tree type;
    4811                 :             : 
    4812                 :        7187 :   if (optional_mask)
    4813                 :             :     {
    4814                 :          62 :       type = TREE_TYPE (maskse->expr);
    4815                 :          62 :       present = gfc_conv_expr_present (maskexpr->symtree->n.sym);
    4816                 :          62 :       present = convert (type, present);
    4817                 :          62 :       present = fold_build1_loc (input_location, TRUTH_NOT_EXPR, type,
    4818                 :             :                                  present);
    4819                 :          62 :       return fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    4820                 :          62 :                               type, present, maskse->expr);
    4821                 :             :     }
    4822                 :             :   else
    4823                 :        7125 :     return maskse->expr;
    4824                 :             : }
    4825                 :             : 
    4826                 :             : /* Inline implementation of the sum and product intrinsics.  */
    4827                 :             : static void
    4828                 :        2315 : gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
    4829                 :             :                           bool norm2)
    4830                 :             : {
    4831                 :        2315 :   tree resvar;
    4832                 :        2315 :   tree scale = NULL_TREE;
    4833                 :        2315 :   tree type;
    4834                 :        2315 :   stmtblock_t body;
    4835                 :        2315 :   stmtblock_t block;
    4836                 :        2315 :   tree tmp;
    4837                 :        2315 :   gfc_loopinfo loop, *ploop;
    4838                 :        2315 :   gfc_actual_arglist *arg_array, *arg_mask;
    4839                 :        2315 :   gfc_ss *arrayss = NULL;
    4840                 :        2315 :   gfc_ss *maskss = NULL;
    4841                 :        2315 :   gfc_se arrayse;
    4842                 :        2315 :   gfc_se maskse;
    4843                 :        2315 :   gfc_se *parent_se;
    4844                 :        2315 :   gfc_expr *arrayexpr;
    4845                 :        2315 :   gfc_expr *maskexpr;
    4846                 :        2315 :   bool optional_mask;
    4847                 :             : 
    4848                 :        2315 :   if (expr->rank > 0)
    4849                 :             :     {
    4850                 :         563 :       gcc_assert (gfc_inline_intrinsic_function_p (expr));
    4851                 :             :       parent_se = se;
    4852                 :             :     }
    4853                 :             :   else
    4854                 :             :     parent_se = NULL;
    4855                 :             : 
    4856                 :        2315 :   type = gfc_typenode_for_spec (&expr->ts);
    4857                 :             :   /* Initialize the result.  */
    4858                 :        2315 :   resvar = gfc_create_var (type, "val");
    4859                 :        2315 :   if (norm2)
    4860                 :             :     {
    4861                 :             :       /* result = 0.0;
    4862                 :             :          scale = 1.0.  */
    4863                 :          68 :       scale = gfc_create_var (type, "scale");
    4864                 :          68 :       gfc_add_modify (&se->pre, scale,
    4865                 :             :                       gfc_build_const (type, integer_one_node));
    4866                 :          68 :       tmp = gfc_build_const (type, integer_zero_node);
    4867                 :             :     }
    4868                 :        2247 :   else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
    4869                 :        1855 :     tmp = gfc_build_const (type, integer_zero_node);
    4870                 :         392 :   else if (op == NE_EXPR)
    4871                 :             :     /* PARITY.  */
    4872                 :          36 :     tmp = convert (type, boolean_false_node);
    4873                 :         356 :   else if (op == BIT_AND_EXPR)
    4874                 :          18 :     tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
    4875                 :             :                                                   type, integer_one_node));
    4876                 :             :   else
    4877                 :         338 :     tmp = gfc_build_const (type, integer_one_node);
    4878                 :             : 
    4879                 :        2315 :   gfc_add_modify (&se->pre, resvar, tmp);
    4880                 :             : 
    4881                 :        2315 :   arg_array = expr->value.function.actual;
    4882                 :             : 
    4883                 :        2315 :   arrayexpr = arg_array->expr;
    4884                 :             : 
    4885                 :        2315 :   if (op == NE_EXPR || norm2)
    4886                 :             :     {
    4887                 :             :       /* PARITY and NORM2.  */
    4888                 :             :       maskexpr = NULL;
    4889                 :             :       optional_mask = false;
    4890                 :             :     }
    4891                 :             :   else
    4892                 :             :     {
    4893                 :        2211 :       arg_mask  = arg_array->next->next;
    4894                 :        2211 :       gcc_assert (arg_mask != NULL);
    4895                 :        2211 :       maskexpr = arg_mask->expr;
    4896                 :         371 :       optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
    4897                 :         266 :         && maskexpr->symtree->n.sym->attr.dummy
    4898                 :        2477 :         && maskexpr->symtree->n.sym->attr.optional;
    4899                 :             :     }
    4900                 :             : 
    4901                 :        2315 :   if (expr->rank == 0)
    4902                 :             :     {
    4903                 :             :       /* Walk the arguments.  */
    4904                 :        1752 :       arrayss = gfc_walk_expr (arrayexpr);
    4905                 :        1752 :       gcc_assert (arrayss != gfc_ss_terminator);
    4906                 :             : 
    4907                 :        1752 :       if (maskexpr && maskexpr->rank > 0)
    4908                 :             :         {
    4909                 :         223 :           maskss = gfc_walk_expr (maskexpr);
    4910                 :         223 :           gcc_assert (maskss != gfc_ss_terminator);
    4911                 :             :         }
    4912                 :             :       else
    4913                 :             :         maskss = NULL;
    4914                 :             : 
    4915                 :             :       /* Initialize the scalarizer.  */
    4916                 :        1752 :       gfc_init_loopinfo (&loop);
    4917                 :             : 
    4918                 :             :       /* We add the mask first because the number of iterations is
    4919                 :             :          taken from the last ss, and this breaks if an absent
    4920                 :             :          optional argument is used for mask.  */
    4921                 :             : 
    4922                 :        1752 :       if (maskexpr && maskexpr->rank > 0)
    4923                 :         223 :         gfc_add_ss_to_loop (&loop, maskss);
    4924                 :        1752 :       gfc_add_ss_to_loop (&loop, arrayss);
    4925                 :             : 
    4926                 :             :       /* Initialize the loop.  */
    4927                 :        1752 :       gfc_conv_ss_startstride (&loop);
    4928                 :        1752 :       gfc_conv_loop_setup (&loop, &expr->where);
    4929                 :             : 
    4930                 :        1752 :       if (maskexpr && maskexpr->rank > 0)
    4931                 :         223 :         gfc_mark_ss_chain_used (maskss, 1);
    4932                 :        1752 :       gfc_mark_ss_chain_used (arrayss, 1);
    4933                 :             : 
    4934                 :        1752 :       ploop = &loop;
    4935                 :             :     }
    4936                 :             :   else
    4937                 :             :     /* All the work has been done in the parent loops.  */
    4938                 :         563 :     ploop = enter_nested_loop (se);
    4939                 :             : 
    4940                 :        2315 :   gcc_assert (ploop);
    4941                 :             : 
    4942                 :             :   /* Generate the loop body.  */
    4943                 :        2315 :   gfc_start_scalarized_body (ploop, &body);
    4944                 :             : 
    4945                 :             :   /* If we have a mask, only add this element if the mask is set.  */
    4946                 :        2315 :   if (maskexpr && maskexpr->rank > 0)
    4947                 :             :     {
    4948                 :         307 :       gfc_init_se (&maskse, parent_se);
    4949                 :         307 :       gfc_copy_loopinfo_to_se (&maskse, ploop);
    4950                 :         307 :       if (expr->rank == 0)
    4951                 :         223 :         maskse.ss = maskss;
    4952                 :         307 :       gfc_conv_expr_val (&maskse, maskexpr);
    4953                 :         307 :       gfc_add_block_to_block (&body, &maskse.pre);
    4954                 :             : 
    4955                 :         307 :       gfc_start_block (&block);
    4956                 :             :     }
    4957                 :             :   else
    4958                 :        2008 :     gfc_init_block (&block);
    4959                 :             : 
    4960                 :             :   /* Do the actual summation/product.  */
    4961                 :        2315 :   gfc_init_se (&arrayse, parent_se);
    4962                 :        2315 :   gfc_copy_loopinfo_to_se (&arrayse, ploop);
    4963                 :        2315 :   if (expr->rank == 0)
    4964                 :        1752 :     arrayse.ss = arrayss;
    4965                 :        2315 :   gfc_conv_expr_val (&arrayse, arrayexpr);
    4966                 :        2315 :   gfc_add_block_to_block (&block, &arrayse.pre);
    4967                 :             : 
    4968                 :        2315 :   if (norm2)
    4969                 :             :     {
    4970                 :             :       /* if (x (i) != 0.0)
    4971                 :             :            {
    4972                 :             :              absX = abs(x(i))
    4973                 :             :              if (absX > scale)
    4974                 :             :                {
    4975                 :             :                  val = scale/absX;
    4976                 :             :                  result = 1.0 + result * val * val;
    4977                 :             :                  scale = absX;
    4978                 :             :                }
    4979                 :             :              else
    4980                 :             :                {
    4981                 :             :                  val = absX/scale;
    4982                 :             :                  result += val * val;
    4983                 :             :                }
    4984                 :             :            }  */
    4985                 :          68 :       tree res1, res2, cond, absX, val;
    4986                 :          68 :       stmtblock_t ifblock1, ifblock2, ifblock3;
    4987                 :             : 
    4988                 :          68 :       gfc_init_block (&ifblock1);
    4989                 :             : 
    4990                 :          68 :       absX = gfc_create_var (type, "absX");
    4991                 :          68 :       gfc_add_modify (&ifblock1, absX,
    4992                 :             :                       fold_build1_loc (input_location, ABS_EXPR, type,
    4993                 :             :                                        arrayse.expr));
    4994                 :          68 :       val = gfc_create_var (type, "val");
    4995                 :          68 :       gfc_add_expr_to_block (&ifblock1, val);
    4996                 :             : 
    4997                 :          68 :       gfc_init_block (&ifblock2);
    4998                 :          68 :       gfc_add_modify (&ifblock2, val,
    4999                 :             :                       fold_build2_loc (input_location, RDIV_EXPR, type, scale,
    5000                 :             :                                        absX));
    5001                 :          68 :       res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
    5002                 :          68 :       res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
    5003                 :          68 :       res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
    5004                 :             :                               gfc_build_const (type, integer_one_node));
    5005                 :          68 :       gfc_add_modify (&ifblock2, resvar, res1);
    5006                 :          68 :       gfc_add_modify (&ifblock2, scale, absX);
    5007                 :          68 :       res1 = gfc_finish_block (&ifblock2);
    5008                 :             : 
    5009                 :          68 :       gfc_init_block (&ifblock3);
    5010                 :          68 :       gfc_add_modify (&ifblock3, val,
    5011                 :             :                       fold_build2_loc (input_location, RDIV_EXPR, type, absX,
    5012                 :             :                                        scale));
    5013                 :          68 :       res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
    5014                 :          68 :       res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
    5015                 :          68 :       gfc_add_modify (&ifblock3, resvar, res2);
    5016                 :          68 :       res2 = gfc_finish_block (&ifblock3);
    5017                 :             : 
    5018                 :          68 :       cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node,
    5019                 :             :                               absX, scale);
    5020                 :          68 :       tmp = build3_v (COND_EXPR, cond, res1, res2);
    5021                 :          68 :       gfc_add_expr_to_block (&ifblock1, tmp);
    5022                 :          68 :       tmp = gfc_finish_block (&ifblock1);
    5023                 :             : 
    5024                 :          68 :       cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    5025                 :             :                               arrayse.expr,
    5026                 :             :                               gfc_build_const (type, integer_zero_node));
    5027                 :             : 
    5028                 :          68 :       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
    5029                 :          68 :       gfc_add_expr_to_block (&block, tmp);
    5030                 :             :     }
    5031                 :             :   else
    5032                 :             :     {
    5033                 :        2247 :       tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
    5034                 :        2247 :       gfc_add_modify (&block, resvar, tmp);
    5035                 :             :     }
    5036                 :             : 
    5037                 :        2315 :   gfc_add_block_to_block (&block, &arrayse.post);
    5038                 :             : 
    5039                 :        2315 :   if (maskexpr && maskexpr->rank > 0)
    5040                 :             :     {
    5041                 :             :       /* We enclose the above in if (mask) {...} .  If the mask is an
    5042                 :             :          optional argument, generate
    5043                 :             :          IF (.NOT. PRESENT(MASK) .OR. MASK(I)).  */
    5044                 :         307 :       tree ifmask;
    5045                 :         307 :       tmp = gfc_finish_block (&block);
    5046                 :         307 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5047                 :         307 :       tmp = build3_v (COND_EXPR, ifmask, tmp,
    5048                 :             :                       build_empty_stmt (input_location));
    5049                 :         307 :     }
    5050                 :             :   else
    5051                 :        2008 :     tmp = gfc_finish_block (&block);
    5052                 :        2315 :   gfc_add_expr_to_block (&body, tmp);
    5053                 :             : 
    5054                 :        2315 :   gfc_trans_scalarizing_loops (ploop, &body);
    5055                 :             : 
    5056                 :             :   /* For a scalar mask, enclose the loop in an if statement.  */
    5057                 :        2315 :   if (maskexpr && maskexpr->rank == 0)
    5058                 :             :     {
    5059                 :          64 :       gfc_init_block (&block);
    5060                 :          64 :       gfc_add_block_to_block (&block, &ploop->pre);
    5061                 :          64 :       gfc_add_block_to_block (&block, &ploop->post);
    5062                 :          64 :       tmp = gfc_finish_block (&block);
    5063                 :             : 
    5064                 :          64 :       if (expr->rank > 0)
    5065                 :             :         {
    5066                 :          34 :           tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
    5067                 :             :                           build_empty_stmt (input_location));
    5068                 :          34 :           gfc_advance_se_ss_chain (se);
    5069                 :             :         }
    5070                 :             :       else
    5071                 :             :         {
    5072                 :          30 :           tree ifmask;
    5073                 :             : 
    5074                 :          30 :           gcc_assert (expr->rank == 0);
    5075                 :          30 :           gfc_init_se (&maskse, NULL);
    5076                 :          30 :           gfc_conv_expr_val (&maskse, maskexpr);
    5077                 :          30 :           ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5078                 :          30 :           tmp = build3_v (COND_EXPR, ifmask, tmp,
    5079                 :             :                           build_empty_stmt (input_location));
    5080                 :             :         }
    5081                 :             : 
    5082                 :          64 :       gfc_add_expr_to_block (&block, tmp);
    5083                 :          64 :       gfc_add_block_to_block (&se->pre, &block);
    5084                 :          64 :       gcc_assert (se->post.head == NULL);
    5085                 :             :     }
    5086                 :             :   else
    5087                 :             :     {
    5088                 :        2251 :       gfc_add_block_to_block (&se->pre, &ploop->pre);
    5089                 :        2251 :       gfc_add_block_to_block (&se->pre, &ploop->post);
    5090                 :             :     }
    5091                 :             : 
    5092                 :        2315 :   if (expr->rank == 0)
    5093                 :        1752 :     gfc_cleanup_loop (ploop);
    5094                 :             : 
    5095                 :        2315 :   if (norm2)
    5096                 :             :     {
    5097                 :             :       /* result = scale * sqrt(result).  */
    5098                 :          68 :       tree sqrt;
    5099                 :          68 :       sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
    5100                 :          68 :       resvar = build_call_expr_loc (input_location,
    5101                 :             :                                     sqrt, 1, resvar);
    5102                 :          68 :       resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
    5103                 :             :     }
    5104                 :             : 
    5105                 :        2315 :   se->expr = resvar;
    5106                 :        2315 : }
    5107                 :             : 
    5108                 :             : 
    5109                 :             : /* Inline implementation of the dot_product intrinsic. This function
    5110                 :             :    is based on gfc_conv_intrinsic_arith (the previous function).  */
    5111                 :             : static void
    5112                 :         111 : gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
    5113                 :             : {
    5114                 :         111 :   tree resvar;
    5115                 :         111 :   tree type;
    5116                 :         111 :   stmtblock_t body;
    5117                 :         111 :   stmtblock_t block;
    5118                 :         111 :   tree tmp;
    5119                 :         111 :   gfc_loopinfo loop;
    5120                 :         111 :   gfc_actual_arglist *actual;
    5121                 :         111 :   gfc_ss *arrayss1, *arrayss2;
    5122                 :         111 :   gfc_se arrayse1, arrayse2;
    5123                 :         111 :   gfc_expr *arrayexpr1, *arrayexpr2;
    5124                 :             : 
    5125                 :         111 :   type = gfc_typenode_for_spec (&expr->ts);
    5126                 :             : 
    5127                 :             :   /* Initialize the result.  */
    5128                 :         111 :   resvar = gfc_create_var (type, "val");
    5129                 :         111 :   if (expr->ts.type == BT_LOGICAL)
    5130                 :          30 :     tmp = build_int_cst (type, 0);
    5131                 :             :   else
    5132                 :          81 :     tmp = gfc_build_const (type, integer_zero_node);
    5133                 :             : 
    5134                 :         111 :   gfc_add_modify (&se->pre, resvar, tmp);
    5135                 :             : 
    5136                 :             :   /* Walk argument #1.  */
    5137                 :         111 :   actual = expr->value.function.actual;
    5138                 :         111 :   arrayexpr1 = actual->expr;
    5139                 :         111 :   arrayss1 = gfc_walk_expr (arrayexpr1);
    5140                 :         111 :   gcc_assert (arrayss1 != gfc_ss_terminator);
    5141                 :             : 
    5142                 :             :   /* Walk argument #2.  */
    5143                 :         111 :   actual = actual->next;
    5144                 :         111 :   arrayexpr2 = actual->expr;
    5145                 :         111 :   arrayss2 = gfc_walk_expr (arrayexpr2);
    5146                 :         111 :   gcc_assert (arrayss2 != gfc_ss_terminator);
    5147                 :             : 
    5148                 :             :   /* Initialize the scalarizer.  */
    5149                 :         111 :   gfc_init_loopinfo (&loop);
    5150                 :         111 :   gfc_add_ss_to_loop (&loop, arrayss1);
    5151                 :         111 :   gfc_add_ss_to_loop (&loop, arrayss2);
    5152                 :             : 
    5153                 :             :   /* Initialize the loop.  */
    5154                 :         111 :   gfc_conv_ss_startstride (&loop);
    5155                 :         111 :   gfc_conv_loop_setup (&loop, &expr->where);
    5156                 :             : 
    5157                 :         111 :   gfc_mark_ss_chain_used (arrayss1, 1);
    5158                 :         111 :   gfc_mark_ss_chain_used (arrayss2, 1);
    5159                 :             : 
    5160                 :             :   /* Generate the loop body.  */
    5161                 :         111 :   gfc_start_scalarized_body (&loop, &body);
    5162                 :         111 :   gfc_init_block (&block);
    5163                 :             : 
    5164                 :             :   /* Make the tree expression for [conjg(]array1[)].  */
    5165                 :         111 :   gfc_init_se (&arrayse1, NULL);
    5166                 :         111 :   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
    5167                 :         111 :   arrayse1.ss = arrayss1;
    5168                 :         111 :   gfc_conv_expr_val (&arrayse1, arrayexpr1);
    5169                 :         111 :   if (expr->ts.type == BT_COMPLEX)
    5170                 :           9 :     arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
    5171                 :             :                                      arrayse1.expr);
    5172                 :         111 :   gfc_add_block_to_block (&block, &arrayse1.pre);
    5173                 :             : 
    5174                 :             :   /* Make the tree expression for array2.  */
    5175                 :         111 :   gfc_init_se (&arrayse2, NULL);
    5176                 :         111 :   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
    5177                 :         111 :   arrayse2.ss = arrayss2;
    5178                 :         111 :   gfc_conv_expr_val (&arrayse2, arrayexpr2);
    5179                 :         111 :   gfc_add_block_to_block (&block, &arrayse2.pre);
    5180                 :             : 
    5181                 :             :   /* Do the actual product and sum.  */
    5182                 :         111 :   if (expr->ts.type == BT_LOGICAL)
    5183                 :             :     {
    5184                 :          30 :       tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
    5185                 :             :                              arrayse1.expr, arrayse2.expr);
    5186                 :          30 :       tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
    5187                 :             :     }
    5188                 :             :   else
    5189                 :             :     {
    5190                 :          81 :       tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
    5191                 :             :                              arrayse2.expr);
    5192                 :          81 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
    5193                 :             :     }
    5194                 :         111 :   gfc_add_modify (&block, resvar, tmp);
    5195                 :             : 
    5196                 :             :   /* Finish up the loop block and the loop.  */
    5197                 :         111 :   tmp = gfc_finish_block (&block);
    5198                 :         111 :   gfc_add_expr_to_block (&body, tmp);
    5199                 :             : 
    5200                 :         111 :   gfc_trans_scalarizing_loops (&loop, &body);
    5201                 :         111 :   gfc_add_block_to_block (&se->pre, &loop.pre);
    5202                 :         111 :   gfc_add_block_to_block (&se->pre, &loop.post);
    5203                 :         111 :   gfc_cleanup_loop (&loop);
    5204                 :             : 
    5205                 :         111 :   se->expr = resvar;
    5206                 :         111 : }
    5207                 :             : 
    5208                 :             : 
    5209                 :             : /* Remove unneeded kind= argument from actual argument list when the
    5210                 :             :    result conversion is dealt with in a different place.  */
    5211                 :             : 
    5212                 :             : static void
    5213                 :          76 : strip_kind_from_actual (gfc_actual_arglist * actual)
    5214                 :             : {
    5215                 :         456 :   for (gfc_actual_arglist *a = actual; a; a = a->next)
    5216                 :             :     {
    5217                 :         380 :       if (a && a->name && strcmp (a->name, "kind") == 0)
    5218                 :             :         {
    5219                 :          12 :           gfc_free_expr (a->expr);
    5220                 :          12 :           a->expr = NULL;
    5221                 :             :         }
    5222                 :             :     }
    5223                 :          76 : }
    5224                 :             : 
    5225                 :             : /* Emit code for minloc or maxloc intrinsic.  There are many different cases
    5226                 :             :    we need to handle.  For performance reasons we sometimes create two
    5227                 :             :    loops instead of one, where the second one is much simpler.
    5228                 :             :    Examples for minloc intrinsic:
    5229                 :             :    1) Result is an array, a call is generated
    5230                 :             :    2) Array mask is used and NaNs need to be supported:
    5231                 :             :       limit = Infinity;
    5232                 :             :       pos = 0;
    5233                 :             :       S = from;
    5234                 :             :       while (S <= to) {
    5235                 :             :         if (mask[S]) {
    5236                 :             :           if (pos == 0) pos = S + (1 - from);
    5237                 :             :           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
    5238                 :             :         }
    5239                 :             :         S++;
    5240                 :             :       }
    5241                 :             :       goto lab2;
    5242                 :             :       lab1:;
    5243                 :             :       while (S <= to) {
    5244                 :             :         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
    5245                 :             :         S++;
    5246                 :             :       }
    5247                 :             :       lab2:;
    5248                 :             :    3) NaNs need to be supported, but it is known at compile time or cheaply
    5249                 :             :       at runtime whether array is nonempty or not:
    5250                 :             :       limit = Infinity;
    5251                 :             :       pos = 0;
    5252                 :             :       S = from;
    5253                 :             :       while (S <= to) {
    5254                 :             :         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
    5255                 :             :         S++;
    5256                 :             :       }
    5257                 :             :       if (from <= to) pos = 1;
    5258                 :             :       goto lab2;
    5259                 :             :       lab1:;
    5260                 :             :       while (S <= to) {
    5261                 :             :         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
    5262                 :             :         S++;
    5263                 :             :       }
    5264                 :             :       lab2:;
    5265                 :             :    4) NaNs aren't supported, array mask is used:
    5266                 :             :       limit = infinities_supported ? Infinity : huge (limit);
    5267                 :             :       pos = 0;
    5268                 :             :       S = from;
    5269                 :             :       while (S <= to) {
    5270                 :             :         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
    5271                 :             :         S++;
    5272                 :             :       }
    5273                 :             :       goto lab2;
    5274                 :             :       lab1:;
    5275                 :             :       while (S <= to) {
    5276                 :             :         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
    5277                 :             :         S++;
    5278                 :             :       }
    5279                 :             :       lab2:;
    5280                 :             :    5) Same without array mask:
    5281                 :             :       limit = infinities_supported ? Infinity : huge (limit);
    5282                 :             :       pos = (from <= to) ? 1 : 0;
    5283                 :             :       S = from;
    5284                 :             :       while (S <= to) {
    5285                 :             :         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
    5286                 :             :         S++;
    5287                 :             :       }
    5288                 :             :    For 3) and 5), if mask is scalar, this all goes into a conditional,
    5289                 :             :    setting pos = 0; in the else branch.
    5290                 :             : 
    5291                 :             :    Since we now also support the BACK argument, instead of using
    5292                 :             :    if (a[S] < limit), we now use
    5293                 :             : 
    5294                 :             :    if (back)
    5295                 :             :      cond = a[S] <= limit;
    5296                 :             :    else
    5297                 :             :      cond = a[S] < limit;
    5298                 :             :    if (cond) {
    5299                 :             :      ....
    5300                 :             : 
    5301                 :             :      The optimizer is smart enough to move the condition out of the loop.
    5302                 :             :      The are now marked as unlikely to for further speedup.  */
    5303                 :             : 
    5304                 :             : static void
    5305                 :        7134 : gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
    5306                 :             : {
    5307                 :        7134 :   stmtblock_t body;
    5308                 :        7134 :   stmtblock_t block;
    5309                 :        7134 :   stmtblock_t ifblock;
    5310                 :        7134 :   stmtblock_t elseblock;
    5311                 :        7134 :   tree limit;
    5312                 :        7134 :   tree type;
    5313                 :        7134 :   tree tmp;
    5314                 :        7134 :   tree cond;
    5315                 :        7134 :   tree elsetmp;
    5316                 :        7134 :   tree ifbody;
    5317                 :        7134 :   tree offset;
    5318                 :        7134 :   tree nonempty;
    5319                 :        7134 :   tree lab1, lab2;
    5320                 :        7134 :   tree b_if, b_else;
    5321                 :        7134 :   gfc_loopinfo loop;
    5322                 :        7134 :   gfc_actual_arglist *actual;
    5323                 :        7134 :   gfc_ss *arrayss;
    5324                 :        7134 :   gfc_ss *maskss;
    5325                 :        7134 :   gfc_se arrayse;
    5326                 :        7134 :   gfc_se maskse;
    5327                 :        7134 :   gfc_expr *arrayexpr;
    5328                 :        7134 :   gfc_expr *maskexpr;
    5329                 :        7134 :   gfc_expr *backexpr;
    5330                 :        7134 :   gfc_se backse;
    5331                 :        7134 :   tree pos;
    5332                 :        7134 :   int n;
    5333                 :        7134 :   bool optional_mask;
    5334                 :             : 
    5335                 :        7134 :   actual = expr->value.function.actual;
    5336                 :             : 
    5337                 :             :   /* The last argument, BACK, is passed by value. Ensure that
    5338                 :             :      by setting its name to %VAL. */
    5339                 :       42804 :   for (gfc_actual_arglist *a = actual; a; a = a->next)
    5340                 :             :     {
    5341                 :       35670 :       if (a->next == NULL)
    5342                 :        7134 :         a->name = "%VAL";
    5343                 :             :     }
    5344                 :             : 
    5345                 :        7134 :   if (se->ss)
    5346                 :             :     {
    5347                 :        2924 :       gfc_conv_intrinsic_funcall (se, expr);
    5348                 :        5924 :       return;
    5349                 :             :     }
    5350                 :             : 
    5351                 :        4210 :   arrayexpr = actual->expr;
    5352                 :             : 
    5353                 :             :   /* Special case for character maxloc.  Remove unneeded actual
    5354                 :             :      arguments, then call a library function.  */
    5355                 :             : 
    5356                 :        4210 :   if (arrayexpr->ts.type == BT_CHARACTER)
    5357                 :             :     {
    5358                 :          76 :       gfc_actual_arglist *a;
    5359                 :          76 :       a = actual;
    5360                 :          76 :       strip_kind_from_actual (a);
    5361                 :         532 :       while (a)
    5362                 :             :         {
    5363                 :         380 :           if (a->name && strcmp (a->name, "dim") == 0)
    5364                 :             :             {
    5365                 :          76 :               gfc_free_expr (a->expr);
    5366                 :          76 :               a->expr = NULL;
    5367                 :             :             }
    5368                 :         380 :           a = a->next;
    5369                 :             :         }
    5370                 :          76 :       gfc_conv_intrinsic_funcall (se, expr);
    5371                 :          76 :       return;
    5372                 :             :     }
    5373                 :             : 
    5374                 :             :   /* Initialize the result.  */
    5375                 :        4134 :   pos = gfc_create_var (gfc_array_index_type, "pos");
    5376                 :        4134 :   offset = gfc_create_var (gfc_array_index_type, "offset");
    5377                 :        4134 :   type = gfc_typenode_for_spec (&expr->ts);
    5378                 :             : 
    5379                 :             :   /* Walk the arguments.  */
    5380                 :        4134 :   arrayss = gfc_walk_expr (arrayexpr);
    5381                 :        4134 :   gcc_assert (arrayss != gfc_ss_terminator);
    5382                 :             : 
    5383                 :        4134 :   actual = actual->next->next;
    5384                 :        4134 :   gcc_assert (actual);
    5385                 :        4134 :   maskexpr = actual->expr;
    5386                 :        3098 :   optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
    5387                 :        2523 :     && maskexpr->symtree->n.sym->attr.dummy
    5388                 :        6657 :     && maskexpr->symtree->n.sym->attr.optional;
    5389                 :        4134 :   backexpr = actual->next->next->expr;
    5390                 :        4134 :   nonempty = NULL;
    5391                 :        4134 :   if (maskexpr && maskexpr->rank != 0)
    5392                 :             :     {
    5393                 :        1766 :       maskss = gfc_walk_expr (maskexpr);
    5394                 :        1766 :       gcc_assert (maskss != gfc_ss_terminator);
    5395                 :             :     }
    5396                 :             :   else
    5397                 :             :     {
    5398                 :        2368 :       mpz_t asize;
    5399                 :        2368 :       if (gfc_array_size (arrayexpr, &asize))
    5400                 :             :         {
    5401                 :        1619 :           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
    5402                 :        1619 :           mpz_clear (asize);
    5403                 :        1619 :           nonempty = fold_build2_loc (input_location, GT_EXPR,
    5404                 :             :                                       logical_type_node, nonempty,
    5405                 :             :                                       gfc_index_zero_node);
    5406                 :             :         }
    5407                 :        2368 :       maskss = NULL;
    5408                 :             :     }
    5409                 :             : 
    5410                 :        4134 :   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
    5411                 :        4134 :   switch (arrayexpr->ts.type)
    5412                 :             :     {
    5413                 :        1531 :     case BT_REAL:
    5414                 :        1531 :       tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
    5415                 :        1531 :       break;
    5416                 :             : 
    5417                 :        2603 :     case BT_INTEGER:
    5418                 :        2603 :       n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
    5419                 :        2603 :       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
    5420                 :             :                                   arrayexpr->ts.kind);
    5421                 :        2603 :       break;
    5422                 :             : 
    5423                 :           0 :     default:
    5424                 :           0 :       gcc_unreachable ();
    5425                 :             :     }
    5426                 :             : 
    5427                 :             :   /* We start with the most negative possible value for MAXLOC, and the most
    5428                 :             :      positive possible value for MINLOC. The most negative possible value is
    5429                 :             :      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
    5430                 :             :      possible value is HUGE in both cases.  */
    5431                 :        4134 :   if (op == GT_EXPR)
    5432                 :        1866 :     tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
    5433                 :        1866 :   if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
    5434                 :        1206 :     tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
    5435                 :        1206 :                            build_int_cst (TREE_TYPE (tmp), 1));
    5436                 :             : 
    5437                 :        4134 :   gfc_add_modify (&se->pre, limit, tmp);
    5438                 :             : 
    5439                 :             :   /* Initialize the scalarizer.  */
    5440                 :        4134 :   gfc_init_loopinfo (&loop);
    5441                 :             : 
    5442                 :             :   /* We add the mask first because the number of iterations is taken
    5443                 :             :      from the last ss, and this breaks if an absent optional argument
    5444                 :             :      is used for mask.  */
    5445                 :             : 
    5446                 :        4134 :   if (maskss)
    5447                 :        1766 :     gfc_add_ss_to_loop (&loop, maskss);
    5448                 :             : 
    5449                 :        4134 :   gfc_add_ss_to_loop (&loop, arrayss);
    5450                 :             : 
    5451                 :             :   /* Initialize the loop.  */
    5452                 :        4134 :   gfc_conv_ss_startstride (&loop);
    5453                 :             : 
    5454                 :             :   /* The code generated can have more than one loop in sequence (see the
    5455                 :             :      comment at the function header).  This doesn't work well with the
    5456                 :             :      scalarizer, which changes arrays' offset when the scalarization loops
    5457                 :             :      are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}loc
    5458                 :             :      are  currently inlined in the scalar case only (for which loop is of rank
    5459                 :             :      one).  As there is no dependency to care about in that case, there is no
    5460                 :             :      temporary, so that we can use the scalarizer temporary code to handle
    5461                 :             :      multiple loops.  Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
    5462                 :             :      with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
    5463                 :             :      to restore offset.
    5464                 :             :      TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
    5465                 :             :      should eventually go away.  We could either create two loops properly,
    5466                 :             :      or find another way to save/restore the array offsets between the two
    5467                 :             :      loops (without conflicting with temporary management), or use a single
    5468                 :             :      loop minmaxloc implementation.  See PR 31067.  */
    5469                 :        4134 :   loop.temp_dim = loop.dimen;
    5470                 :        4134 :   gfc_conv_loop_setup (&loop, &expr->where);
    5471                 :             : 
    5472                 :        4134 :   gcc_assert (loop.dimen == 1);
    5473                 :        4134 :   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
    5474                 :         749 :     nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
    5475                 :             :                                 loop.from[0], loop.to[0]);
    5476                 :             : 
    5477                 :        4134 :   lab1 = NULL;
    5478                 :        4134 :   lab2 = NULL;
    5479                 :             :   /* Initialize the position to zero, following Fortran 2003.  We are free
    5480                 :             :      to do this because Fortran 95 allows the result of an entirely false
    5481                 :             :      mask to be processor dependent.  If we know at compile time the array
    5482                 :             :      is non-empty and no MASK is used, we can initialize to 1 to simplify
    5483                 :             :      the inner loop.  */
    5484                 :        4134 :   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
    5485                 :        1491 :     gfc_add_modify (&loop.pre, pos,
    5486                 :             :                     fold_build3_loc (input_location, COND_EXPR,
    5487                 :             :                                      gfc_array_index_type,
    5488                 :             :                                      nonempty, gfc_index_one_node,
    5489                 :             :                                      gfc_index_zero_node));
    5490                 :             :   else
    5491                 :             :     {
    5492                 :        2643 :       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
    5493                 :        2643 :       lab1 = gfc_build_label_decl (NULL_TREE);
    5494                 :        2643 :       TREE_USED (lab1) = 1;
    5495                 :        2643 :       lab2 = gfc_build_label_decl (NULL_TREE);
    5496                 :        2643 :       TREE_USED (lab2) = 1;
    5497                 :             :     }
    5498                 :             : 
    5499                 :             :   /* An offset must be added to the loop
    5500                 :             :      counter to obtain the required position.  */
    5501                 :        4134 :   gcc_assert (loop.from[0]);
    5502                 :             : 
    5503                 :        4134 :   tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5504                 :             :                          gfc_index_one_node, loop.from[0]);
    5505                 :        4134 :   gfc_add_modify (&loop.pre, offset, tmp);
    5506                 :             : 
    5507                 :        5625 :   gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
    5508                 :        4134 :   if (maskss)
    5509                 :        1766 :     gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
    5510                 :             :   /* Generate the loop body.  */
    5511                 :        4134 :   gfc_start_scalarized_body (&loop, &body);
    5512                 :             : 
    5513                 :             :   /* If we have a mask, only check this element if the mask is set.  */
    5514                 :        4134 :   if (maskss)
    5515                 :             :     {
    5516                 :        1766 :       gfc_init_se (&maskse, NULL);
    5517                 :        1766 :       gfc_copy_loopinfo_to_se (&maskse, &loop);
    5518                 :        1766 :       maskse.ss = maskss;
    5519                 :        1766 :       gfc_conv_expr_val (&maskse, maskexpr);
    5520                 :        1766 :       gfc_add_block_to_block (&body, &maskse.pre);
    5521                 :             : 
    5522                 :        1766 :       gfc_start_block (&block);
    5523                 :             :     }
    5524                 :             :   else
    5525                 :        2368 :     gfc_init_block (&block);
    5526                 :             : 
    5527                 :             :   /* Compare with the current limit.  */
    5528                 :        4134 :   gfc_init_se (&arrayse, NULL);
    5529                 :        4134 :   gfc_copy_loopinfo_to_se (&arrayse, &loop);
    5530                 :        4134 :   arrayse.ss = arrayss;
    5531                 :        4134 :   gfc_conv_expr_val (&arrayse, arrayexpr);
    5532                 :        4134 :   gfc_add_block_to_block (&block, &arrayse.pre);
    5533                 :             : 
    5534                 :        4134 :   gfc_init_se (&backse, NULL);
    5535                 :        4134 :   gfc_conv_expr_val (&backse, backexpr);
    5536                 :        4134 :   gfc_add_block_to_block (&block, &backse.pre);
    5537                 :             : 
    5538                 :             :   /* We do the following if this is a more extreme value.  */
    5539                 :        4134 :   gfc_start_block (&ifblock);
    5540                 :             : 
    5541                 :             :   /* Assign the value to the limit...  */
    5542                 :        4134 :   gfc_add_modify (&ifblock, limit, arrayse.expr);
    5543                 :             : 
    5544                 :        4134 :   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
    5545                 :             :     {
    5546                 :         654 :       stmtblock_t ifblock2;
    5547                 :         654 :       tree ifbody2;
    5548                 :             : 
    5549                 :         654 :       gfc_start_block (&ifblock2);
    5550                 :         654 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
    5551                 :             :                              loop.loopvar[0], offset);
    5552                 :         654 :       gfc_add_modify (&ifblock2, pos, tmp);
    5553                 :         654 :       ifbody2 = gfc_finish_block (&ifblock2);
    5554                 :         654 :       cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pos,
    5555                 :             :                               gfc_index_zero_node);
    5556                 :         654 :       tmp = build3_v (COND_EXPR, cond, ifbody2,
    5557                 :             :                       build_empty_stmt (input_location));
    5558                 :         654 :       gfc_add_expr_to_block (&block, tmp);
    5559                 :             :     }
    5560                 :             : 
    5561                 :        4134 :   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
    5562                 :             :                          loop.loopvar[0], offset);
    5563                 :        4134 :   gfc_add_modify (&ifblock, pos, tmp);
    5564                 :             : 
    5565                 :        4134 :   if (lab1)
    5566                 :        2643 :     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
    5567                 :             : 
    5568                 :        4134 :   ifbody = gfc_finish_block (&ifblock);
    5569                 :             : 
    5570                 :        4134 :   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
    5571                 :             :     {
    5572                 :        3022 :       if (lab1)
    5573                 :        2402 :         cond = fold_build2_loc (input_location,
    5574                 :             :                                 op == GT_EXPR ? GE_EXPR : LE_EXPR,
    5575                 :             :                                 logical_type_node, arrayse.expr, limit);
    5576                 :             :       else
    5577                 :             :         {
    5578                 :        1491 :           tree ifbody2, elsebody2;
    5579                 :             : 
    5580                 :             :           /* We switch to > or >= depending on the value of the BACK argument. */
    5581                 :        1491 :           cond = gfc_create_var (logical_type_node, "cond");
    5582                 :             : 
    5583                 :        1491 :           gfc_start_block (&ifblock);
    5584                 :        2265 :           b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
    5585                 :             :                                   logical_type_node, arrayse.expr, limit);
    5586                 :             : 
    5587                 :        1491 :           gfc_add_modify (&ifblock, cond, b_if);
    5588                 :        1491 :           ifbody2 = gfc_finish_block (&ifblock);
    5589                 :             : 
    5590                 :        1491 :           gfc_start_block (&elseblock);
    5591                 :        1491 :           b_else = fold_build2_loc (input_location, op, logical_type_node,
    5592                 :             :                                     arrayse.expr, limit);
    5593                 :             : 
    5594                 :        1491 :           gfc_add_modify (&elseblock, cond, b_else);
    5595                 :        1491 :           elsebody2 = gfc_finish_block (&elseblock);
    5596                 :             : 
    5597                 :        1491 :           tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
    5598                 :             :                                  backse.expr, ifbody2, elsebody2);
    5599                 :             : 
    5600                 :        1491 :           gfc_add_expr_to_block (&block, tmp);
    5601                 :             :         }
    5602                 :             : 
    5603                 :        3022 :       cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
    5604                 :        3022 :       ifbody = build3_v (COND_EXPR, cond, ifbody,
    5605                 :             :                          build_empty_stmt (input_location));
    5606                 :             :     }
    5607                 :        4134 :   gfc_add_expr_to_block (&block, ifbody);
    5608                 :             : 
    5609                 :        4134 :   if (maskss)
    5610                 :             :     {
    5611                 :             :       /* We enclose the above in if (mask) {...}.  If the mask is an
    5612                 :             :          optional argument, generate IF (.NOT. PRESENT(MASK)
    5613                 :             :          .OR. MASK(I)). */
    5614                 :             : 
    5615                 :        1766 :       tree ifmask;
    5616                 :        1766 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5617                 :        1766 :       tmp = gfc_finish_block (&block);
    5618                 :        1766 :       tmp = build3_v (COND_EXPR, ifmask, tmp,
    5619                 :             :                       build_empty_stmt (input_location));
    5620                 :             :     }
    5621                 :             :   else
    5622                 :        2368 :     tmp = gfc_finish_block (&block);
    5623                 :        4134 :   gfc_add_expr_to_block (&body, tmp);
    5624                 :             : 
    5625                 :        4134 :   if (lab1)
    5626                 :             :     {
    5627                 :        2643 :       gfc_trans_scalarized_loop_boundary (&loop, &body);
    5628                 :             : 
    5629                 :        2643 :       if (HONOR_NANS (DECL_MODE (limit)))
    5630                 :             :         {
    5631                 :        1531 :           if (nonempty != NULL)
    5632                 :             :             {
    5633                 :         877 :               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
    5634                 :         877 :               tmp = build3_v (COND_EXPR, nonempty, ifbody,
    5635                 :             :                               build_empty_stmt (input_location));
    5636                 :         877 :               gfc_add_expr_to_block (&loop.code[0], tmp);
    5637                 :             :             }
    5638                 :             :         }
    5639                 :             : 
    5640                 :        2643 :       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
    5641                 :        2643 :       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
    5642                 :             : 
    5643                 :             :       /* If we have a mask, only check this element if the mask is set.  */
    5644                 :        2643 :       if (maskss)
    5645                 :             :         {
    5646                 :        1766 :           gfc_init_se (&maskse, NULL);
    5647                 :        1766 :           gfc_copy_loopinfo_to_se (&maskse, &loop);
    5648                 :        1766 :           maskse.ss = maskss;
    5649                 :        1766 :           gfc_conv_expr_val (&maskse, maskexpr);
    5650                 :        1766 :           gfc_add_block_to_block (&body, &maskse.pre);
    5651                 :             : 
    5652                 :        1766 :           gfc_start_block (&block);
    5653                 :             :         }
    5654                 :             :       else
    5655                 :         877 :         gfc_init_block (&block);
    5656                 :             : 
    5657                 :             :       /* Compare with the current limit.  */
    5658                 :        2643 :       gfc_init_se (&arrayse, NULL);
    5659                 :        2643 :       gfc_copy_loopinfo_to_se (&arrayse, &loop);
    5660                 :        2643 :       arrayse.ss = arrayss;
    5661                 :        2643 :       gfc_conv_expr_val (&arrayse, arrayexpr);
    5662                 :        2643 :       gfc_add_block_to_block (&block, &arrayse.pre);
    5663                 :             : 
    5664                 :             :       /* We do the following if this is a more extreme value.  */
    5665                 :        2643 :       gfc_start_block (&ifblock);
    5666                 :             : 
    5667                 :             :       /* Assign the value to the limit...  */
    5668                 :        2643 :       gfc_add_modify (&ifblock, limit, arrayse.expr);
    5669                 :             : 
    5670                 :        2643 :       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
    5671                 :             :                              loop.loopvar[0], offset);
    5672                 :        2643 :       gfc_add_modify (&ifblock, pos, tmp);
    5673                 :             : 
    5674                 :        2643 :       ifbody = gfc_finish_block (&ifblock);
    5675                 :             : 
    5676                 :             :       /* We switch to > or >= depending on the value of the BACK argument. */
    5677                 :        2643 :       {
    5678                 :        2643 :         tree ifbody2, elsebody2;
    5679                 :             : 
    5680                 :        2643 :         cond = gfc_create_var (logical_type_node, "cond");
    5681                 :             : 
    5682                 :        2643 :         gfc_start_block (&ifblock);
    5683                 :        4137 :         b_if = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
    5684                 :             :                                 logical_type_node, arrayse.expr, limit);
    5685                 :             : 
    5686                 :        2643 :         gfc_add_modify (&ifblock, cond, b_if);
    5687                 :        2643 :         ifbody2 = gfc_finish_block (&ifblock);
    5688                 :             : 
    5689                 :        2643 :         gfc_start_block (&elseblock);
    5690                 :        2643 :         b_else = fold_build2_loc (input_location, op, logical_type_node,
    5691                 :             :                                   arrayse.expr, limit);
    5692                 :             : 
    5693                 :        2643 :         gfc_add_modify (&elseblock, cond, b_else);
    5694                 :        2643 :         elsebody2 = gfc_finish_block (&elseblock);
    5695                 :             : 
    5696                 :        2643 :         tmp = fold_build3_loc (input_location, COND_EXPR, logical_type_node,
    5697                 :             :                                backse.expr, ifbody2, elsebody2);
    5698                 :             :       }
    5699                 :             : 
    5700                 :        2643 :       gfc_add_expr_to_block (&block, tmp);
    5701                 :        2643 :       cond = gfc_unlikely (cond, PRED_BUILTIN_EXPECT);
    5702                 :        2643 :       tmp = build3_v (COND_EXPR, cond, ifbody,
    5703                 :             :                       build_empty_stmt (input_location));
    5704                 :             : 
    5705                 :        2643 :       gfc_add_expr_to_block (&block, tmp);
    5706                 :             : 
    5707                 :        2643 :       if (maskss)
    5708                 :             :         {
    5709                 :             :           /* We enclose the above in if (mask) {...}.  If the mask is
    5710                 :             :          an optional argument, generate IF (.NOT. PRESENT(MASK)
    5711                 :             :          .OR. MASK(I)).*/
    5712                 :             : 
    5713                 :        1766 :           tree ifmask;
    5714                 :        1766 :           ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5715                 :        1766 :           tmp = gfc_finish_block (&block);
    5716                 :        1766 :           tmp = build3_v (COND_EXPR, ifmask, tmp,
    5717                 :             :                           build_empty_stmt (input_location));
    5718                 :             :         }
    5719                 :             :       else
    5720                 :         877 :         tmp = gfc_finish_block (&block);
    5721                 :        2643 :       gfc_add_expr_to_block (&body, tmp);
    5722                 :             :       /* Avoid initializing loopvar[0] again, it should be left where
    5723                 :             :          it finished by the first loop.  */
    5724                 :        2643 :       loop.from[0] = loop.loopvar[0];
    5725                 :             :     }
    5726                 :             : 
    5727                 :        4134 :   gfc_trans_scalarizing_loops (&loop, &body);
    5728                 :             : 
    5729                 :        4134 :   if (lab2)
    5730                 :        2643 :     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
    5731                 :             : 
    5732                 :             :   /* For a scalar mask, enclose the loop in an if statement.  */
    5733                 :        4134 :   if (maskexpr && maskss == NULL)
    5734                 :             :     {
    5735                 :        1332 :       tree ifmask;
    5736                 :             : 
    5737                 :        1332 :       gfc_init_se (&maskse, NULL);
    5738                 :        1332 :       gfc_conv_expr_val (&maskse, maskexpr);
    5739                 :        1332 :       gfc_init_block (&block);
    5740                 :        1332 :       gfc_add_block_to_block (&block, &loop.pre);
    5741                 :        1332 :       gfc_add_block_to_block (&block, &loop.post);
    5742                 :        1332 :       tmp = gfc_finish_block (&block);
    5743                 :             : 
    5744                 :             :       /* For the else part of the scalar mask, just initialize
    5745                 :             :          the pos variable the same way as above.  */
    5746                 :             : 
    5747                 :        1332 :       gfc_init_block (&elseblock);
    5748                 :        1332 :       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
    5749                 :        1332 :       elsetmp = gfc_finish_block (&elseblock);
    5750                 :        1332 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5751                 :        1332 :       tmp = build3_v (COND_EXPR, ifmask, tmp, elsetmp);
    5752                 :        1332 :       gfc_add_expr_to_block (&block, tmp);
    5753                 :        1332 :       gfc_add_block_to_block (&se->pre, &block);
    5754                 :             :     }
    5755                 :             :   else
    5756                 :             :     {
    5757                 :        2802 :       gfc_add_block_to_block (&se->pre, &loop.pre);
    5758                 :        2802 :       gfc_add_block_to_block (&se->pre, &loop.post);
    5759                 :             :     }
    5760                 :        4134 :   gfc_cleanup_loop (&loop);
    5761                 :             : 
    5762                 :        4134 :   se->expr = convert (type, pos);
    5763                 :             : }
    5764                 :             : 
    5765                 :             : /* Emit code for findloc.  */
    5766                 :             : 
    5767                 :             : static void
    5768                 :         936 : gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
    5769                 :             : {
    5770                 :         936 :   gfc_actual_arglist *array_arg, *value_arg, *dim_arg, *mask_arg,
    5771                 :             :     *kind_arg, *back_arg;
    5772                 :         936 :   gfc_expr *value_expr;
    5773                 :         936 :   int ikind;
    5774                 :         936 :   tree resvar;
    5775                 :         936 :   stmtblock_t block;
    5776                 :         936 :   stmtblock_t body;
    5777                 :         936 :   stmtblock_t loopblock;
    5778                 :         936 :   tree type;
    5779                 :         936 :   tree tmp;
    5780                 :         936 :   tree found;
    5781                 :         936 :   tree forward_branch = NULL_TREE;
    5782                 :         936 :   tree back_branch;
    5783                 :         936 :   gfc_loopinfo loop;
    5784                 :         936 :   gfc_ss *arrayss;
    5785                 :         936 :   gfc_ss *maskss;
    5786                 :         936 :   gfc_se arrayse;
    5787                 :         936 :   gfc_se valuese;
    5788                 :         936 :   gfc_se maskse;
    5789                 :         936 :   gfc_se backse;
    5790                 :         936 :   tree exit_label;
    5791                 :         936 :   gfc_expr *maskexpr;
    5792                 :         936 :   tree offset;
    5793                 :         936 :   int i;
    5794                 :         936 :   bool optional_mask;
    5795                 :             : 
    5796                 :         936 :   array_arg = expr->value.function.actual;
    5797                 :         936 :   value_arg = array_arg->next;
    5798                 :         936 :   dim_arg   = value_arg->next;
    5799                 :         936 :   mask_arg  = dim_arg->next;
    5800                 :         936 :   kind_arg  = mask_arg->next;
    5801                 :         936 :   back_arg  = kind_arg->next;
    5802                 :             : 
    5803                 :             :   /* Remove kind and set ikind.  */
    5804                 :         936 :   if (kind_arg->expr)
    5805                 :             :     {
    5806                 :           0 :       ikind = mpz_get_si (kind_arg->expr->value.integer);
    5807                 :           0 :       gfc_free_expr (kind_arg->expr);
    5808                 :           0 :       kind_arg->expr = NULL;
    5809                 :             :     }
    5810                 :             :   else
    5811                 :         936 :     ikind = gfc_default_integer_kind;
    5812                 :             : 
    5813                 :         936 :   value_expr = value_arg->expr;
    5814                 :             : 
    5815                 :             :   /* Unless it's a string, pass VALUE by value.  */
    5816                 :         936 :   if (value_expr->ts.type != BT_CHARACTER)
    5817                 :         516 :     value_arg->name = "%VAL";
    5818                 :             : 
    5819                 :             :   /* Pass BACK argument by value.  */
    5820                 :         936 :   back_arg->name = "%VAL";
    5821                 :             : 
    5822                 :             :   /* Call the library if we have a character function or if
    5823                 :             :      rank > 0.  */
    5824                 :         936 :   if (se->ss || array_arg->expr->ts.type == BT_CHARACTER)
    5825                 :             :     {
    5826                 :         828 :       se->ignore_optional = 1;
    5827                 :         828 :       if (expr->rank == 0)
    5828                 :             :         {
    5829                 :             :           /* Remove dim argument.  */
    5830                 :          48 :           gfc_free_expr (dim_arg->expr);
    5831                 :          48 :           dim_arg->expr = NULL;
    5832                 :             :         }
    5833                 :         828 :       gfc_conv_intrinsic_funcall (se, expr);
    5834                 :         828 :       return;
    5835                 :             :     }
    5836                 :             : 
    5837                 :         108 :   type = gfc_get_int_type (ikind);
    5838                 :             : 
    5839                 :             :   /* Initialize the result.  */
    5840                 :         108 :   resvar = gfc_create_var (gfc_array_index_type, "pos");
    5841                 :         108 :   gfc_add_modify (&se->pre, resvar, build_int_cst (gfc_array_index_type, 0));
    5842                 :         108 :   offset = gfc_create_var (gfc_array_index_type, "offset");
    5843                 :             : 
    5844                 :         108 :   maskexpr = mask_arg->expr;
    5845                 :          72 :   optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
    5846                 :          60 :     && maskexpr->symtree->n.sym->attr.dummy
    5847                 :         168 :     && maskexpr->symtree->n.sym->attr.optional;
    5848                 :             : 
    5849                 :             :   /*  Generate two loops, one for BACK=.true. and one for BACK=.false.  */
    5850                 :             : 
    5851                 :         324 :   for (i = 0 ; i < 2; i++)
    5852                 :             :     {
    5853                 :             :       /* Walk the arguments.  */
    5854                 :         216 :       arrayss = gfc_walk_expr (array_arg->expr);
    5855                 :         216 :       gcc_assert (arrayss != gfc_ss_terminator);
    5856                 :             : 
    5857                 :         216 :       if (maskexpr && maskexpr->rank != 0)
    5858                 :             :         {
    5859                 :          84 :           maskss = gfc_walk_expr (maskexpr);
    5860                 :          84 :           gcc_assert (maskss != gfc_ss_terminator);
    5861                 :             :         }
    5862                 :             :       else
    5863                 :             :         maskss = NULL;
    5864                 :             : 
    5865                 :             :       /* Initialize the scalarizer.  */
    5866                 :         216 :       gfc_init_loopinfo (&loop);
    5867                 :         216 :       exit_label = gfc_build_label_decl (NULL_TREE);
    5868                 :         216 :       TREE_USED (exit_label) = 1;
    5869                 :             : 
    5870                 :             :       /* We add the mask first because the number of iterations is
    5871                 :             :          taken from the last ss, and this breaks if an absent
    5872                 :             :          optional argument is used for mask.  */
    5873                 :             : 
    5874                 :         216 :       if (maskss)
    5875                 :          84 :         gfc_add_ss_to_loop (&loop, maskss);
    5876                 :         216 :       gfc_add_ss_to_loop (&loop, arrayss);
    5877                 :             : 
    5878                 :             :       /* Initialize the loop.  */
    5879                 :         216 :       gfc_conv_ss_startstride (&loop);
    5880                 :         216 :       gfc_conv_loop_setup (&loop, &expr->where);
    5881                 :             : 
    5882                 :             :       /* Calculate the offset.  */
    5883                 :         216 :       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
    5884                 :             :                              gfc_index_one_node, loop.from[0]);
    5885                 :         216 :       gfc_add_modify (&loop.pre, offset, tmp);
    5886                 :             : 
    5887                 :         216 :       gfc_mark_ss_chain_used (arrayss, 1);
    5888                 :         216 :       if (maskss)
    5889                 :          84 :         gfc_mark_ss_chain_used (maskss, 1);
    5890                 :             : 
    5891                 :             :       /* The first loop is for BACK=.true.  */
    5892                 :         216 :       if (i == 0)
    5893                 :         108 :         loop.reverse[0] = GFC_REVERSE_SET;
    5894                 :             : 
    5895                 :             :       /* Generate the loop body.  */
    5896                 :         216 :       gfc_start_scalarized_body (&loop, &body);
    5897                 :             : 
    5898                 :             :       /* If we have an array mask, only add the element if it is
    5899                 :             :          set.  */
    5900                 :         216 :       if (maskss)
    5901                 :             :         {
    5902                 :          84 :           gfc_init_se (&maskse, NULL);
    5903                 :          84 :           gfc_copy_loopinfo_to_se (&maskse, &loop);
    5904                 :          84 :           maskse.ss = maskss;
    5905                 :          84 :           gfc_conv_expr_val (&maskse, maskexpr);
    5906                 :          84 :           gfc_add_block_to_block (&body, &maskse.pre);
    5907                 :             :         }
    5908                 :             : 
    5909                 :             :       /* If the condition matches then set the return value.  */
    5910                 :         216 :       gfc_start_block (&block);
    5911                 :             : 
    5912                 :             :       /* Add the offset.  */
    5913                 :         216 :       tmp = fold_build2_loc (input_location, PLUS_EXPR,
    5914                 :         216 :                              TREE_TYPE (resvar),
    5915                 :             :                              loop.loopvar[0], offset);
    5916                 :         216 :       gfc_add_modify (&block, resvar, tmp);
    5917                 :             :       /* And break out of the loop.  */
    5918                 :         216 :       tmp = build1_v (GOTO_EXPR, exit_label);
    5919                 :         216 :       gfc_add_expr_to_block (&block, tmp);
    5920                 :             : 
    5921                 :         216 :       found = gfc_finish_block (&block);
    5922                 :             : 
    5923                 :             :       /* Check this element.  */
    5924                 :         216 :       gfc_init_se (&arrayse, NULL);
    5925                 :         216 :       gfc_copy_loopinfo_to_se (&arrayse, &loop);
    5926                 :         216 :       arrayse.ss = arrayss;
    5927                 :         216 :       gfc_conv_expr_val (&arrayse, array_arg->expr);
    5928                 :         216 :       gfc_add_block_to_block (&body, &arrayse.pre);
    5929                 :             : 
    5930                 :         216 :       gfc_init_se (&valuese, NULL);
    5931                 :         216 :       gfc_conv_expr_val (&valuese, value_arg->expr);
    5932                 :         216 :       gfc_add_block_to_block (&body, &valuese.pre);
    5933                 :             : 
    5934                 :         216 :       tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    5935                 :             :                              arrayse.expr, valuese.expr);
    5936                 :             : 
    5937                 :         216 :       tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
    5938                 :         216 :       if (maskss)
    5939                 :             :         {
    5940                 :             :           /* We enclose the above in if (mask) {...}.  If the mask is
    5941                 :             :              an optional argument, generate IF (.NOT. PRESENT(MASK)
    5942                 :             :              .OR. MASK(I)). */
    5943                 :             : 
    5944                 :          84 :           tree ifmask;
    5945                 :          84 :           ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5946                 :          84 :           tmp = build3_v (COND_EXPR, ifmask, tmp,
    5947                 :             :                           build_empty_stmt (input_location));
    5948                 :             :         }
    5949                 :             : 
    5950                 :         216 :       gfc_add_expr_to_block (&body, tmp);
    5951                 :         216 :       gfc_add_block_to_block (&body, &arrayse.post);
    5952                 :             : 
    5953                 :         216 :       gfc_trans_scalarizing_loops (&loop, &body);
    5954                 :             : 
    5955                 :             :       /* Add the exit label.  */
    5956                 :         216 :       tmp = build1_v (LABEL_EXPR, exit_label);
    5957                 :         216 :       gfc_add_expr_to_block (&loop.pre, tmp);
    5958                 :         216 :       gfc_start_block (&loopblock);
    5959                 :         216 :       gfc_add_block_to_block (&loopblock, &loop.pre);
    5960                 :         216 :       gfc_add_block_to_block (&loopblock, &loop.post);
    5961                 :         216 :       if (i == 0)
    5962                 :         108 :         forward_branch = gfc_finish_block (&loopblock);
    5963                 :             :       else
    5964                 :         108 :         back_branch = gfc_finish_block (&loopblock);
    5965                 :             : 
    5966                 :         216 :       gfc_cleanup_loop (&loop);
    5967                 :             :     }
    5968                 :             : 
    5969                 :             :   /* Enclose the two loops in an IF statement.  */
    5970                 :             : 
    5971                 :         108 :   gfc_init_se (&backse, NULL);
    5972                 :         108 :   gfc_conv_expr_val (&backse, back_arg->expr);
    5973                 :         108 :   gfc_add_block_to_block (&se->pre, &backse.pre);
    5974                 :         108 :   tmp = build3_v (COND_EXPR, backse.expr, forward_branch, back_branch);
    5975                 :             : 
    5976                 :             :   /* For a scalar mask, enclose the loop in an if statement.  */
    5977                 :         108 :   if (maskexpr && maskss == NULL)
    5978                 :             :     {
    5979                 :          30 :       tree ifmask;
    5980                 :          30 :       tree if_stmt;
    5981                 :             : 
    5982                 :          30 :       gfc_init_se (&maskse, NULL);
    5983                 :          30 :       gfc_conv_expr_val (&maskse, maskexpr);
    5984                 :          30 :       gfc_init_block (&block);
    5985                 :          30 :       gfc_add_expr_to_block (&block, maskse.expr);
    5986                 :          30 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    5987                 :          30 :       if_stmt = build3_v (COND_EXPR, ifmask, tmp,
    5988                 :             :                           build_empty_stmt (input_location));
    5989                 :          30 :       gfc_add_expr_to_block (&block, if_stmt);
    5990                 :          30 :       tmp = gfc_finish_block (&block);
    5991                 :             :     }
    5992                 :             : 
    5993                 :         108 :   gfc_add_expr_to_block (&se->pre, tmp);
    5994                 :         108 :   se->expr = convert (type, resvar);
    5995                 :             : 
    5996                 :             : }
    5997                 :             : 
    5998                 :             : /* Emit code for minval or maxval intrinsic.  There are many different cases
    5999                 :             :    we need to handle.  For performance reasons we sometimes create two
    6000                 :             :    loops instead of one, where the second one is much simpler.
    6001                 :             :    Examples for minval intrinsic:
    6002                 :             :    1) Result is an array, a call is generated
    6003                 :             :    2) Array mask is used and NaNs need to be supported, rank 1:
    6004                 :             :       limit = Infinity;
    6005                 :             :       nonempty = false;
    6006                 :             :       S = from;
    6007                 :             :       while (S <= to) {
    6008                 :             :         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
    6009                 :             :         S++;
    6010                 :             :       }
    6011                 :             :       limit = nonempty ? NaN : huge (limit);
    6012                 :             :       lab:
    6013                 :             :       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
    6014                 :             :    3) NaNs need to be supported, but it is known at compile time or cheaply
    6015                 :             :       at runtime whether array is nonempty or not, rank 1:
    6016                 :             :       limit = Infinity;
    6017                 :             :       S = from;
    6018                 :             :       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
    6019                 :             :       limit = (from <= to) ? NaN : huge (limit);
    6020                 :             :       lab:
    6021                 :             :       while (S <= to) { limit = min (a[S], limit); S++; }
    6022                 :             :    4) Array mask is used and NaNs need to be supported, rank > 1:
    6023                 :             :       limit = Infinity;
    6024                 :             :       nonempty = false;
    6025                 :             :       fast = false;
    6026                 :             :       S1 = from1;
    6027                 :             :       while (S1 <= to1) {
    6028                 :             :         S2 = from2;
    6029                 :             :         while (S2 <= to2) {
    6030                 :             :           if (mask[S1][S2]) {
    6031                 :             :             if (fast) limit = min (a[S1][S2], limit);
    6032                 :             :             else {
    6033                 :             :               nonempty = true;
    6034                 :             :               if (a[S1][S2] <= limit) {
    6035                 :             :                 limit = a[S1][S2];
    6036                 :             :                 fast = true;
    6037                 :             :               }
    6038                 :             :             }
    6039                 :             :           }
    6040                 :             :           S2++;
    6041                 :             :         }
    6042                 :             :         S1++;
    6043                 :             :       }
    6044                 :             :       if (!fast)
    6045                 :             :         limit = nonempty ? NaN : huge (limit);
    6046                 :             :    5) NaNs need to be supported, but it is known at compile time or cheaply
    6047                 :             :       at runtime whether array is nonempty or not, rank > 1:
    6048                 :             :       limit = Infinity;
    6049                 :             :       fast = false;
    6050                 :             :       S1 = from1;
    6051                 :             :       while (S1 <= to1) {
    6052                 :             :         S2 = from2;
    6053                 :             :         while (S2 <= to2) {
    6054                 :             :           if (fast) limit = min (a[S1][S2], limit);
    6055                 :             :           else {
    6056                 :             :             if (a[S1][S2] <= limit) {
    6057                 :             :               limit = a[S1][S2];
    6058                 :             :               fast = true;
    6059                 :             :             }
    6060                 :             :           }
    6061                 :             :           S2++;
    6062                 :             :         }
    6063                 :             :         S1++;
    6064                 :             :       }
    6065                 :             :       if (!fast)
    6066                 :             :         limit = (nonempty_array) ? NaN : huge (limit);
    6067                 :             :    6) NaNs aren't supported, but infinities are.  Array mask is used:
    6068                 :             :       limit = Infinity;
    6069                 :             :       nonempty = false;
    6070                 :             :       S = from;
    6071                 :             :       while (S <= to) {
    6072                 :             :         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
    6073                 :             :         S++;
    6074                 :             :       }
    6075                 :             :       limit = nonempty ? limit : huge (limit);
    6076                 :             :    7) Same without array mask:
    6077                 :             :       limit = Infinity;
    6078                 :             :       S = from;
    6079                 :             :       while (S <= to) { limit = min (a[S], limit); S++; }
    6080                 :             :       limit = (from <= to) ? limit : huge (limit);
    6081                 :             :    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
    6082                 :             :       limit = huge (limit);
    6083                 :             :       S = from;
    6084                 :             :       while (S <= to) { limit = min (a[S], limit); S++); }
    6085                 :             :       (or
    6086                 :             :       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
    6087                 :             :       with array mask instead).
    6088                 :             :    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
    6089                 :             :    setting limit = huge (limit); in the else branch.  */
    6090                 :             : 
    6091                 :             : static void
    6092                 :        2311 : gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
    6093                 :             : {
    6094                 :        2311 :   tree limit;
    6095                 :        2311 :   tree type;
    6096                 :        2311 :   tree tmp;
    6097                 :        2311 :   tree ifbody;
    6098                 :        2311 :   tree nonempty;
    6099                 :        2311 :   tree nonempty_var;
    6100                 :        2311 :   tree lab;
    6101                 :        2311 :   tree fast;
    6102                 :        2311 :   tree huge_cst = NULL, nan_cst = NULL;
    6103                 :        2311 :   stmtblock_t body;
    6104                 :        2311 :   stmtblock_t block, block2;
    6105                 :        2311 :   gfc_loopinfo loop;
    6106                 :        2311 :   gfc_actual_arglist *actual;
    6107                 :        2311 :   gfc_ss *arrayss;
    6108                 :        2311 :   gfc_ss *maskss;
    6109                 :        2311 :   gfc_se arrayse;
    6110                 :        2311 :   gfc_se maskse;
    6111                 :        2311 :   gfc_expr *arrayexpr;
    6112                 :        2311 :   gfc_expr *maskexpr;
    6113                 :        2311 :   int n;
    6114                 :        2311 :   bool optional_mask;
    6115                 :             : 
    6116                 :        2311 :   if (se->ss)
    6117                 :             :     {
    6118                 :           0 :       gfc_conv_intrinsic_funcall (se, expr);
    6119                 :         186 :       return;
    6120                 :             :     }
    6121                 :             : 
    6122                 :        2311 :   actual = expr->value.function.actual;
    6123                 :        2311 :   arrayexpr = actual->expr;
    6124                 :             : 
    6125                 :        2311 :   if (arrayexpr->ts.type == BT_CHARACTER)
    6126                 :             :     {
    6127                 :         186 :       gfc_actual_arglist *dim = actual->next;
    6128                 :         186 :       if (expr->rank == 0 && dim->expr != 0)
    6129                 :             :         {
    6130                 :           6 :           gfc_free_expr (dim->expr);
    6131                 :           6 :           dim->expr = NULL;
    6132                 :             :         }
    6133                 :         186 :       gfc_conv_intrinsic_funcall (se, expr);
    6134                 :         186 :       return;
    6135                 :             :     }
    6136                 :             : 
    6137                 :        2125 :   type = gfc_typenode_for_spec (&expr->ts);
    6138                 :             :   /* Initialize the result.  */
    6139                 :        2125 :   limit = gfc_create_var (type, "limit");
    6140                 :        2125 :   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
    6141                 :        2125 :   switch (expr->ts.type)
    6142                 :             :     {
    6143                 :        1194 :     case BT_REAL:
    6144                 :        1194 :       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
    6145                 :             :                                         expr->ts.kind, 0);
    6146                 :        1194 :       if (HONOR_INFINITIES (DECL_MODE (limit)))
    6147                 :             :         {
    6148                 :        1192 :           REAL_VALUE_TYPE real;
    6149                 :        1192 :           real_inf (&real);
    6150                 :        1192 :           tmp = build_real (type, real);
    6151                 :             :         }
    6152                 :             :       else
    6153                 :             :         tmp = huge_cst;
    6154                 :        1194 :       if (HONOR_NANS (DECL_MODE (limit)))
    6155                 :        1192 :         nan_cst = gfc_build_nan (type, "");
    6156                 :             :       break;
    6157                 :             : 
    6158                 :         931 :     case BT_INTEGER:
    6159                 :         931 :       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
    6160                 :         931 :       break;
    6161                 :             : 
    6162                 :           0 :     default:
    6163                 :           0 :       gcc_unreachable ();
    6164                 :             :     }
    6165                 :             : 
    6166                 :             :   /* We start with the most negative possible value for MAXVAL, and the most
    6167                 :             :      positive possible value for MINVAL. The most negative possible value is
    6168                 :             :      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
    6169                 :             :      possible value is HUGE in both cases.  */
    6170                 :        2125 :   if (op == GT_EXPR)
    6171                 :             :     {
    6172                 :         913 :       tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
    6173                 :         913 :       if (huge_cst)
    6174                 :         511 :         huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
    6175                 :         511 :                                     TREE_TYPE (huge_cst), huge_cst);
    6176                 :             :     }
    6177                 :             : 
    6178                 :        2125 :   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
    6179                 :         402 :     tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
    6180                 :         402 :                            tmp, build_int_cst (type, 1));
    6181                 :             : 
    6182                 :        2125 :   gfc_add_modify (&se->pre, limit, tmp);
    6183                 :             : 
    6184                 :             :   /* Walk the arguments.  */
    6185                 :        2125 :   arrayss = gfc_walk_expr (arrayexpr);
    6186                 :        2125 :   gcc_assert (arrayss != gfc_ss_terminator);
    6187                 :             : 
    6188                 :        2125 :   actual = actual->next->next;
    6189                 :        2125 :   gcc_assert (actual);
    6190                 :        2125 :   maskexpr = actual->expr;
    6191                 :        1536 :   optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
    6192                 :        1524 :     && maskexpr->symtree->n.sym->attr.dummy
    6193                 :        3649 :     && maskexpr->symtree->n.sym->attr.optional;
    6194                 :        1524 :   nonempty = NULL;
    6195                 :        1536 :   if (maskexpr && maskexpr->rank != 0)
    6196                 :             :     {
    6197                 :         990 :       maskss = gfc_walk_expr (maskexpr);
    6198                 :         990 :       gcc_assert (maskss != gfc_ss_terminator);
    6199                 :             :     }
    6200                 :             :   else
    6201                 :             :     {
    6202                 :        1135 :       mpz_t asize;
    6203                 :        1135 :       if (gfc_array_size (arrayexpr, &asize))
    6204                 :             :         {
    6205                 :         624 :           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
    6206                 :         624 :           mpz_clear (asize);
    6207                 :         624 :           nonempty = fold_build2_loc (input_location, GT_EXPR,
    6208                 :             :                                       logical_type_node, nonempty,
    6209                 :             :                                       gfc_index_zero_node);
    6210                 :             :         }
    6211                 :        1135 :       maskss = NULL;
    6212                 :             :     }
    6213                 :             : 
    6214                 :             :   /* Initialize the scalarizer.  */
    6215                 :        2125 :   gfc_init_loopinfo (&loop);
    6216                 :             : 
    6217                 :             :   /* We add the mask first because the number of iterations is taken
    6218                 :             :      from the last ss, and this breaks if an absent optional argument
    6219                 :             :      is used for mask.  */
    6220                 :             : 
    6221                 :        2125 :   if (maskss)
    6222                 :         990 :     gfc_add_ss_to_loop (&loop, maskss);
    6223                 :        2125 :   gfc_add_ss_to_loop (&loop, arrayss);
    6224                 :             : 
    6225                 :             :   /* Initialize the loop.  */
    6226                 :        2125 :   gfc_conv_ss_startstride (&loop);
    6227                 :             : 
    6228                 :             :   /* The code generated can have more than one loop in sequence (see the
    6229                 :             :      comment at the function header).  This doesn't work well with the
    6230                 :             :      scalarizer, which changes arrays' offset when the scalarization loops
    6231                 :             :      are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}val
    6232                 :             :      are  currently inlined in the scalar case only.  As there is no dependency
    6233                 :             :      to care about in that case, there is no temporary, so that we can use the
    6234                 :             :      scalarizer temporary code to handle multiple loops.  Thus, we set temp_dim
    6235                 :             :      here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
    6236                 :             :      gfc_trans_scalarized_loop_boundary even later to restore offset.
    6237                 :             :      TODO: this prevents inlining of rank > 0 minmaxval calls, so this
    6238                 :             :      should eventually go away.  We could either create two loops properly,
    6239                 :             :      or find another way to save/restore the array offsets between the two
    6240                 :             :      loops (without conflicting with temporary management), or use a single
    6241                 :             :      loop minmaxval implementation.  See PR 31067.  */
    6242                 :        2125 :   loop.temp_dim = loop.dimen;
    6243                 :        2125 :   gfc_conv_loop_setup (&loop, &expr->where);
    6244                 :             : 
    6245                 :        2125 :   if (nonempty == NULL && maskss == NULL
    6246                 :         511 :       && loop.dimen == 1 && loop.from[0] && loop.to[0])
    6247                 :         475 :     nonempty = fold_build2_loc (input_location, LE_EXPR, logical_type_node,
    6248                 :             :                                 loop.from[0], loop.to[0]);
    6249                 :        2125 :   nonempty_var = NULL;
    6250                 :        2125 :   if (nonempty == NULL
    6251                 :        2125 :       && (HONOR_INFINITIES (DECL_MODE (limit))
    6252                 :         468 :           || HONOR_NANS (DECL_MODE (limit))))
    6253                 :             :     {
    6254                 :         558 :       nonempty_var = gfc_create_var (logical_type_node, "nonempty");
    6255                 :         558 :       gfc_add_modify (&se->pre, nonempty_var, logical_false_node);
    6256                 :         558 :       nonempty = nonempty_var;
    6257                 :             :     }
    6258                 :        2125 :   lab = NULL;
    6259                 :        2125 :   fast = NULL;
    6260                 :        2125 :   if (HONOR_NANS (DECL_MODE (limit)))
    6261                 :             :     {
    6262                 :        1192 :       if (loop.dimen == 1)
    6263                 :             :         {
    6264                 :         796 :           lab = gfc_build_label_decl (NULL_TREE);
    6265                 :         796 :           TREE_USED (lab) = 1;
    6266                 :             :         }
    6267                 :             :       else
    6268                 :             :         {
    6269                 :         396 :           fast = gfc_create_var (logical_type_node, "fast");
    6270                 :         396 :           gfc_add_modify (&se->pre, fast, logical_false_node);
    6271                 :             :         }
    6272                 :             :     }
    6273                 :             : 
    6274                 :        2125 :   gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
    6275                 :        2125 :   if (maskss)
    6276                 :        1644 :     gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
    6277                 :             :   /* Generate the loop body.  */
    6278                 :        2125 :   gfc_start_scalarized_body (&loop, &body);
    6279                 :             : 
    6280                 :             :   /* If we have a mask, only add this element if the mask is set.  */
    6281                 :        2125 :   if (maskss)
    6282                 :             :     {
    6283                 :         990 :       gfc_init_se (&maskse, NULL);
    6284                 :         990 :       gfc_copy_loopinfo_to_se (&maskse, &loop);
    6285                 :         990 :       maskse.ss = maskss;
    6286                 :         990 :       gfc_conv_expr_val (&maskse, maskexpr);
    6287                 :         990 :       gfc_add_block_to_block (&body, &maskse.pre);
    6288                 :             : 
    6289                 :         990 :       gfc_start_block (&block);
    6290                 :             :     }
    6291                 :             :   else
    6292                 :        1135 :     gfc_init_block (&block);
    6293                 :             : 
    6294                 :             :   /* Compare with the current limit.  */
    6295                 :        2125 :   gfc_init_se (&arrayse, NULL);
    6296                 :        2125 :   gfc_copy_loopinfo_to_se (&arrayse, &loop);
    6297                 :        2125 :   arrayse.ss = arrayss;
    6298                 :        2125 :   gfc_conv_expr_val (&arrayse, arrayexpr);
    6299                 :        2125 :   gfc_add_block_to_block (&block, &arrayse.pre);
    6300                 :             : 
    6301                 :        2125 :   gfc_init_block (&block2);
    6302                 :             : 
    6303                 :        2125 :   if (nonempty_var)
    6304                 :         558 :     gfc_add_modify (&block2, nonempty_var, logical_true_node);
    6305                 :             : 
    6306                 :        2125 :   if (HONOR_NANS (DECL_MODE (limit)))
    6307                 :             :     {
    6308                 :        1873 :       tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
    6309                 :             :                              logical_type_node, arrayse.expr, limit);
    6310                 :        1192 :       if (lab)
    6311                 :         796 :         ifbody = build1_v (GOTO_EXPR, lab);
    6312                 :             :       else
    6313                 :             :         {
    6314                 :         396 :           stmtblock_t ifblock;
    6315                 :             : 
    6316                 :         396 :           gfc_init_block (&ifblock);
    6317                 :         396 :           gfc_add_modify (&ifblock, limit, arrayse.expr);
    6318                 :         396 :           gfc_add_modify (&ifblock, fast, logical_true_node);
    6319                 :         396 :           ifbody = gfc_finish_block (&ifblock);
    6320                 :             :         }
    6321                 :        1192 :       tmp = build3_v (COND_EXPR, tmp, ifbody,
    6322                 :             :                       build_empty_stmt (input_location));
    6323                 :        1192 :       gfc_add_expr_to_block (&block2, tmp);
    6324                 :             :     }
    6325                 :             :   else
    6326                 :             :     {
    6327                 :             :       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
    6328                 :             :          signed zeros.  */
    6329                 :        1464 :       tmp = fold_build2_loc (input_location,
    6330                 :             :                              op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
    6331                 :             :                              type, arrayse.expr, limit);
    6332                 :         933 :       gfc_add_modify (&block2, limit, tmp);
    6333                 :             :     }
    6334                 :             : 
    6335                 :        2125 :   if (fast)
    6336                 :             :     {
    6337                 :         396 :       tree elsebody = gfc_finish_block (&block2);
    6338                 :             : 
    6339                 :             :       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
    6340                 :             :          signed zeros.  */
    6341                 :         396 :       if (HONOR_NANS (DECL_MODE (limit)))
    6342                 :             :         {
    6343                 :         396 :           tmp = fold_build2_loc (input_location, op, logical_type_node,
    6344                 :             :                                  arrayse.expr, limit);
    6345                 :         396 :           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
    6346                 :         396 :           ifbody = build3_v (COND_EXPR, tmp, ifbody,
    6347                 :             :                              build_empty_stmt (input_location));
    6348                 :             :         }
    6349                 :             :       else
    6350                 :             :         {
    6351                 :           0 :           tmp = fold_build2_loc (input_location,
    6352                 :             :                                  op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
    6353                 :             :                                  type, arrayse.expr, limit);
    6354                 :           0 :           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
    6355                 :             :         }
    6356                 :         396 :       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
    6357                 :         396 :       gfc_add_expr_to_block (&block, tmp);
    6358                 :             :     }
    6359                 :             :   else
    6360                 :        1729 :     gfc_add_block_to_block (&block, &block2);
    6361                 :             : 
    6362                 :        2125 :   gfc_add_block_to_block (&block, &arrayse.post);
    6363                 :             : 
    6364                 :        2125 :   tmp = gfc_finish_block (&block);
    6365                 :        2125 :   if (maskss)
    6366                 :             :     {
    6367                 :             :       /* We enclose the above in if (mask) {...}.  If the mask is an
    6368                 :             :          optional argument, generate IF (.NOT. PRESENT(MASK)
    6369                 :             :          .OR. MASK(I)).  */
    6370                 :         990 :       tree ifmask;
    6371                 :         990 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    6372                 :         990 :       tmp = build3_v (COND_EXPR, ifmask, tmp,
    6373                 :             :                       build_empty_stmt (input_location));
    6374                 :             :     }
    6375                 :        2125 :   gfc_add_expr_to_block (&body, tmp);
    6376                 :             : 
    6377                 :        2125 :   if (lab)
    6378                 :             :     {
    6379                 :         796 :       gfc_trans_scalarized_loop_boundary (&loop, &body);
    6380                 :             : 
    6381                 :         796 :       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
    6382                 :             :                              nan_cst, huge_cst);
    6383                 :         796 :       gfc_add_modify (&loop.code[0], limit, tmp);
    6384                 :         796 :       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
    6385                 :             : 
    6386                 :             :       /* If we have a mask, only add this element if the mask is set.  */
    6387                 :         796 :       if (maskss)
    6388                 :             :         {
    6389                 :         336 :           gfc_init_se (&maskse, NULL);
    6390                 :         336 :           gfc_copy_loopinfo_to_se (&maskse, &loop);
    6391                 :         336 :           maskse.ss = maskss;
    6392                 :         336 :           gfc_conv_expr_val (&maskse, maskexpr);
    6393                 :         336 :           gfc_add_block_to_block (&body, &maskse.pre);
    6394                 :             : 
    6395                 :         336 :           gfc_start_block (&block);
    6396                 :             :         }
    6397                 :             :       else
    6398                 :         460 :         gfc_init_block (&block);
    6399                 :             : 
    6400                 :             :       /* Compare with the current limit.  */
    6401                 :         796 :       gfc_init_se (&arrayse, NULL);
    6402                 :         796 :       gfc_copy_loopinfo_to_se (&arrayse, &loop);
    6403                 :         796 :       arrayse.ss = arrayss;
    6404                 :         796 :       gfc_conv_expr_val (&arrayse, arrayexpr);
    6405                 :         796 :       gfc_add_block_to_block (&block, &arrayse.pre);
    6406                 :             : 
    6407                 :             :       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
    6408                 :             :          signed zeros.  */
    6409                 :         796 :       if (HONOR_NANS (DECL_MODE (limit)))
    6410                 :             :         {
    6411                 :         796 :           tmp = fold_build2_loc (input_location, op, logical_type_node,
    6412                 :             :                                  arrayse.expr, limit);
    6413                 :         796 :           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
    6414                 :         796 :           tmp = build3_v (COND_EXPR, tmp, ifbody,
    6415                 :             :                           build_empty_stmt (input_location));
    6416                 :         796 :           gfc_add_expr_to_block (&block, tmp);
    6417                 :             :         }
    6418                 :             :       else
    6419                 :             :         {
    6420                 :           0 :           tmp = fold_build2_loc (input_location,
    6421                 :             :                                  op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
    6422                 :             :                                  type, arrayse.expr, limit);
    6423                 :           0 :           gfc_add_modify (&block, limit, tmp);
    6424                 :             :         }
    6425                 :             : 
    6426                 :         796 :       gfc_add_block_to_block (&block, &arrayse.post);
    6427                 :             : 
    6428                 :         796 :       tmp = gfc_finish_block (&block);
    6429                 :         796 :       if (maskss)
    6430                 :             :         /* We enclose the above in if (mask) {...}.  */
    6431                 :             :         {
    6432                 :         336 :           tree ifmask;
    6433                 :         336 :           ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    6434                 :         336 :           tmp = build3_v (COND_EXPR, ifmask, tmp,
    6435                 :             :                           build_empty_stmt (input_location));
    6436                 :             :         }
    6437                 :             : 
    6438                 :         796 :       gfc_add_expr_to_block (&body, tmp);
    6439                 :             :       /* Avoid initializing loopvar[0] again, it should be left where
    6440                 :             :          it finished by the first loop.  */
    6441                 :         796 :       loop.from[0] = loop.loopvar[0];
    6442                 :             :     }
    6443                 :        2125 :   gfc_trans_scalarizing_loops (&loop, &body);
    6444                 :             : 
    6445                 :        2125 :   if (fast)
    6446                 :             :     {
    6447                 :         396 :       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
    6448                 :             :                              nan_cst, huge_cst);
    6449                 :         396 :       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
    6450                 :         396 :       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
    6451                 :             :                       ifbody);
    6452                 :         396 :       gfc_add_expr_to_block (&loop.pre, tmp);
    6453                 :             :     }
    6454                 :        1729 :   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
    6455                 :             :     {
    6456                 :           0 :       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
    6457                 :             :                              huge_cst);
    6458                 :           0 :       gfc_add_modify (&loop.pre, limit, tmp);
    6459                 :             :     }
    6460                 :             : 
    6461                 :             :   /* For a scalar mask, enclose the loop in an if statement.  */
    6462                 :        2125 :   if (maskexpr && maskss == NULL)
    6463                 :             :     {
    6464                 :         546 :       tree else_stmt;
    6465                 :         546 :       tree ifmask;
    6466                 :             : 
    6467                 :         546 :       gfc_init_se (&maskse, NULL);
    6468                 :         546 :       gfc_conv_expr_val (&maskse, maskexpr);
    6469                 :         546 :       gfc_init_block (&block);
    6470                 :         546 :       gfc_add_block_to_block (&block, &loop.pre);
    6471                 :         546 :       gfc_add_block_to_block (&block, &loop.post);
    6472                 :         546 :       tmp = gfc_finish_block (&block);
    6473                 :             : 
    6474                 :         546 :       if (HONOR_INFINITIES (DECL_MODE (limit)))
    6475                 :         354 :         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
    6476                 :             :       else
    6477                 :         192 :         else_stmt = build_empty_stmt (input_location);
    6478                 :             : 
    6479                 :         546 :       ifmask = conv_mask_condition (&maskse, maskexpr, optional_mask);
    6480                 :         546 :       tmp = build3_v (COND_EXPR, ifmask, tmp, else_stmt);
    6481                 :         546 :       gfc_add_expr_to_block (&block, tmp);
    6482                 :         546 :       gfc_add_block_to_block (&se->pre, &block);
    6483                 :             :     }
    6484                 :             :   else
    6485                 :             :     {
    6486                 :        1579 :       gfc_add_block_to_block (&se->pre, &loop.pre);
    6487                 :        1579 :       gfc_add_block_to_block (&se->pre, &loop.post);
    6488                 :             :     }
    6489                 :             : 
    6490                 :        2125 :   gfc_cleanup_loop (&loop);
    6491                 :             : 
    6492                 :        2125 :   se->expr = limit;
    6493                 :             : }
    6494                 :             : 
    6495                 :             : /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
    6496                 :             : static void
    6497                 :         138 : gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
    6498                 :             : {
    6499                 :         138 :   tree args[2];
    6500                 :         138 :   tree type;
    6501                 :         138 :   tree tmp;
    6502                 :             : 
    6503                 :         138 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6504                 :         138 :   type = TREE_TYPE (args[0]);
    6505                 :             : 
    6506                 :             :   /* Optionally generate code for runtime argument check.  */
    6507                 :         138 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6508                 :             :     {
    6509                 :           6 :       tree below = fold_build2_loc (input_location, LT_EXPR,
    6510                 :             :                                     logical_type_node, args[1],
    6511                 :           6 :                                     build_int_cst (TREE_TYPE (args[1]), 0));
    6512                 :           6 :       tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
    6513                 :           6 :       tree above = fold_build2_loc (input_location, GE_EXPR,
    6514                 :             :                                     logical_type_node, args[1], nbits);
    6515                 :           6 :       tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6516                 :             :                                     logical_type_node, below, above);
    6517                 :           6 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6518                 :             :                                "POS argument (%ld) out of range 0:%ld "
    6519                 :             :                                "in intrinsic BTEST",
    6520                 :             :                                fold_convert (long_integer_type_node, args[1]),
    6521                 :             :                                fold_convert (long_integer_type_node, nbits));
    6522                 :             :     }
    6523                 :             : 
    6524                 :         138 :   tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    6525                 :         138 :                          build_int_cst (type, 1), args[1]);
    6526                 :         138 :   tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
    6527                 :         138 :   tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp,
    6528                 :         138 :                          build_int_cst (type, 0));
    6529                 :         138 :   type = gfc_typenode_for_spec (&expr->ts);
    6530                 :         138 :   se->expr = convert (type, tmp);
    6531                 :         138 : }
    6532                 :             : 
    6533                 :             : 
    6534                 :             : /* Generate code for BGE, BGT, BLE and BLT intrinsics.  */
    6535                 :             : static void
    6536                 :         168 : gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
    6537                 :             : {
    6538                 :         168 :   tree args[2];
    6539                 :             : 
    6540                 :         168 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6541                 :             : 
    6542                 :             :   /* Convert both arguments to the unsigned type of the same size.  */
    6543                 :         168 :   args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
    6544                 :         168 :   args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
    6545                 :             : 
    6546                 :             :   /* If they have unequal type size, convert to the larger one.  */
    6547                 :         168 :   if (TYPE_PRECISION (TREE_TYPE (args[0]))
    6548                 :         168 :       > TYPE_PRECISION (TREE_TYPE (args[1])))
    6549                 :           0 :     args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
    6550                 :         168 :   else if (TYPE_PRECISION (TREE_TYPE (args[1]))
    6551                 :         168 :            > TYPE_PRECISION (TREE_TYPE (args[0])))
    6552                 :           0 :     args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
    6553                 :             : 
    6554                 :             :   /* Now, we compare them.  */
    6555                 :         168 :   se->expr = fold_build2_loc (input_location, op, logical_type_node,
    6556                 :             :                               args[0], args[1]);
    6557                 :         168 : }
    6558                 :             : 
    6559                 :             : 
    6560                 :             : /* Generate code to perform the specified operation.  */
    6561                 :             : static void
    6562                 :        1849 : gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
    6563                 :             : {
    6564                 :        1849 :   tree args[2];
    6565                 :             : 
    6566                 :        1849 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6567                 :        1849 :   se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
    6568                 :             :                               args[0], args[1]);
    6569                 :        1849 : }
    6570                 :             : 
    6571                 :             : /* Bitwise not.  */
    6572                 :             : static void
    6573                 :         222 : gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
    6574                 :             : {
    6575                 :         222 :   tree arg;
    6576                 :             : 
    6577                 :         222 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    6578                 :         222 :   se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
    6579                 :         222 :                               TREE_TYPE (arg), arg);
    6580                 :         222 : }
    6581                 :             : 
    6582                 :             : /* Set or clear a single bit.  */
    6583                 :             : static void
    6584                 :         282 : gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
    6585                 :             : {
    6586                 :         282 :   tree args[2];
    6587                 :         282 :   tree type;
    6588                 :         282 :   tree tmp;
    6589                 :         282 :   enum tree_code op;
    6590                 :             : 
    6591                 :         282 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6592                 :         282 :   type = TREE_TYPE (args[0]);
    6593                 :             : 
    6594                 :             :   /* Optionally generate code for runtime argument check.  */
    6595                 :         282 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6596                 :             :     {
    6597                 :          12 :       tree below = fold_build2_loc (input_location, LT_EXPR,
    6598                 :             :                                     logical_type_node, args[1],
    6599                 :          12 :                                     build_int_cst (TREE_TYPE (args[1]), 0));
    6600                 :          12 :       tree nbits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
    6601                 :          12 :       tree above = fold_build2_loc (input_location, GE_EXPR,
    6602                 :             :                                     logical_type_node, args[1], nbits);
    6603                 :          12 :       tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6604                 :             :                                     logical_type_node, below, above);
    6605                 :          12 :       size_t len_name = strlen (expr->value.function.isym->name);
    6606                 :          12 :       char *name = XALLOCAVEC (char, len_name + 1);
    6607                 :          72 :       for (size_t i = 0; i < len_name; i++)
    6608                 :          60 :         name[i] = TOUPPER (expr->value.function.isym->name[i]);
    6609                 :          12 :       name[len_name] = '\0';
    6610                 :          12 :       tree iname = gfc_build_addr_expr (pchar_type_node,
    6611                 :             :                                         gfc_build_cstring_const (name));
    6612                 :          12 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6613                 :             :                                "POS argument (%ld) out of range 0:%ld "
    6614                 :             :                                "in intrinsic %s",
    6615                 :             :                                fold_convert (long_integer_type_node, args[1]),
    6616                 :             :                                fold_convert (long_integer_type_node, nbits),
    6617                 :             :                                iname);
    6618                 :             :     }
    6619                 :             : 
    6620                 :         282 :   tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
    6621                 :         282 :                          build_int_cst (type, 1), args[1]);
    6622                 :         282 :   if (set)
    6623                 :             :     op = BIT_IOR_EXPR;
    6624                 :             :   else
    6625                 :             :     {
    6626                 :         156 :       op = BIT_AND_EXPR;
    6627                 :         156 :       tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
    6628                 :             :     }
    6629                 :         282 :   se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
    6630                 :         282 : }
    6631                 :             : 
    6632                 :             : /* Extract a sequence of bits.
    6633                 :             :     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
    6634                 :             : static void
    6635                 :          27 : gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
    6636                 :             : {
    6637                 :          27 :   tree args[3];
    6638                 :          27 :   tree type;
    6639                 :          27 :   tree tmp;
    6640                 :          27 :   tree mask;
    6641                 :          27 :   tree num_bits, cond;
    6642                 :             : 
    6643                 :          27 :   gfc_conv_intrinsic_function_args (se, expr, args, 3);
    6644                 :          27 :   type = TREE_TYPE (args[0]);
    6645                 :             : 
    6646                 :             :   /* Optionally generate code for runtime argument check.  */
    6647                 :          27 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6648                 :             :     {
    6649                 :          12 :       tree tmp1 = fold_convert (long_integer_type_node, args[1]);
    6650                 :          12 :       tree tmp2 = fold_convert (long_integer_type_node, args[2]);
    6651                 :          36 :       tree nbits = build_int_cst (long_integer_type_node,
    6652                 :          12 :                                   TYPE_PRECISION (type));
    6653                 :          12 :       tree below = fold_build2_loc (input_location, LT_EXPR,
    6654                 :             :                                     logical_type_node, args[1],
    6655                 :          12 :                                     build_int_cst (TREE_TYPE (args[1]), 0));
    6656                 :          12 :       tree above = fold_build2_loc (input_location, GT_EXPR,
    6657                 :             :                                     logical_type_node, tmp1, nbits);
    6658                 :          12 :       tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6659                 :             :                                     logical_type_node, below, above);
    6660                 :          12 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6661                 :             :                                "POS argument (%ld) out of range 0:%ld "
    6662                 :             :                                "in intrinsic IBITS", tmp1, nbits);
    6663                 :          12 :       below = fold_build2_loc (input_location, LT_EXPR,
    6664                 :             :                                logical_type_node, args[2],
    6665                 :          12 :                                build_int_cst (TREE_TYPE (args[2]), 0));
    6666                 :          12 :       above = fold_build2_loc (input_location, GT_EXPR,
    6667                 :             :                                logical_type_node, tmp2, nbits);
    6668                 :          12 :       scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6669                 :             :                                logical_type_node, below, above);
    6670                 :          12 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6671                 :             :                                "LEN argument (%ld) out of range 0:%ld "
    6672                 :             :                                "in intrinsic IBITS", tmp2, nbits);
    6673                 :          12 :       above = fold_build2_loc (input_location, PLUS_EXPR,
    6674                 :             :                                long_integer_type_node, tmp1, tmp2);
    6675                 :          12 :       scond = fold_build2_loc (input_location, GT_EXPR,
    6676                 :             :                                logical_type_node, above, nbits);
    6677                 :          12 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6678                 :             :                                "POS(%ld)+LEN(%ld)>BIT_SIZE(%ld) "
    6679                 :             :                                "in intrinsic IBITS", tmp1, tmp2, nbits);
    6680                 :             :     }
    6681                 :             : 
    6682                 :             :   /* The Fortran standard allows (shift width) LEN <= BIT_SIZE(I), whereas
    6683                 :             :      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
    6684                 :             :      special case.  See also gfc_conv_intrinsic_ishft ().  */
    6685                 :          27 :   num_bits = build_int_cst (TREE_TYPE (args[2]), TYPE_PRECISION (type));
    6686                 :             : 
    6687                 :          27 :   mask = build_int_cst (type, -1);
    6688                 :          27 :   mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
    6689                 :          27 :   cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[2],
    6690                 :             :                           num_bits);
    6691                 :          27 :   mask = fold_build3_loc (input_location, COND_EXPR, type, cond,
    6692                 :          27 :                           build_int_cst (type, 0), mask);
    6693                 :          27 :   mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
    6694                 :             : 
    6695                 :          27 :   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
    6696                 :             : 
    6697                 :          27 :   se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
    6698                 :          27 : }
    6699                 :             : 
    6700                 :             : static void
    6701                 :         351 : gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
    6702                 :             :                           bool arithmetic)
    6703                 :             : {
    6704                 :         351 :   tree args[2], type, num_bits, cond;
    6705                 :         351 :   tree bigshift;
    6706                 :             : 
    6707                 :         351 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6708                 :             : 
    6709                 :         351 :   args[0] = gfc_evaluate_now (args[0], &se->pre);
    6710                 :         351 :   args[1] = gfc_evaluate_now (args[1], &se->pre);
    6711                 :         351 :   type = TREE_TYPE (args[0]);
    6712                 :             : 
    6713                 :         351 :   if (!arithmetic)
    6714                 :         279 :     args[0] = fold_convert (unsigned_type_for (type), args[0]);
    6715                 :             :   else
    6716                 :          72 :     gcc_assert (right_shift);
    6717                 :             : 
    6718                 :         588 :   se->expr = fold_build2_loc (input_location,
    6719                 :             :                               right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
    6720                 :         351 :                               TREE_TYPE (args[0]), args[0], args[1]);
    6721                 :             : 
    6722                 :         351 :   if (!arithmetic)
    6723                 :         279 :     se->expr = fold_convert (type, se->expr);
    6724                 :             : 
    6725                 :         351 :   if (!arithmetic)
    6726                 :         279 :     bigshift = build_int_cst (type, 0);
    6727                 :             :   else
    6728                 :             :     {
    6729                 :          72 :       tree nonneg = fold_build2_loc (input_location, GE_EXPR,
    6730                 :             :                                      logical_type_node, args[0],
    6731                 :          72 :                                      build_int_cst (TREE_TYPE (args[0]), 0));
    6732                 :          72 :       bigshift = fold_build3_loc (input_location, COND_EXPR, type, nonneg,
    6733                 :          72 :                                   build_int_cst (type, 0),
    6734                 :          72 :                                   build_int_cst (type, -1));
    6735                 :             :     }
    6736                 :             : 
    6737                 :             :   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
    6738                 :             :      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
    6739                 :             :      special case.  */
    6740                 :         351 :   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
    6741                 :             : 
    6742                 :             :   /* Optionally generate code for runtime argument check.  */
    6743                 :         351 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6744                 :             :     {
    6745                 :          30 :       tree below = fold_build2_loc (input_location, LT_EXPR,
    6746                 :             :                                     logical_type_node, args[1],
    6747                 :          30 :                                     build_int_cst (TREE_TYPE (args[1]), 0));
    6748                 :          30 :       tree above = fold_build2_loc (input_location, GT_EXPR,
    6749                 :             :                                     logical_type_node, args[1], num_bits);
    6750                 :          30 :       tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6751                 :             :                                     logical_type_node, below, above);
    6752                 :          30 :       size_t len_name = strlen (expr->value.function.isym->name);
    6753                 :          30 :       char *name = XALLOCAVEC (char, len_name + 1);
    6754                 :         210 :       for (size_t i = 0; i < len_name; i++)
    6755                 :         180 :         name[i] = TOUPPER (expr->value.function.isym->name[i]);
    6756                 :          30 :       name[len_name] = '\0';
    6757                 :          30 :       tree iname = gfc_build_addr_expr (pchar_type_node,
    6758                 :             :                                         gfc_build_cstring_const (name));
    6759                 :          30 :       gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6760                 :             :                                "SHIFT argument (%ld) out of range 0:%ld "
    6761                 :             :                                "in intrinsic %s",
    6762                 :             :                                fold_convert (long_integer_type_node, args[1]),
    6763                 :             :                                fold_convert (long_integer_type_node, num_bits),
    6764                 :             :                                iname);
    6765                 :             :     }
    6766                 :             : 
    6767                 :         351 :   cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node,
    6768                 :             :                           args[1], num_bits);
    6769                 :             : 
    6770                 :         351 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
    6771                 :             :                               bigshift, se->expr);
    6772                 :         351 : }
    6773                 :             : 
    6774                 :             : /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
    6775                 :             :                         ? 0
    6776                 :             :                         : ((shift >= 0) ? i << shift : i >> -shift)
    6777                 :             :    where all shifts are logical shifts.  */
    6778                 :             : static void
    6779                 :         252 : gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
    6780                 :             : {
    6781                 :         252 :   tree args[2];
    6782                 :         252 :   tree type;
    6783                 :         252 :   tree utype;
    6784                 :         252 :   tree tmp;
    6785                 :         252 :   tree width;
    6786                 :         252 :   tree num_bits;
    6787                 :         252 :   tree cond;
    6788                 :         252 :   tree lshift;
    6789                 :         252 :   tree rshift;
    6790                 :             : 
    6791                 :         252 :   gfc_conv_intrinsic_function_args (se, expr, args, 2);
    6792                 :             : 
    6793                 :         252 :   args[0] = gfc_evaluate_now (args[0], &se->pre);
    6794                 :         252 :   args[1] = gfc_evaluate_now (args[1], &se->pre);
    6795                 :             : 
    6796                 :         252 :   type = TREE_TYPE (args[0]);
    6797                 :         252 :   utype = unsigned_type_for (type);
    6798                 :             : 
    6799                 :         252 :   width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
    6800                 :             :                            args[1]);
    6801                 :             : 
    6802                 :             :   /* Left shift if positive.  */
    6803                 :         252 :   lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
    6804                 :             : 
    6805                 :             :   /* Right shift if negative.
    6806                 :             :      We convert to an unsigned type because we want a logical shift.
    6807                 :             :      The standard doesn't define the case of shifting negative
    6808                 :             :      numbers, and we try to be compatible with other compilers, most
    6809                 :             :      notably g77, here.  */
    6810                 :         252 :   rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
    6811                 :             :                                     utype, convert (utype, args[0]), width));
    6812                 :             : 
    6813                 :         252 :   tmp = fold_build2_loc (input_location, GE_EXPR, logical_type_node, args[1],
    6814                 :         252 :                          build_int_cst (TREE_TYPE (args[1]), 0));
    6815                 :         252 :   tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
    6816                 :             : 
    6817                 :             :   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
    6818                 :             :      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
    6819                 :             :      special case.  */
    6820                 :         252 :   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
    6821                 :             : 
    6822                 :             :   /* Optionally generate code for runtime argument check.  */
    6823                 :         252 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6824                 :             :     {
    6825                 :          24 :       tree outside = fold_build2_loc (input_location, GT_EXPR,
    6826                 :             :                                     logical_type_node, width, num_bits);
    6827                 :          24 :       gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
    6828                 :             :                                "SHIFT argument (%ld) out of range -%ld:%ld "
    6829                 :             :                                "in intrinsic ISHFT",
    6830                 :             :                                fold_convert (long_integer_type_node, args[1]),
    6831                 :             :                                fold_convert (long_integer_type_node, num_bits),
    6832                 :             :                                fold_convert (long_integer_type_node, num_bits));
    6833                 :             :     }
    6834                 :             : 
    6835                 :         252 :   cond = fold_build2_loc (input_location, GE_EXPR, logical_type_node, width,
    6836                 :             :                           num_bits);
    6837                 :         252 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
    6838                 :         252 :                               build_int_cst (type, 0), tmp);
    6839                 :         252 : }
    6840                 :             : 
    6841                 :             : 
    6842                 :             : /* Circular shift.  AKA rotate or barrel shift.  */
    6843                 :             : 
    6844                 :             : static void
    6845                 :         568 : gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
    6846                 :             : {
    6847                 :         568 :   tree *args;
    6848                 :         568 :   tree type;
    6849                 :         568 :   tree tmp;
    6850                 :         568 :   tree lrot;
    6851                 :         568 :   tree rrot;
    6852                 :         568 :   tree zero;
    6853                 :         568 :   tree nbits;
    6854                 :         568 :   unsigned int num_args;
    6855                 :             : 
    6856                 :         568 :   num_args = gfc_intrinsic_argument_list_length (expr);
    6857                 :         568 :   args = XALLOCAVEC (tree, num_args);
    6858                 :             : 
    6859                 :         568 :   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
    6860                 :             : 
    6861                 :         568 :   type = TREE_TYPE (args[0]);
    6862                 :         568 :   nbits = build_int_cst (long_integer_type_node, TYPE_PRECISION (type));
    6863                 :             : 
    6864                 :         568 :   if (num_args == 3)
    6865                 :             :     {
    6866                 :             :       /* Use a library function for the 3 parameter version.  */
    6867                 :         514 :       tree int4type = gfc_get_int_type (4);
    6868                 :             : 
    6869                 :             :       /* We convert the first argument to at least 4 bytes, and
    6870                 :             :          convert back afterwards.  This removes the need for library
    6871                 :             :          functions for all argument sizes, and function will be
    6872                 :             :          aligned to at least 32 bits, so there's no loss.  */
    6873                 :         514 :       if (expr->ts.kind < 4)
    6874                 :         230 :         args[0] = convert (int4type, args[0]);
    6875                 :             : 
    6876                 :             :       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
    6877                 :             :          need loads of library  functions.  They cannot have values >
    6878                 :             :          BIT_SIZE (I) so the conversion is safe.  */
    6879                 :         514 :       args[1] = convert (int4type, args[1]);
    6880                 :         514 :       args[2] = convert (int4type, args[2]);
    6881                 :             : 
    6882                 :             :       /* Optionally generate code for runtime argument check.  */
    6883                 :         514 :       if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6884                 :             :         {
    6885                 :          18 :           tree size = fold_convert (long_integer_type_node, args[2]);
    6886                 :          18 :           tree below = fold_build2_loc (input_location, LE_EXPR,
    6887                 :             :                                         logical_type_node, size,
    6888                 :          18 :                                         build_int_cst (TREE_TYPE (args[1]), 0));
    6889                 :          18 :           tree above = fold_build2_loc (input_location, GT_EXPR,
    6890                 :             :                                         logical_type_node, size, nbits);
    6891                 :          18 :           tree scond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
    6892                 :             :                                         logical_type_node, below, above);
    6893                 :          18 :           gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6894                 :             :                                    "SIZE argument (%ld) out of range 1:%ld "
    6895                 :             :                                    "in intrinsic ISHFTC", size, nbits);
    6896                 :          18 :           tree width = fold_convert (long_integer_type_node, args[1]);
    6897                 :          18 :           width = fold_build1_loc (input_location, ABS_EXPR,
    6898                 :             :                                    long_integer_type_node, width);
    6899                 :          18 :           scond = fold_build2_loc (input_location, GT_EXPR,
    6900                 :             :                                    logical_type_node, width, size);
    6901                 :          18 :           gfc_trans_runtime_check (true, false, scond, &se->pre, &expr->where,
    6902                 :             :                                    "SHIFT argument (%ld) out of range -%ld:%ld "
    6903                 :             :                                    "in intrinsic ISHFTC",
    6904                 :             :                                    fold_convert (long_integer_type_node, args[1]),
    6905                 :             :                                    size, size);
    6906                 :             :         }
    6907                 :             : 
    6908                 :         514 :       switch (expr->ts.kind)
    6909                 :             :         {
    6910                 :         390 :         case 1:
    6911                 :         390 :         case 2:
    6912                 :         390 :         case 4:
    6913                 :         390 :           tmp = gfor_fndecl_math_ishftc4;
    6914                 :         390 :           break;
    6915                 :         124 :         case 8:
    6916                 :         124 :           tmp = gfor_fndecl_math_ishftc8;
    6917                 :         124 :           break;
    6918                 :           0 :         case 16:
    6919                 :           0 :           tmp = gfor_fndecl_math_ishftc16;
    6920                 :           0 :           break;
    6921                 :           0 :         default:
    6922                 :           0 :           gcc_unreachable ();
    6923                 :             :         }
    6924                 :         514 :       se->expr = build_call_expr_loc (input_location,
    6925                 :             :                                       tmp, 3, args[0], args[1], args[2]);
    6926                 :             :       /* Convert the result back to the original type, if we extended
    6927                 :             :          the first argument's width above.  */
    6928                 :         514 :       if (expr->ts.kind < 4)
    6929                 :         230 :         se->expr = convert (type, se->expr);
    6930                 :             : 
    6931                 :         514 :       return;
    6932                 :             :     }
    6933                 :             : 
    6934                 :             :   /* Evaluate arguments only once.  */
    6935                 :          54 :   args[0] = gfc_evaluate_now (args[0], &se->pre);
    6936                 :          54 :   args[1] = gfc_evaluate_now (args[1], &se->pre);
    6937                 :             : 
    6938                 :             :   /* Optionally generate code for runtime argument check.  */
    6939                 :          54 :   if (gfc_option.rtcheck & GFC_RTCHECK_BITS)
    6940                 :             :     {
    6941                 :          12 :       tree width = fold_convert (long_integer_type_node, args[1]);
    6942                 :          12 :       width = fold_build1_loc (input_location, ABS_EXPR,
    6943                 :             :                                long_integer_type_node, width);
    6944                 :          12 :       tree outside = fold_build2_loc (input_location, GT_EXPR,
    6945                 :             :                                       logical_type_node, width, nbits);
    6946                 :          12 :       gfc_trans_runtime_check (true, false, outside, &se->pre, &expr->where,
    6947                 :             :                                "SHIFT argument (%ld) out of range -%ld:%ld "
    6948                 :             :                                "in intrinsic ISHFTC",
    6949                 :             :                                fold_convert (long_integer_type_node, args[1]),
    6950                 :             :                                nbits, nbits);
    6951                 :             :     }
    6952                 :             : 
    6953                 :             :   /* Rotate left if positive.  */
    6954                 :          54 :   lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
    6955                 :             : 
    6956                 :             :   /* Rotate right if negative.  */
    6957                 :          54 :   tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
    6958                 :             :                          args[1]);
    6959                 :          54 :   rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
    6960                 :             : 
    6961                 :          54 :   zero = build_int_cst (TREE_TYPE (args[1]), 0);
    6962                 :          54 :   tmp = fold_build2_loc (input_location, GT_EXPR, logical_type_node, args[1],
    6963                 :             :                          zero);
    6964                 :          54 :   rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
    6965                 :             : 
    6966                 :             :   /* Do nothing if shift == 0.  */
    6967                 :          54 :   tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, args[1],
    6968                 :             :                          zero);
    6969                 :          54 :   se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
    6970                 :             :                               rrot);
    6971                 :             : }
    6972                 :             : 
    6973                 :             : 
    6974                 :             : /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
    6975                 :             :                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
    6976                 :             : 
    6977                 :             :    The conditional expression is necessary because the result of LEADZ(0)
    6978                 :             :    is defined, but the result of __builtin_clz(0) is undefined for most
    6979                 :             :    targets.
    6980                 :             : 
    6981                 :             :    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
    6982                 :             :    difference in bit size between the argument of LEADZ and the C int.  */
    6983                 :             : 
    6984                 :             : static void
    6985                 :         270 : gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
    6986                 :             : {
    6987                 :         270 :   tree arg;
    6988                 :         270 :   tree arg_type;
    6989                 :         270 :   tree cond;
    6990                 :         270 :   tree result_type;
    6991                 :         270 :   tree leadz;
    6992                 :         270 :   tree bit_size;
    6993                 :         270 :   tree tmp;
    6994                 :         270 :   tree func;
    6995                 :         270 :   int s, argsize;
    6996                 :             : 
    6997                 :         270 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    6998                 :         270 :   argsize = TYPE_PRECISION (TREE_TYPE (arg));
    6999                 :             : 
    7000                 :             :   /* Which variant of __builtin_clz* should we call?  */
    7001                 :         270 :   if (argsize <= INT_TYPE_SIZE)
    7002                 :             :     {
    7003                 :         183 :       arg_type = unsigned_type_node;
    7004                 :         183 :       func = builtin_decl_explicit (BUILT_IN_CLZ);
    7005                 :             :     }
    7006                 :          87 :   else if (argsize <= LONG_TYPE_SIZE)
    7007                 :             :     {
    7008                 :          57 :       arg_type = long_unsigned_type_node;
    7009                 :          57 :       func = builtin_decl_explicit (BUILT_IN_CLZL);
    7010                 :             :     }
    7011                 :          30 :   else if (argsize <= LONG_LONG_TYPE_SIZE)
    7012                 :             :     {
    7013                 :           0 :       arg_type = long_long_unsigned_type_node;
    7014                 :           0 :       func = builtin_decl_explicit (BUILT_IN_CLZLL);
    7015                 :             :     }
    7016                 :             :   else
    7017                 :             :     {
    7018                 :          30 :       gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
    7019                 :          30 :       arg_type = gfc_build_uint_type (argsize);
    7020                 :          30 :       func = NULL_TREE;
    7021                 :             :     }
    7022                 :             : 
    7023                 :             :   /* Convert the actual argument twice: first, to the unsigned type of the
    7024                 :             :      same size; then, to the proper argument type for the built-in
    7025                 :             :      function.  But the return type is of the default INTEGER kind.  */
    7026                 :         270 :   arg = fold_convert (gfc_build_uint_type (argsize), arg);
    7027                 :         270 :   arg = fold_convert (arg_type, arg);
    7028                 :         270 :   arg = gfc_evaluate_now (arg, &se->pre);
    7029                 :         270 :   result_type = gfc_get_int_type (gfc_default_integer_kind);
    7030                 :             : 
    7031                 :             :   /* Compute LEADZ for the case i .ne. 0.  */
    7032                 :         270 :   if (func)
    7033                 :             :     {
    7034                 :         240 :       s = TYPE_PRECISION (arg_type) - argsize;
    7035                 :         240 :       tmp = fold_convert (result_type,
    7036                 :             :                           build_call_expr_loc (input_location, func,
    7037                 :             :                                                1, arg));
    7038                 :         240 :       leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
    7039                 :             :                                tmp, build_int_cst (result_type, s));
    7040                 :             :     }
    7041                 :             :   else
    7042                 :             :     {
    7043                 :             :       /* We end up here if the argument type is larger than 'long long'.
    7044                 :             :          We generate this code:
    7045                 :             : 
    7046                 :             :             if (x & (ULL_MAX << ULL_SIZE) != 0)
    7047                 :             :               return clzll ((unsigned long long) (x >> ULLSIZE));
    7048                 :             :             else
    7049                 :             :               return ULL_SIZE + clzll ((unsigned long long) x);
    7050                 :             :          where ULL_MAX is the largest value that a ULL_MAX can hold
    7051                 :             :          (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
    7052                 :             :          is the bit-size of the long long type (64 in this example).  */
    7053                 :          30 :       tree ullsize, ullmax, tmp1, tmp2, btmp;
    7054                 :             : 
    7055                 :          30 :       ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
    7056                 :          30 :       ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
    7057                 :             :                                 long_long_unsigned_type_node,
    7058                 :             :                                 build_int_cst (long_long_unsigned_type_node,
    7059                 :          30 :                                                0));
    7060                 :             : 
    7061                 :          30 :       cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
    7062                 :             :                               fold_convert (arg_type, ullmax), ullsize);
    7063                 :          30 :       cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
    7064                 :             :                               arg, cond);
    7065                 :          30 :       cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
    7066                 :          30 :                               cond, build_int_cst (arg_type, 0));
    7067                 :             : 
    7068                 :          30 :       tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
    7069                 :             :                               arg, ullsize);
    7070                 :          30 :       tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
    7071                 :          30 :       btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
    7072                 :          30 :       tmp1 = fold_convert (result_type,
    7073                 :             :                            build_call_expr_loc (input_location, btmp, 1, tmp1));
    7074                 :             : 
    7075                 :          30 :       tmp2 = fold_convert (long_long_unsigned_type_node, arg);
    7076                 :          30 :       btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
    7077                 :          30 :       tmp2 = fold_convert (result_type,
    7078                 :             :                            build_call_expr_loc (input_location, btmp, 1, tmp2));
    7079                 :          30 :       tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
    7080                 :             :                               tmp2, ullsize);
    7081                 :             : 
    7082                 :          30 :       leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
    7083                 :             :                                cond, tmp1, tmp2);
    7084                 :             :     }
    7085                 :             : 
    7086                 :             :   /* Build BIT_SIZE.  */
    7087                 :         270 :   bit_size = build_int_cst (result_type, argsize);
    7088                 :             : 
    7089                 :         270 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    7090                 :         270 :                           arg, build_int_cst (arg_type, 0));
    7091                 :         270 :   se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
    7092                 :             :                               bit_size, leadz);
    7093                 :         270 : }
    7094                 :             : 
    7095                 :             : 
    7096                 :             : /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
    7097                 :             : 
    7098                 :             :    The conditional expression is necessary because the result of TRAILZ(0)
    7099                 :             :    is defined, but the result of __builtin_ctz(0) is undefined for most
    7100                 :             :    targets.  */
    7101                 :             : 
    7102                 :             : static void
    7103                 :         282 : gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
    7104                 :             : {
    7105                 :         282 :   tree arg;
    7106                 :         282 :   tree arg_type;
    7107                 :         282 :   tree cond;
    7108                 :         282 :   tree result_type;
    7109                 :         282 :   tree trailz;
    7110                 :         282 :   tree bit_size;
    7111                 :         282 :   tree func;
    7112                 :         282 :   int argsize;
    7113                 :             : 
    7114                 :         282 :   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
    7115                 :         282 :   argsize = TYPE_PRECISION (TREE_TYPE (arg));
    7116                 :             : 
    7117                 :             :   /* Which variant of __builtin_ctz* should we call?  */
    7118                 :         282 :   if (argsize <= INT_TYPE_SIZE)
    7119                 :             :     {
    7120                 :         195 :       arg_type = unsigned_type_node;
    7121                 :         195 :       func = builtin_decl_explicit (BUILT_IN_CTZ);
    7122                 :             :     }
    7123                 :          87 :   else if (argsize <= LONG_TYPE_SIZE)
    7124                 :             :     {
    7125                 :          57 :       arg_type = long_unsigned_type_node;
    7126                 :          57 :       func = builtin_decl_explicit (BUILT_IN_CTZL);
    7127                 :             :     }
    7128                 :          30 :   else if (argsize <= LONG_LONG_TYPE_SIZE)
    7129                 :             :     {
    7130                 :           0 :       arg_type = long_long_unsigned_type_node;
    7131                 :           0 :       func = builtin_decl_explicit (BUILT_IN_CTZLL);
    7132                 :             :     }
    7133                 :             :   else
    7134                 :             :     {
    7135                 :          30 :       gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
    7136                 :          30 :       arg_type = gfc_build_uint_type (argsize);
    7137                 :          30 :       func = NULL_TREE;
    7138                 :             :     }
    7139                 :             : 
    7140                 :             :   /* Convert the actual argument twice: first, to the unsigned type of the
    7141                 :             :      same size; then, to the proper argument type for the built-in
    7142                 :             :      function.  But the return type is of the default INTEGER kind.  */
    7143                 :         282 :   arg = fold_convert (gfc_build_uint_type (argsize), arg);
    7144                 :         282 :   arg = fold_convert (arg_type, arg);
    7145                 :         282 :   arg = gfc_evaluate_now (arg, &se->pre);
    7146                 :         282 :   result_type = gfc_get_int_type (gfc_default_integer_kind);
    7147                 :             : 
    7148                 :             :   /* Compute TRAILZ for the case i .ne. 0.  */
    7149                 :         282 :   if (func)
    7150                 :         252 :     trailz = fold_convert (result_type, build_call_expr_loc (input_location,
    7151                 :             :                                                              func, 1, arg));
    7152                 :             :   else
    7153                 :             :     {
    7154                 :             :       /* We end up here if the argument type is larger than 'long long'.
    7155                 :             :          We generate this code:
    7156                 :             : 
    7157                 :             :             if ((x & ULL_MAX) == 0)
    7158                 :             :               return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
    7159                 :             :             else
    7160                 :             :               return ctzll ((unsigned long long) x);
    7161                 :             : 
    7162                 :             :          where ULL_MAX is the largest value that a ULL_MAX can hold
    7163                 :             :          (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
    7164                 :             :          is the bit-size of the long long type (64 in this example).  */
    7165                 :          30 :       tree ullsize, ullmax, tmp1, tmp2, btmp;
    7166                 :             : 
    7167                 :          30 :       ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
    7168                 :          30 :       ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
    7169                 :             :                                 long_long_unsigned_type_node,
    7170                 :          30 :                                 build_int_cst (long_long_unsigned_type_node, 0));
    7171                 :             : 
    7172                 :          30 :       cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
    7173                 :             :                               fold_convert (arg_type, ullmax));
    7174                 :          30 :       cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, cond,
    7175                 :          30 :                               build_int_cst (arg_type, 0));
    7176                 :             : 
    7177                 :          30 :       tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
    7178                 :             :                               arg, ullsize);
    7179                 :          30 :       tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
    7180                 :          30 :       btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
    7181                 :          30 :       tmp1 = fold_convert (result_type,
    7182                 :             :                            build_call_expr_loc (input_location, btmp, 1, tmp1));
    7183                 :          30 :       tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
    7184                 :             :                               tmp1, ullsize);
    7185                 :             : 
    7186                 :          30 :       tmp2 = fold_convert (long_long_unsigned_type_node, arg);
    7187                 :          30 :       btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
    7188                 :          30 :       tmp2 = fold_convert (result_type,
    7189                 :             :                            build_call_expr_loc (input_location, btmp, 1, tmp2));
    7190                 :             : 
    7191                 :          30 :       trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
    7192                 :             :                                 cond, tmp1, tmp2);
    7193                 :             :     }
    7194                 :             : 
    7195                 :             :   /* Build BIT_SIZE.  */
    7196                 :         282 :   bit_size = build_int_cst (result_type, argsize);
    7197                 :             : 
    7198                 :         282 :   cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node,
    7199                 :         282 :                           arg, build_int_cst (arg_type, 0));
    7200                 :         282 :   se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
    7201                 :             :                               bit_size, trailz);
    7202                 :         282 : }
    7203                 :             : 
    7204                 :             : /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
    7205                 :             :    for types larger than "long long", we call the long long built-in for
    7206                 :             :    the lower and higher bits and combine the result.  */
    7207                 :             : 
    7208                 :             : static void
    7209                 :         134 : gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
    7210                 :             : {
    7211                 :         134 :   tree arg;
    7212                 :         134 :   tree arg_type;
    7213                 :         134 :   tree result_type;