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