gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002-2017 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 "tree-nested.h"
  35 #include "stor-layout.h"
  36 #include "toplev.h"     /* For rest_of_decl_compilation.  */
  37 #include "arith.h"
  38 #include "trans-const.h"
  39 #include "trans-types.h"
  40 #include "trans-array.h"
  41 #include "dependency.h" /* For CAF array alias analysis.  */
  42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  43
  44 /* This maps Fortran intrinsic math functions to external library or GCC
  45    builtin functions.  */
  46 typedef struct GTY(()) gfc_intrinsic_map_t {
  47   /* The explicit enum is required to work around inadequacies in the
  48      garbage collection/gengtype parsing mechanism.  */
  49   enum gfc_isym_id id;
  50
  51   /* Enum value from the "language-independent", aka C-centric, part
  52      of gcc, or END_BUILTINS of no such value set.  */
  53   enum built_in_function float_built_in;
  54   enum built_in_function double_built_in;
  55   enum built_in_function long_double_built_in;
  56   enum built_in_function complex_float_built_in;
  57   enum built_in_function complex_double_built_in;
  58   enum built_in_function complex_long_double_built_in;
  59
  60   /* True if the naming pattern is to prepend "c" for complex and
  61      append "f" for kind=4.  False if the naming pattern is to
  62      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  63   bool libm_name;
  64
  65   /* True if a complex version of the function exists.  */
  66   bool complex_available;
  67
  68   /* True if the function should be marked const.  */
  69   bool is_constant;
  70
  71   /* The base library name of this function.  */
  72   const char *name;
  73
  74   /* Cache decls created for the various operand types.  */
  75   tree real4_decl;
  76   tree real8_decl;
  77   tree real10_decl;
  78   tree real16_decl;
  79   tree complex4_decl;
  80   tree complex8_decl;
  81   tree complex10_decl;
  82   tree complex16_decl;
  83 }
  84 gfc_intrinsic_map_t;
  85
  86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  87    defines complex variants of all of the entries in mathbuiltins.def
  88    except for atan2.  */
  89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  90   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  91     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
  92     true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  93     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  94
  95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
  96   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  97     BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
  98     BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
  99     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 100
 101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 102   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 103     END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 104     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 106
 107 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
 108   { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 109     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 112
 113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 114 {
 115   /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
 116      DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
 117      to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro.  */
 118 #include "mathbuiltins.def"
 119
 120   /* Functions in libgfortran.  */
 121   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
 122
 123   /* End the list.  */
 124   LIB_FUNCTION (NONE, NULL, false)
 125
 126 };
 127 #undef OTHER_BUILTIN
 128 #undef LIB_FUNCTION
 129 #undef DEFINE_MATH_BUILTIN
 130 #undef DEFINE_MATH_BUILTIN_C
 131
 132
 133 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 134
 135
 136 /* Find the correct variant of a given builtin from its argument.  */
 137 static tree
 138 builtin_decl_for_precision (enum built_in_function base_built_in,
 139                             int precision)
 140 {
 141   enum built_in_function i = END_BUILTINS;
 142
 143   gfc_intrinsic_map_t *m;
 144   for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
 145     ;
 146
 147   if (precision == TYPE_PRECISION (float_type_node))
 148     i = m->float_built_in;
 149   else if (precision == TYPE_PRECISION (double_type_node))
 150     i = m->double_built_in;
 151   else if (precision == TYPE_PRECISION (long_double_type_node))
 152     i = m->long_double_built_in;
 153   else if (precision == TYPE_PRECISION (gfc_float128_type_node))
 154     {
 155       /* Special treatment, because it is not exactly a built-in, but
 156          a library function.  */
 157       return m->real16_decl;
 158     }
 159
 160   return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
 161 }
 162
 163
 164 tree
 165 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
 166                                  int kind)
 167 {
 168   int i = gfc_validate_kind (BT_REAL, kind, false);
 169
 170   if (gfc_real_kinds[i].c_float128)
 171     {
 172       /* For __float128, the story is a bit different, because we return
 173          a decl to a library function rather than a built-in.  */
 174       gfc_intrinsic_map_t *m;
 175       for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
 176         ;
 177
 178       return m->real16_decl;
 179     }
 180
 181   return builtin_decl_for_precision (double_built_in,
 182                                      gfc_real_kinds[i].mode_precision);
 183 }
 184
 185
 186 /* Evaluate the arguments to an intrinsic function.  The value
 187    of NARGS may be less than the actual number of arguments in EXPR
 188    to allow optional "KIND" arguments that are not included in the
 189    generated code to be ignored.  */
 190
 191 static void
 192 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 193                                   tree *argarray, int nargs)
 194 {
 195   gfc_actual_arglist *actual;
 196   gfc_expr *e;
 197   gfc_intrinsic_arg  *formal;
 198   gfc_se argse;
 199   int curr_arg;
 200
 201   formal = expr->value.function.isym->formal;
 202   actual = expr->value.function.actual;
 203
 204    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 205         actual = actual->next,
 206         formal = formal ? formal->next : NULL)
 207     {
 208       gcc_assert (actual);
 209       e = actual->expr;
 210       /* Skip omitted optional arguments.  */
 211       if (!e)
 212         {
 213           --curr_arg;
 214           continue;
 215         }
 216
 217       /* Evaluate the parameter.  This will substitute scalarized
 218          references automatically.  */
 219       gfc_init_se (&argse, se);
 220
 221       if (e->ts.type == BT_CHARACTER)
 222         {
 223           gfc_conv_expr (&argse, e);
 224           gfc_conv_string_parameter (&argse);
 225           argarray[curr_arg++] = argse.string_length;
 226           gcc_assert (curr_arg < nargs);
 227         }
 228       else
 229         gfc_conv_expr_val (&argse, e);
 230
 231       /* If an optional argument is itself an optional dummy argument,
 232          check its presence and substitute a null if absent.  */
 233       if (e->expr_type == EXPR_VARIABLE
 234             && e->symtree->n.sym->attr.optional
 235             && formal
 236             && formal->optional)
 237         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
 238
 239       gfc_add_block_to_block (&se->pre, &argse.pre);
 240       gfc_add_block_to_block (&se->post, &argse.post);
 241       argarray[curr_arg] = argse.expr;
 242     }
 243 }
 244
 245 /* Count the number of actual arguments to the intrinsic function EXPR
 246    including any "hidden" string length arguments.  */
 247
 248 static unsigned int
 249 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 250 {
 251   int n = 0;
 252   gfc_actual_arglist *actual;
 253
 254   for (actual = expr->value.function.actual; actual; actual = actual->next)
 255     {
 256       if (!actual->expr)
 257         continue;
 258
 259       if (actual->expr->ts.type == BT_CHARACTER)
 260         n += 2;
 261       else
 262         n++;
 263     }
 264
 265   return n;
 266 }
 267
 268
 269 /* Conversions between different types are output by the frontend as
 270    intrinsic functions.  We implement these directly with inline code.  */
 271
 272 static void
 273 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 274 {
 275   tree type;
 276   tree *args;
 277   int nargs;
 278
 279   nargs = gfc_intrinsic_argument_list_length (expr);
 280   args = XALLOCAVEC (tree, nargs);
 281
 282   /* Evaluate all the arguments passed. Whilst we're only interested in the
 283      first one here, there are other parts of the front-end that assume this
 284      and will trigger an ICE if it's not the case.  */
 285   type = gfc_typenode_for_spec (&expr->ts);
 286   gcc_assert (expr->value.function.actual->expr);
 287   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 288
 289   /* Conversion between character kinds involves a call to a library
 290      function.  */
 291   if (expr->ts.type == BT_CHARACTER)
 292     {
 293       tree fndecl, var, addr, tmp;
 294
 295       if (expr->ts.kind == 1
 296           && expr->value.function.actual->expr->ts.kind == 4)
 297         fndecl = gfor_fndecl_convert_char4_to_char1;
 298       else if (expr->ts.kind == 4
 299                && expr->value.function.actual->expr->ts.kind == 1)
 300         fndecl = gfor_fndecl_convert_char1_to_char4;
 301       else
 302         gcc_unreachable ();
 303
 304       /* Create the variable storing the converted value.  */
 305       type = gfc_get_pchar_type (expr->ts.kind);
 306       var = gfc_create_var (type, "str");
 307       addr = gfc_build_addr_expr (build_pointer_type (type), var);
 308
 309       /* Call the library function that will perform the conversion.  */
 310       gcc_assert (nargs >= 2);
 311       tmp = build_call_expr_loc (input_location,
 312                              fndecl, 3, addr, args[0], args[1]);
 313       gfc_add_expr_to_block (&se->pre, tmp);
 314
 315       /* Free the temporary afterwards.  */
 316       tmp = gfc_call_free (var);
 317       gfc_add_expr_to_block (&se->post, tmp);
 318
 319       se->expr = var;
 320       se->string_length = args[0];
 321
 322       return;
 323     }
 324
 325   /* Conversion from complex to non-complex involves taking the real
 326      component of the value.  */
 327   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 328       && expr->ts.type != BT_COMPLEX)
 329     {
 330       tree artype;
 331
 332       artype = TREE_TYPE (TREE_TYPE (args[0]));
 333       args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
 334                                  args[0]);
 335     }
 336
 337   se->expr = convert (type, args[0]);
 338 }
 339
 340 /* This is needed because the gcc backend only implements
 341    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 342    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 343    Similarly for CEILING.  */
 344
 345 static tree
 346 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 347 {
 348   tree tmp;
 349   tree cond;
 350   tree argtype;
 351   tree intval;
 352
 353   argtype = TREE_TYPE (arg);
 354   arg = gfc_evaluate_now (arg, pblock);
 355
 356   intval = convert (type, arg);
 357   intval = gfc_evaluate_now (intval, pblock);
 358
 359   tmp = convert (argtype, intval);
 360   cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
 361                           boolean_type_node, tmp, arg);
 362
 363   tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
 364                          intval, build_int_cst (type, 1));
 365   tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
 366   return tmp;
 367 }
 368
 369
 370 /* Round to nearest integer, away from zero.  */
 371
 372 static tree
 373 build_round_expr (tree arg, tree restype)
 374 {
 375   tree argtype;
 376   tree fn;
 377   int argprec, resprec;
 378
 379   argtype = TREE_TYPE (arg);
 380   argprec = TYPE_PRECISION (argtype);
 381   resprec = TYPE_PRECISION (restype);
 382
 383   /* Depending on the type of the result, choose the int intrinsic
 384      (iround, available only as a builtin, therefore cannot use it for
 385      __float128), long int intrinsic (lround family) or long long
 386      intrinsic (llround).  We might also need to convert the result
 387      afterwards.  */
 388   if (resprec <= INT_TYPE_SIZE && argprec <= LONG_DOUBLE_TYPE_SIZE)
 389     fn = builtin_decl_for_precision (BUILT_IN_IROUND, argprec);
 390   else if (resprec <= LONG_TYPE_SIZE)
 391     fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
 392   else if (resprec <= LONG_LONG_TYPE_SIZE)
 393     fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
 394   else
 395     gcc_unreachable ();
 396
 397   return fold_convert (restype, build_call_expr_loc (input_location,
 398                                                  fn, 1, arg));
 399 }
 400
 401
 402 /* Convert a real to an integer using a specific rounding mode.
 403    Ideally we would just build the corresponding GENERIC node,
 404    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 405
 406 static tree
 407 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 408                enum rounding_mode op)
 409 {
 410   switch (op)
 411     {
 412     case RND_FLOOR:
 413       return build_fixbound_expr (pblock, arg, type, 0);
 414
 415     case RND_CEIL:
 416       return build_fixbound_expr (pblock, arg, type, 1);
 417
 418     case RND_ROUND:
 419       return build_round_expr (arg, type);
 420
 421     case RND_TRUNC:
 422       return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
 423
 424     default:
 425       gcc_unreachable ();
 426     }
 427 }
 428
 429
 430 /* Round a real value using the specified rounding mode.
 431    We use a temporary integer of that same kind size as the result.
 432    Values larger than those that can be represented by this kind are
 433    unchanged, as they will not be accurate enough to represent the
 434    rounding.
 435     huge = HUGE (KIND (a))
 436     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 437    */
 438
 439 static void
 440 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 441 {
 442   tree type;
 443   tree itype;
 444   tree arg[2];
 445   tree tmp;
 446   tree cond;
 447   tree decl;
 448   mpfr_t huge;
 449   int n, nargs;
 450   int kind;
 451
 452   kind = expr->ts.kind;
 453   nargs = gfc_intrinsic_argument_list_length (expr);
 454
 455   decl = NULL_TREE;
 456   /* We have builtin functions for some cases.  */
 457   switch (op)
 458     {
 459     case RND_ROUND:
 460       decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
 461       break;
 462
 463     case RND_TRUNC:
 464       decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
 465       break;
 466
 467     default:
 468       gcc_unreachable ();
 469     }
 470
 471   /* Evaluate the argument.  */
 472   gcc_assert (expr->value.function.actual->expr);
 473   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
 474
 475   /* Use a builtin function if one exists.  */
 476   if (decl != NULL_TREE)
 477     {
 478       se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
 479       return;
 480     }
 481
 482   /* This code is probably redundant, but we'll keep it lying around just
 483      in case.  */
 484   type = gfc_typenode_for_spec (&expr->ts);
 485   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
 486
 487   /* Test if the value is too large to handle sensibly.  */
 488   gfc_set_model_kind (kind);
 489   mpfr_init (huge);
 490   n = gfc_validate_kind (BT_INTEGER, kind, false);
 491   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 492   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 493   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
 494                           tmp);
 495
 496   mpfr_neg (huge, huge, GFC_RND_MODE);
 497   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 498   tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
 499                          tmp);
 500   cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
 501                           cond, tmp);
 502   itype = gfc_get_int_type (kind);
 503
 504   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
 505   tmp = convert (type, tmp);
 506   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
 507                               arg[0]);
 508   mpfr_clear (huge);
 509 }
 510
 511
 512 /* Convert to an integer using the specified rounding mode.  */
 513
 514 static void
 515 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 516 {
 517   tree type;
 518   tree *args;
 519   int nargs;
 520
 521   nargs = gfc_intrinsic_argument_list_length (expr);
 522   args = XALLOCAVEC (tree, nargs);
 523
 524   /* Evaluate the argument, we process all arguments even though we only
 525      use the first one for code generation purposes.  */
 526   type = gfc_typenode_for_spec (&expr->ts);
 527   gcc_assert (expr->value.function.actual->expr);
 528   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 529
 530   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 531     {
 532       /* Conversion to a different integer kind.  */
 533       se->expr = convert (type, args[0]);
 534     }
 535   else
 536     {
 537       /* Conversion from complex to non-complex involves taking the real
 538          component of the value.  */
 539       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 540           && expr->ts.type != BT_COMPLEX)
 541         {
 542           tree artype;
 543
 544           artype = TREE_TYPE (TREE_TYPE (args[0]));
 545           args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
 546                                      args[0]);
 547         }
 548
 549       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 550     }
 551 }
 552
 553
 554 /* Get the imaginary component of a value.  */
 555
 556 static void
 557 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 558 {
 559   tree arg;
 560
 561   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 562   se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
 563                               TREE_TYPE (TREE_TYPE (arg)), arg);
 564 }
 565
 566
 567 /* Get the complex conjugate of a value.  */
 568
 569 static void
 570 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 571 {
 572   tree arg;
 573
 574   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 575   se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
 576 }
 577
 578
 579
 580 static tree
 581 define_quad_builtin (const char *name, tree type, bool is_const)
 582 {
 583   tree fndecl;
 584   fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
 585                        type);
 586
 587   /* Mark the decl as external.  */
 588   DECL_EXTERNAL (fndecl) = 1;
 589   TREE_PUBLIC (fndecl) = 1;
 590
 591   /* Mark it __attribute__((const)).  */
 592   TREE_READONLY (fndecl) = is_const;
 593
 594   rest_of_decl_compilation (fndecl, 1, 0);
 595
 596   return fndecl;
 597 }
 598
 599
 600
 601 /* Initialize function decls for library functions.  The external functions
 602    are created as required.  Builtin functions are added here.  */
 603
 604 void
 605 gfc_build_intrinsic_lib_fndecls (void)
 606 {
 607   gfc_intrinsic_map_t *m;
 608   tree quad_decls[END_BUILTINS + 1];
 609
 610   if (gfc_real16_is_float128)
 611   {
 612     /* If we have soft-float types, we create the decls for their
 613        C99-like library functions.  For now, we only handle __float128
 614        q-suffixed functions.  */
 615
 616     tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
 617     tree func_iround, func_lround, func_llround, func_scalbn, func_cpow;
 618
 619     memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
 620
 621     type = gfc_float128_type_node;
 622     complex_type = gfc_complex_float128_type_node;
 623     /* type (*) (type) */
 624     func_1 = build_function_type_list (type, type, NULL_TREE);
 625     /* int (*) (type) */
 626     func_iround = build_function_type_list (integer_type_node,
 627                                             type, NULL_TREE);
 628     /* long (*) (type) */
 629     func_lround = build_function_type_list (long_integer_type_node,
 630                                             type, NULL_TREE);
 631     /* long long (*) (type) */
 632     func_llround = build_function_type_list (long_long_integer_type_node,
 633                                              type, NULL_TREE);
 634     /* type (*) (type, type) */
 635     func_2 = build_function_type_list (type, type, type, NULL_TREE);
 636     /* type (*) (type, &int) */
 637     func_frexp
 638       = build_function_type_list (type,
 639                                   type,
 640                                   build_pointer_type (integer_type_node),
 641                                   NULL_TREE);
 642     /* type (*) (type, int) */
 643     func_scalbn = build_function_type_list (type,
 644                                             type, integer_type_node, NULL_TREE);
 645     /* type (*) (complex type) */
 646     func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
 647     /* complex type (*) (complex type, complex type) */
 648     func_cpow
 649       = build_function_type_list (complex_type,
 650                                   complex_type, complex_type, NULL_TREE);
 651
 652 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
 653 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
 654 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
 655
 656     /* Only these built-ins are actually needed here. These are used directly
 657        from the code, when calling builtin_decl_for_precision() or
 658        builtin_decl_for_float_type(). The others are all constructed by
 659        gfc_get_intrinsic_lib_fndecl().  */
 660 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
 661   quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
 662
 663 #include "mathbuiltins.def"
 664
 665 #undef OTHER_BUILTIN
 666 #undef LIB_FUNCTION
 667 #undef DEFINE_MATH_BUILTIN
 668 #undef DEFINE_MATH_BUILTIN_C
 669
 670     /* There is one built-in we defined manually, because it gets called
 671        with builtin_decl_for_precision() or builtin_decl_for_float_type()
 672        even though it is not an OTHER_BUILTIN: it is SQRT.  */
 673     quad_decls[BUILT_IN_SQRT] = define_quad_builtin ("sqrtq", func_1, true);
 674
 675   }
 676
 677   /* Add GCC builtin functions.  */
 678   for (m = gfc_intrinsic_map;
 679        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
 680     {
 681       if (m->float_built_in != END_BUILTINS)
 682         m->real4_decl = builtin_decl_explicit (m->float_built_in);
 683       if (m->complex_float_built_in != END_BUILTINS)
 684         m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
 685       if (m->double_built_in != END_BUILTINS)
 686         m->real8_decl = builtin_decl_explicit (m->double_built_in);
 687       if (m->complex_double_built_in != END_BUILTINS)
 688         m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
 689
 690       /* If real(kind=10) exists, it is always long double.  */
 691       if (m->long_double_built_in != END_BUILTINS)
 692         m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
 693       if (m->complex_long_double_built_in != END_BUILTINS)
 694         m->complex10_decl
 695           = builtin_decl_explicit (m->complex_long_double_built_in);
 696
 697       if (!gfc_real16_is_float128)
 698         {
 699           if (m->long_double_built_in != END_BUILTINS)
 700             m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
 701           if (m->complex_long_double_built_in != END_BUILTINS)
 702             m->complex16_decl
 703               = builtin_decl_explicit (m->complex_long_double_built_in);
 704         }
 705       else if (quad_decls[m->double_built_in] != NULL_TREE)
 706         {
 707           /* Quad-precision function calls are constructed when first
 708              needed by builtin_decl_for_precision(), except for those
 709              that will be used directly (define by OTHER_BUILTIN).  */
 710           m->real16_decl = quad_decls[m->double_built_in];
 711         }
 712       else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
 713         {
 714           /* Same thing for the complex ones.  */
 715           m->complex16_decl = quad_decls[m->double_built_in];
 716         }
 717     }
 718 }
 719
 720
 721 /* Create a fndecl for a simple intrinsic library function.  */
 722
 723 static tree
 724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 725 {
 726   tree type;
 727   vec<tree, va_gc> *argtypes;
 728   tree fndecl;
 729   gfc_actual_arglist *actual;
 730   tree *pdecl;
 731   gfc_typespec *ts;
 732   char name[GFC_MAX_SYMBOL_LEN + 3];
 733
 734   ts = &expr->ts;
 735   if (ts->type == BT_REAL)
 736     {
 737       switch (ts->kind)
 738         {
 739         case 4:
 740           pdecl = &m->real4_decl;
 741           break;
 742         case 8:
 743           pdecl = &m->real8_decl;
 744           break;
 745         case 10:
 746           pdecl = &m->real10_decl;
 747           break;
 748         case 16:
 749           pdecl = &m->real16_decl;
 750           break;
 751         default:
 752           gcc_unreachable ();
 753         }
 754     }
 755   else if (ts->type == BT_COMPLEX)
 756     {
 757       gcc_assert (m->complex_available);
 758
 759       switch (ts->kind)
 760         {
 761         case 4:
 762           pdecl = &m->complex4_decl;
 763           break;
 764         case 8:
 765           pdecl = &m->complex8_decl;
 766           break;
 767         case 10:
 768           pdecl = &m->complex10_decl;
 769           break;
 770         case 16:
 771           pdecl = &m->complex16_decl;
 772           break;
 773         default:
 774           gcc_unreachable ();
 775         }
 776     }
 777   else
 778     gcc_unreachable ();
 779
 780   if (*pdecl)
 781     return *pdecl;
 782
 783   if (m->libm_name)
 784     {
 785       int n = gfc_validate_kind (BT_REAL, ts->kind, false);
 786       if (gfc_real_kinds[n].c_float)
 787         snprintf (name, sizeof (name), "%s%s%s",
 788                   ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 789       else if (gfc_real_kinds[n].c_double)
 790         snprintf (name, sizeof (name), "%s%s",
 791                   ts->type == BT_COMPLEX ? "c" : "", m->name);
 792       else if (gfc_real_kinds[n].c_long_double)
 793         snprintf (name, sizeof (name), "%s%s%s",
 794                   ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 795       else if (gfc_real_kinds[n].c_float128)
 796         snprintf (name, sizeof (name), "%s%s%s",
 797                   ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
 798       else
 799         gcc_unreachable ();
 800     }
 801   else
 802     {
 803       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 804                 ts->type == BT_COMPLEX ? 'c' : 'r',
 805                 ts->kind);
 806     }
 807
 808   argtypes = NULL;
 809   for (actual = expr->value.function.actual; actual; actual = actual->next)
 810     {
 811       type = gfc_typenode_for_spec (&actual->expr->ts);
 812       vec_safe_push (argtypes, type);
 813     }
 814   type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
 815   fndecl = build_decl (input_location,
 816                        FUNCTION_DECL, get_identifier (name), type);
 817
 818   /* Mark the decl as external.  */
 819   DECL_EXTERNAL (fndecl) = 1;
 820   TREE_PUBLIC (fndecl) = 1;
 821
 822   /* Mark it __attribute__((const)), if possible.  */
 823   TREE_READONLY (fndecl) = m->is_constant;
 824
 825   rest_of_decl_compilation (fndecl, 1, 0);
 826
 827   (*pdecl) = fndecl;
 828   return fndecl;
 829 }
 830
 831
 832 /* Convert an intrinsic function into an external or builtin call.  */
 833
 834 static void
 835 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 836 {
 837   gfc_intrinsic_map_t *m;
 838   tree fndecl;
 839   tree rettype;
 840   tree *args;
 841   unsigned int num_args;
 842   gfc_isym_id id;
 843
 844   id = expr->value.function.isym->id;
 845   /* Find the entry for this function.  */
 846   for (m = gfc_intrinsic_map;
 847        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
 848     {
 849       if (id == m->id)
 850         break;
 851     }
 852
 853   if (m->id == GFC_ISYM_NONE)
 854     {
 855       gfc_internal_error ("Intrinsic function %qs (%d) not recognized",
 856                           expr->value.function.name, id);
 857     }
 858
 859   /* Get the decl and generate the call.  */
 860   num_args = gfc_intrinsic_argument_list_length (expr);
 861   args = XALLOCAVEC (tree, num_args);
 862
 863   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 864   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 865   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 866
 867   fndecl = build_addr (fndecl);
 868   se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
 869 }
 870
 871
 872 /* If bounds-checking is enabled, create code to verify at runtime that the
 873    string lengths for both expressions are the same (needed for e.g. MERGE).
 874    If bounds-checking is not enabled, does nothing.  */
 875
 876 void
 877 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
 878                              tree a, tree b, stmtblock_t* target)
 879 {
 880   tree cond;
 881   tree name;
 882
 883   /* If bounds-checking is disabled, do nothing.  */
 884   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
 885     return;
 886
 887   /* Compare the two string lengths.  */
 888   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
 889
 890   /* Output the runtime-check.  */
 891   name = gfc_build_cstring_const (intr_name);
 892   name = gfc_build_addr_expr (pchar_type_node, name);
 893   gfc_trans_runtime_check (true, false, cond, target, where,
 894                            "Unequal character lengths (%ld/%ld) in %s",
 895                            fold_convert (long_integer_type_node, a),
 896                            fold_convert (long_integer_type_node, b), name);
 897 }
 898
 899
 900 /* The EXPONENT(X) intrinsic function is translated into
 901        int ret;
 902        return isfinite(X) ? (frexp (X, &ret) , ret) : huge
 903    so that if X is a NaN or infinity, the result is HUGE(0).
 904  */
 905
 906 static void
 907 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 908 {
 909   tree arg, type, res, tmp, frexp, cond, huge;
 910   int i;
 911
 912   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
 913                                        expr->value.function.actual->expr->ts.kind);
 914
 915   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 916   arg = gfc_evaluate_now (arg, &se->pre);
 917
 918   i = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
 919   huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_c_int_kind);
 920   cond = build_call_expr_loc (input_location,
 921                               builtin_decl_explicit (BUILT_IN_ISFINITE),
 922                               1, arg);
 923
 924   res = gfc_create_var (integer_type_node, NULL);
 925   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
 926                              gfc_build_addr_expr (NULL_TREE, res));
 927   tmp = fold_build2_loc (input_location, COMPOUND_EXPR, integer_type_node,
 928                          tmp, res);
 929   se->expr = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
 930                               cond, tmp, huge);
 931
 932   type = gfc_typenode_for_spec (&expr->ts);
 933   se->expr = fold_convert (type, se->expr);
 934 }
 935
 936
 937 /* Fill in the following structure
 938      struct caf_vector_t {
 939        size_t nvec;  // size of the vector
 940        union {
 941          struct {
 942            void *vector;
 943            int kind;
 944          } v;
 945          struct {
 946            ptrdiff_t lower_bound;
 947            ptrdiff_t upper_bound;
 948            ptrdiff_t stride;
 949          } triplet;
 950        } u;
 951      }  */
 952
 953 static void
 954 conv_caf_vector_subscript_elem (stmtblock_t *block, int i, tree desc,
 955                                 tree lower, tree upper, tree stride,
 956                                 tree vector, int kind, tree nvec)
 957 {
 958   tree field, type, tmp;
 959
 960   desc = gfc_build_array_ref (desc, gfc_rank_cst[i], NULL_TREE);
 961   type = TREE_TYPE (desc);
 962
 963   field = gfc_advance_chain (TYPE_FIELDS (type), 0);
 964   tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 965                          desc, field, NULL_TREE);
 966   gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), nvec));
 967
 968   /* Access union.  */
 969   field = gfc_advance_chain (TYPE_FIELDS (type), 1);
 970   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 971                           desc, field, NULL_TREE);
 972   type = TREE_TYPE (desc);
 973
 974   /* Access the inner struct.  */
 975   field = gfc_advance_chain (TYPE_FIELDS (type), vector != NULL_TREE ? 0 : 1);
 976   desc = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 977                       desc, field, NULL_TREE);
 978   type = TREE_TYPE (desc);
 979
 980   if (vector != NULL_TREE)
 981     {
 982       /* Set vector and kind.  */
 983       field = gfc_advance_chain (TYPE_FIELDS (type), 0);
 984       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 985                          desc, field, NULL_TREE);
 986       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), vector));
 987       field = gfc_advance_chain (TYPE_FIELDS (type), 1);
 988       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 989                          desc, field, NULL_TREE);
 990       gfc_add_modify (block, tmp, build_int_cst (integer_type_node, kind));
 991     }
 992   else
 993     {
 994       /* Set dim.lower/upper/stride.  */
 995       field = gfc_advance_chain (TYPE_FIELDS (type), 0);
 996       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
 997                              desc, field, NULL_TREE);
 998       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), lower));
 999
1000       field = gfc_advance_chain (TYPE_FIELDS (type), 1);
1001       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1002                              desc, field, NULL_TREE);
1003       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), upper));
1004
1005       field = gfc_advance_chain (TYPE_FIELDS (type), 2);
1006       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1007                              desc, field, NULL_TREE);
1008       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field), stride));
1009     }
1010 }
1011
1012
1013 static tree
1014 conv_caf_vector_subscript (stmtblock_t *block, tree desc, gfc_array_ref *ar)
1015 {
1016   gfc_se argse;
1017   tree var, lower, upper = NULL_TREE, stride = NULL_TREE, vector, nvec;
1018   tree lbound, ubound, tmp;
1019   int i;
1020
1021   var = gfc_create_var (gfc_get_caf_vector_type (ar->dimen), "vector");
1022
1023   for (i = 0; i < ar->dimen; i++)
1024     switch (ar->dimen_type[i])
1025       {
1026       case DIMEN_RANGE:
1027         if (ar->end[i])
1028           {
1029             gfc_init_se (&argse, NULL);
1030             gfc_conv_expr (&argse, ar->end[i]);
1031             gfc_add_block_to_block (block, &argse.pre);
1032             upper = gfc_evaluate_now (argse.expr, block);
1033           }
1034         else
1035           upper = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
1036         if (ar->stride[i])
1037           {
1038             gfc_init_se (&argse, NULL);
1039             gfc_conv_expr (&argse, ar->stride[i]);
1040             gfc_add_block_to_block (block, &argse.pre);
1041             stride = gfc_evaluate_now (argse.expr, block);
1042           }
1043         else
1044           stride = gfc_index_one_node;
1045
1046         /* Fall through.  */
1047       case DIMEN_ELEMENT:
1048         if (ar->start[i])
1049           {
1050             gfc_init_se (&argse, NULL);
1051             gfc_conv_expr (&argse, ar->start[i]);
1052             gfc_add_block_to_block (block, &argse.pre);
1053             lower = gfc_evaluate_now (argse.expr, block);
1054           }
1055         else
1056           lower = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
1057         if (ar->dimen_type[i] == DIMEN_ELEMENT)
1058           {
1059             upper = lower;
1060             stride = gfc_index_one_node;
1061           }
1062         vector = NULL_TREE;
1063         nvec = size_zero_node;
1064         conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1065                                         vector, 0, nvec);
1066         break;
1067
1068       case DIMEN_VECTOR:
1069         gfc_init_se (&argse, NULL);
1070         argse.descriptor_only = 1;
1071         gfc_conv_expr_descriptor (&argse, ar->start[i]);
1072         gfc_add_block_to_block (block, &argse.pre);
1073         vector = argse.expr;
1074         lbound = gfc_conv_descriptor_lbound_get (vector, gfc_rank_cst[0]);
1075         ubound = gfc_conv_descriptor_ubound_get (vector, gfc_rank_cst[0]);
1076         nvec = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1077         tmp = gfc_conv_descriptor_stride_get (vector, gfc_rank_cst[0]);
1078         nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1079                                 TREE_TYPE (nvec), nvec, tmp);
1080         lower = gfc_index_zero_node;
1081         upper = gfc_index_zero_node;
1082         stride = gfc_index_zero_node;
1083         vector = gfc_conv_descriptor_data_get (vector);
1084         conv_caf_vector_subscript_elem (block, i, var, lower, upper, stride,
1085                                         vector, ar->start[i]->ts.kind, nvec);
1086         break;
1087       default:
1088         gcc_unreachable();
1089     }
1090   return gfc_build_addr_expr (NULL_TREE, var);
1091 }
1092
1093
1094 static tree
1095 compute_component_offset (tree field, tree type)
1096 {
1097   tree tmp;
1098   if (DECL_FIELD_BIT_OFFSET (field) != NULL_TREE
1099       && !integer_zerop (DECL_FIELD_BIT_OFFSET (field)))
1100     {
1101       tmp = fold_build2 (TRUNC_DIV_EXPR, type,
1102                          DECL_FIELD_BIT_OFFSET (field),
1103                          bitsize_unit_node);
1104       return fold_build2 (PLUS_EXPR, type, DECL_FIELD_OFFSET (field), tmp);
1105     }
1106   else
1107     return DECL_FIELD_OFFSET (field);
1108 }
1109
1110
1111 static tree
1112 conv_expr_ref_to_caf_ref (stmtblock_t *block, gfc_expr *expr)
1113 {
1114   gfc_ref *ref = expr->ref, *last_comp_ref;
1115   tree caf_ref = NULL_TREE, prev_caf_ref = NULL_TREE, reference_type, tmp, tmp2,
1116       field, last_type, inner_struct, mode, mode_rhs, dim_array, dim, dim_type,
1117       start, end, stride, vector, nvec;
1118   gfc_se se;
1119   bool ref_static_array = false;
1120   tree last_component_ref_tree = NULL_TREE;
1121   int i, last_type_n;
1122
1123   if (expr->symtree)
1124     {
1125       last_component_ref_tree = expr->symtree->n.sym->backend_decl;
1126       ref_static_array = !expr->symtree->n.sym->attr.allocatable
1127           && !expr->symtree->n.sym->attr.pointer;
1128     }
1129
1130   /* Prevent uninit-warning.  */
1131   reference_type = NULL_TREE;
1132
1133   /* Skip refs upto the first coarray-ref.  */
1134   last_comp_ref = NULL;
1135   while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0))
1136     {
1137       /* Remember the type of components skipped.  */
1138       if (ref->type == REF_COMPONENT)
1139         last_comp_ref = ref;
1140       ref = ref->next;
1141     }
1142   /* When a component was skipped, get the type information of the last
1143      component ref, else get the type from the symbol.  */
1144   if (last_comp_ref)
1145     {
1146       last_type = gfc_typenode_for_spec (&last_comp_ref->u.c.component->ts);
1147       last_type_n = last_comp_ref->u.c.component->ts.type;
1148     }
1149   else
1150     {
1151       last_type = gfc_typenode_for_spec (&expr->symtree->n.sym->ts);
1152       last_type_n = expr->symtree->n.sym->ts.type;
1153     }
1154
1155   while (ref)
1156     {
1157       if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0
1158           && ref->u.ar.dimen == 0)
1159         {
1160           /* Skip pure coindexes.  */
1161           ref = ref->next;
1162           continue;
1163         }
1164       tmp = gfc_create_var (gfc_get_caf_reference_type (), "caf_ref");
1165       reference_type = TREE_TYPE (tmp);
1166
1167       if (caf_ref == NULL_TREE)
1168         caf_ref = tmp;
1169
1170       /* Construct the chain of refs.  */
1171       if (prev_caf_ref != NULL_TREE)
1172         {
1173           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1174           tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1175                                   TREE_TYPE (field), prev_caf_ref, field,
1176                                   NULL_TREE);
1177           gfc_add_modify (block, tmp2, gfc_build_addr_expr (TREE_TYPE (field),
1178                                                             tmp));
1179         }
1180       prev_caf_ref = tmp;
1181
1182       switch (ref->type)
1183         {
1184         case REF_COMPONENT:
1185           last_type = gfc_typenode_for_spec (&ref->u.c.component->ts);
1186           last_type_n = ref->u.c.component->ts.type;
1187           /* Set the type of the ref.  */
1188           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1189           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1190                                  TREE_TYPE (field), prev_caf_ref, field,
1191                                  NULL_TREE);
1192           gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1193                                                      GFC_CAF_REF_COMPONENT));
1194
1195           /* Ref the c in union u.  */
1196           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1197           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1198                                  TREE_TYPE (field), prev_caf_ref, field,
1199                                  NULL_TREE);
1200           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 0);
1201           inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1202                                        TREE_TYPE (field), tmp, field,
1203                                        NULL_TREE);
1204
1205           /* Set the offset.  */
1206           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1207           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1208                                  TREE_TYPE (field), inner_struct, field,
1209                                  NULL_TREE);
1210           /* Computing the offset is somewhat harder.  The bit_offset has to be
1211              taken into account.  When the bit_offset in the field_decl is non-
1212              null, divide it by the bitsize_unit and add it to the regular
1213              offset.  */
1214           tmp2 = compute_component_offset (ref->u.c.component->backend_decl,
1215                                            TREE_TYPE (tmp));
1216           gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1217
1218           /* Set caf_token_offset.  */
1219           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 1);
1220           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1221                                  TREE_TYPE (field), inner_struct, field,
1222                                  NULL_TREE);
1223           if ((ref->u.c.component->attr.allocatable
1224                || ref->u.c.component->attr.pointer)
1225               && ref->u.c.component->attr.dimension)
1226             {
1227               tree arr_desc_token_offset;
1228               /* Get the token from the descriptor.  */
1229               arr_desc_token_offset = gfc_advance_chain (
1230                     TYPE_FIELDS (TREE_TYPE (ref->u.c.component->backend_decl)),
1231                     4 /* CAF_TOKEN_FIELD  */);
1232               arr_desc_token_offset
1233                   = compute_component_offset (arr_desc_token_offset,
1234                                               TREE_TYPE (tmp));
1235               tmp2 = fold_build2_loc (input_location, PLUS_EXPR,
1236                                       TREE_TYPE (tmp2), tmp2,
1237                                       arr_desc_token_offset);
1238             }
1239           else if (ref->u.c.component->caf_token)
1240             tmp2 = compute_component_offset (ref->u.c.component->caf_token,
1241                                              TREE_TYPE (tmp));
1242           else
1243             tmp2 = integer_zero_node;
1244           gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp), tmp2));
1245
1246           /* Remember whether this ref was to a non-allocatable/non-pointer
1247              component so the next array ref can be tailored correctly.  */
1248           ref_static_array = !ref->u.c.component->attr.allocatable
1249               && !ref->u.c.component->attr.pointer;
1250           last_component_ref_tree = ref_static_array
1251               ? ref->u.c.component->backend_decl : NULL_TREE;
1252           break;
1253         case REF_ARRAY:
1254           if (ref_static_array && ref->u.ar.as->type == AS_DEFERRED)
1255             ref_static_array = false;
1256           /* Set the type of the ref.  */
1257           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 1);
1258           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1259                                  TREE_TYPE (field), prev_caf_ref, field,
1260                                  NULL_TREE);
1261           gfc_add_modify (block, tmp, build_int_cst (integer_type_node,
1262                                                      ref_static_array
1263                                                      ? GFC_CAF_REF_STATIC_ARRAY
1264                                                      : GFC_CAF_REF_ARRAY));
1265
1266           /* Ref the a in union u.  */
1267           field = gfc_advance_chain (TYPE_FIELDS (reference_type), 3);
1268           tmp = fold_build3_loc (input_location, COMPONENT_REF,
1269                                  TREE_TYPE (field), prev_caf_ref, field,
1270                                  NULL_TREE);
1271           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (field)), 1);
1272           inner_struct = fold_build3_loc (input_location, COMPONENT_REF,
1273                                        TREE_TYPE (field), tmp, field,
1274                                        NULL_TREE);
1275
1276           /* Set the static_array_type in a for static arrays.  */
1277           if (ref_static_array)
1278             {
1279               field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)),
1280                                          1);
1281               tmp = fold_build3_loc (input_location, COMPONENT_REF,
1282                                      TREE_TYPE (field), inner_struct, field,
1283                                      NULL_TREE);
1284               gfc_add_modify (block, tmp, build_int_cst (TREE_TYPE (tmp),
1285                                                          last_type_n));
1286             }
1287           /* Ref the mode in the inner_struct.  */
1288           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 0);
1289           mode = fold_build3_loc (input_location, COMPONENT_REF,
1290                                   TREE_TYPE (field), inner_struct, field,
1291                                   NULL_TREE);
1292           /* Ref the dim in the inner_struct.  */
1293           field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (inner_struct)), 2);
1294           dim_array = fold_build3_loc (input_location, COMPONENT_REF,
1295                                        TREE_TYPE (field), inner_struct, field,
1296                                        NULL_TREE);
1297           for (i = 0; i < ref->u.ar.dimen; ++i)
1298             {
1299               /* Ref dim i.  */
1300               dim = gfc_build_array_ref (dim_array, gfc_rank_cst[i], NULL_TREE);
1301               dim_type = TREE_TYPE (dim);
1302               mode_rhs = start = end = stride = NULL_TREE;
1303               switch (ref->u.ar.dimen_type[i])
1304                 {
1305                 case DIMEN_RANGE:
1306                   if (ref->u.ar.end[i])
1307                     {
1308                       gfc_init_se (&se, NULL);
1309                       gfc_conv_expr (&se, ref->u.ar.end[i]);
1310                       gfc_add_block_to_block (block, &se.pre);
1311                       if (ref_static_array)
1312                         {
1313                           /* Make the index zero-based, when reffing a static
1314                              array.  */
1315                           end = se.expr;
1316                           gfc_init_se (&se, NULL);
1317                           gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1318                           gfc_add_block_to_block (block, &se.pre);
1319                           se.expr = fold_build2 (MINUS_EXPR,
1320                                                  gfc_array_index_type,
1321                                                  end, fold_convert (
1322                                                    gfc_array_index_type,
1323                                                    se.expr));
1324                         }
1325                       end = gfc_evaluate_now (fold_convert (
1326                                                 gfc_array_index_type,
1327                                                 se.expr),
1328                                               block);
1329                     }
1330                   else if (ref_static_array)
1331                     end = fold_build2 (MINUS_EXPR,
1332                                        gfc_array_index_type,
1333                                        gfc_conv_array_ubound (
1334                                          last_component_ref_tree, i),
1335                                        gfc_conv_array_lbound (
1336                                          last_component_ref_tree, i));
1337                   else
1338                     {
1339                       end = NULL_TREE;
1340                       mode_rhs = build_int_cst (unsigned_char_type_node,
1341                                                 GFC_CAF_ARR_REF_OPEN_END);
1342                     }
1343                   if (ref->u.ar.stride[i])
1344                     {
1345                       gfc_init_se (&se, NULL);
1346                       gfc_conv_expr (&se, ref->u.ar.stride[i]);
1347                       gfc_add_block_to_block (block, &se.pre);
1348                       stride = gfc_evaluate_now (fold_convert (
1349                                                    gfc_array_index_type,
1350                                                    se.expr),
1351                                                  block);
1352                       if (ref_static_array)
1353                         {
1354                           /* Make the index zero-based, when reffing a static
1355                              array.  */
1356                           stride = fold_build2 (MULT_EXPR,
1357                                                 gfc_array_index_type,
1358                                                 gfc_conv_array_stride (
1359                                                   last_component_ref_tree,
1360                                                   i),
1361                                                 stride);
1362                           gcc_assert (end != NULL_TREE);
1363                           /* Multiply with the product of array's stride and
1364                              the step of the ref to a virtual upper bound.
1365                              We can not compute the actual upper bound here or
1366                              the caflib would compute the extend
1367                              incorrectly.  */
1368                           end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1369                                              end, gfc_conv_array_stride (
1370                                                last_component_ref_tree,
1371                                                i));
1372                           end = gfc_evaluate_now (end, block);
1373                           stride = gfc_evaluate_now (stride, block);
1374                         }
1375                     }
1376                   else if (ref_static_array)
1377                     {
1378                       stride = gfc_conv_array_stride (last_component_ref_tree,
1379                                                       i);
1380                       end = fold_build2 (MULT_EXPR, gfc_array_index_type,
1381                                          end, stride);
1382                       end = gfc_evaluate_now (end, block);
1383                     }
1384                   else
1385                     /* Always set a ref stride of one to make caflib's
1386                        handling easier.  */
1387                     stride = gfc_index_one_node;
1388
1389                   /* Fall through.  */
1390                 case DIMEN_ELEMENT:
1391                   if (ref->u.ar.start[i])
1392                     {
1393                       gfc_init_se (&se, NULL);
1394                       gfc_conv_expr (&se, ref->u.ar.start[i]);
1395                       gfc_add_block_to_block (block, &se.pre);
1396                       if (ref_static_array)
1397                         {
1398                           /* Make the index zero-based, when reffing a static
1399                              array.  */
1400                           start = fold_convert (gfc_array_index_type, se.expr);
1401                           gfc_init_se (&se, NULL);
1402                           gfc_conv_expr (&se, ref->u.ar.as->lower[i]);
1403                           gfc_add_block_to_block (block, &se.pre);
1404                           se.expr = fold_build2 (MINUS_EXPR,
1405                                                  gfc_array_index_type,
1406                                                  start, fold_convert (
1407                                                    gfc_array_index_type,
1408                                                    se.expr));
1409                           /* Multiply with the stride.  */
1410                           se.expr = fold_build2 (MULT_EXPR,
1411                                                  gfc_array_index_type,
1412                                                  se.expr,
1413                                                  gfc_conv_array_stride (
1414                                                    last_component_ref_tree,
1415                                                    i));
1416                         }
1417                       start = gfc_evaluate_now (fold_convert (
1418                                                   gfc_array_index_type,
1419                                                   se.expr),
1420                                                 block);
1421                       if (mode_rhs == NULL_TREE)
1422                         mode_rhs = build_int_cst (unsigned_char_type_node,
1423                                                   ref->u.ar.dimen_type[i]
1424                                                   == DIMEN_ELEMENT
1425                                                   ? GFC_CAF_ARR_REF_SINGLE
1426                                                   : GFC_CAF_ARR_REF_RANGE);
1427                     }
1428                   else if (ref_static_array)
1429                     {
1430                       start = integer_zero_node;
1431                       mode_rhs = build_int_cst (unsigned_char_type_node,
1432                                                 ref->u.ar.start[i] == NULL
1433                                                 ? GFC_CAF_ARR_REF_FULL
1434                                                 : GFC_CAF_ARR_REF_RANGE);
1435                     }
1436                   else if (end == NULL_TREE)
1437                     mode_rhs = build_int_cst (unsigned_char_type_node,
1438                                               GFC_CAF_ARR_REF_FULL);
1439                   else
1440                     mode_rhs = build_int_cst (unsigned_char_type_node,
1441                                               GFC_CAF_ARR_REF_OPEN_START);
1442
1443                   /* Ref the s in dim.  */
1444                   field = gfc_advance_chain (TYPE_FIELDS (dim_type), 0);
1445                   tmp = fold_build3_loc (input_location, COMPONENT_REF,
1446                                          TREE_TYPE (field), dim, field,
1447                                          NULL_TREE);
1448
1449                   /* Set start in s.  */
1450                   if (start != NULL_TREE)
1451                     {
1452                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1453                                                  0);
1454                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1455                                               TREE_TYPE (field), tmp, field,
1456                                               NULL_TREE);
1457                       gfc_add_modify (block, tmp2,
1458                                       fold_convert (TREE_TYPE (tmp2), start));
1459                     }
1460
1461                   /* Set end in s.  */
1462                   if (end != NULL_TREE)
1463                     {
1464                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1465                                                  1);
1466                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1467                                               TREE_TYPE (field), tmp, field,
1468                                               NULL_TREE);
1469                       gfc_add_modify (block, tmp2,
1470                                       fold_convert (TREE_TYPE (tmp2), end));
1471                     }
1472
1473                   /* Set end in s.  */
1474                   if (stride != NULL_TREE)
1475                     {
1476                       field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)),
1477                                                  2);
1478                       tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1479                                               TREE_TYPE (field), tmp, field,
1480                                               NULL_TREE);
1481                       gfc_add_modify (block, tmp2,
1482                                       fold_convert (TREE_TYPE (tmp2), stride));
1483                     }
1484                   break;
1485                 case DIMEN_VECTOR:
1486                   /* TODO: In case of static array.  */
1487                   gcc_assert (!ref_static_array);
1488                   mode_rhs = build_int_cst (unsigned_char_type_node,
1489                                             GFC_CAF_ARR_REF_VECTOR);
1490                   gfc_init_se (&se, NULL);
1491                   se.descriptor_only = 1;
1492                   gfc_conv_expr_descriptor (&se, ref->u.ar.start[i]);
1493                   gfc_add_block_to_block (block, &se.pre);
1494                   vector = se.expr;
1495                   tmp = gfc_conv_descriptor_lbound_get (vector,
1496                                                         gfc_rank_cst[0]);
1497                   tmp2 = gfc_conv_descriptor_ubound_get (vector,
1498                                                          gfc_rank_cst[0]);
1499                   nvec = gfc_conv_array_extent_dim (tmp, tmp2, NULL);
1500                   tmp = gfc_conv_descriptor_stride_get (vector,
1501                                                         gfc_rank_cst[0]);
1502                   nvec = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1503                                           TREE_TYPE (nvec), nvec, tmp);
1504                   vector = gfc_conv_descriptor_data_get (vector);
1505
1506                   /* Ref the v in dim.  */
1507                   field = gfc_advance_chain (TYPE_FIELDS (dim_type), 1);
1508                   tmp = fold_build3_loc (input_location, COMPONENT_REF,
1509                                          TREE_TYPE (field), dim, field,
1510                                          NULL_TREE);
1511
1512                   /* Set vector in v.  */
1513                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 0);
1514                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1515                                           TREE_TYPE (field), tmp, field,
1516                                           NULL_TREE);
1517                   gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1518                                                              vector));
1519
1520                   /* Set nvec in v.  */
1521                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 1);
1522                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1523                                           TREE_TYPE (field), tmp, field,
1524                                           NULL_TREE);
1525                   gfc_add_modify (block, tmp2, fold_convert (TREE_TYPE (tmp2),
1526                                                              nvec));
1527
1528                   /* Set kind in v.  */
1529                   field = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (tmp)), 2);
1530                   tmp2 = fold_build3_loc (input_location, COMPONENT_REF,
1531                                           TREE_TYPE (field), tmp, field,
1532                                           NULL_TREE);
1533                   gfc_add_modify (block, tmp2, build_int_cst (integer_type_node,
1534                                                   ref->u.ar.start[i]->ts.kind));
1535                   break;
1536                 default:
1537                   gcc_unreachable ();
1538                 }
1539               /* Set the mode for dim i.  */
1540               tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1541               gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (tmp),
1542                                                         mode_rhs));
1543             }
1544
1545           /* Set the mode for dim i+1 to GFC_ARR_REF_NONE.  */
1546           if (i < GFC_MAX_DIMENSIONS)
1547             {
1548               tmp = gfc_build_array_ref (mode, gfc_rank_cst[i], NULL_TREE);
1549               gfc_add_modify (block, tmp,
1550                               build_int_cst (unsigned_char_type_node,
1551                                              GFC_CAF_ARR_REF_NONE));
1552             }
1553           break;
1554         default:
1555           gcc_unreachable ();
1556         }
1557
1558       /* Set the size of the current type.  */
1559       field = gfc_advance_chain (TYPE_FIELDS (reference_type), 2);
1560       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1561                              prev_caf_ref, field, NULL_TREE);
1562       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1563                                                 TYPE_SIZE_UNIT (last_type)));
1564
1565       ref = ref->next;
1566     }
1567
1568   if (prev_caf_ref != NULL_TREE)
1569     {
1570       field = gfc_advance_chain (TYPE_FIELDS (reference_type), 0);
1571       tmp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (field),
1572                              prev_caf_ref, field, NULL_TREE);
1573       gfc_add_modify (block, tmp, fold_convert (TREE_TYPE (field),
1574                                                   null_pointer_node));
1575     }
1576   return caf_ref != NULL_TREE ? gfc_build_addr_expr (NULL_TREE, caf_ref)
1577                               : NULL_TREE;
1578 }
1579
1580 /* Get data from a remote coarray.  */
1581
1582 static void
1583 gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
1584                             tree may_require_tmp, bool may_realloc,
1585                             symbol_attribute *caf_attr)
1586 {
1587   gfc_expr *array_expr, *tmp_stat;
1588   gfc_se argse;
1589   tree caf_decl, token, offset, image_index, tmp;
1590   tree res_var, dst_var, type, kind, vec, stat;
1591   tree caf_reference;
1592   symbol_attribute caf_attr_store;
1593
1594   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1595
1596   if (se->ss && se->ss->info->useflags)
1597     {
1598        /* Access the previously obtained result.  */
1599        gfc_conv_tmp_array_ref (se);
1600        return;
1601     }
1602
1603   /* If lhs is set, the CAF_GET intrinsic has already been stripped.  */
1604   array_expr = (lhs == NULL_TREE) ? expr->value.function.actual->expr : expr;
1605   type = gfc_typenode_for_spec (&array_expr->ts);
1606
1607   if (caf_attr == NULL)
1608     {
1609       caf_attr_store = gfc_caf_attr (array_expr);
1610       caf_attr = &caf_attr_store;
1611     }
1612
1613   res_var = lhs;
1614   dst_var = lhs;
1615
1616   vec = null_pointer_node;
1617   tmp_stat = gfc_find_stat_co (expr);
1618
1619   if (tmp_stat)
1620     {
1621       gfc_se stat_se;
1622       gfc_init_se (&stat_se, NULL);
1623       gfc_conv_expr_reference (&stat_se, tmp_stat);
1624       stat = stat_se.expr;
1625       gfc_add_block_to_block (&se->pre, &stat_se.pre);
1626       gfc_add_block_to_block (&se->post, &stat_se.post);
1627     }
1628   else
1629     stat = null_pointer_node;
1630
1631   /* Only use the new get_by_ref () where it is necessary.  I.e., when the lhs
1632      is reallocatable or the right-hand side has allocatable components.  */
1633   if (caf_attr->alloc_comp || caf_attr->pointer_comp || may_realloc)
1634     {
1635       /* Get using caf_get_by_ref.  */
1636       caf_reference = conv_expr_ref_to_caf_ref (&se->pre, array_expr);
1637
1638       if (caf_reference != NULL_TREE)
1639         {
1640           if (lhs == NULL_TREE)
1641             {
1642               if (array_expr->ts.type == BT_CHARACTER)
1643                 gfc_init_se (&argse, NULL);
1644               if (array_expr->rank == 0)
1645                 {
1646                   symbol_attribute attr;
1647                   gfc_clear_attr (&attr);
1648                   if (array_expr->ts.type == BT_CHARACTER)
1649                     {
1650                       res_var = gfc_conv_string_tmp (se,
1651                                                      build_pointer_type (type),
1652                                              array_expr->ts.u.cl->backend_decl);
1653                       argse.string_length = array_expr->ts.u.cl->backend_decl;
1654                     }
1655                   else
1656                     res_var = gfc_create_var (type, "caf_res");
1657                   dst_var = gfc_conv_scalar_to_descriptor (se, res_var, attr);
1658                   dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1659                 }
1660               else
1661                 {
1662                   /* Create temporary.  */
1663                   if (array_expr->ts.type == BT_CHARACTER)
1664                     gfc_conv_expr_descriptor (&argse, array_expr);
1665                   may_realloc = gfc_trans_create_temp_array (&se->pre,
1666                                                              &se->post,
1667                                                              se->ss, type,
1668                                                              NULL_TREE, false,
1669                                                              false, false,
1670                                                              &array_expr->where)
1671                       == NULL_TREE;
1672                   res_var = se->ss->info->data.array.descriptor;
1673                   dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1674                   if (may_realloc)
1675                     {
1676                       tmp = gfc_conv_descriptor_data_get (res_var);
1677                       tmp = gfc_deallocate_with_status (tmp, NULL_TREE,
1678                                                         NULL_TREE, NULL_TREE,
1679                                                         NULL_TREE, true,
1680                                                         NULL,
1681                                                      GFC_CAF_COARRAY_NOCOARRAY);
1682                       gfc_add_expr_to_block (&se->post, tmp);
1683                     }
1684                 }
1685             }
1686
1687           kind = build_int_cst (integer_type_node, expr->ts.kind);
1688           if (lhs_kind == NULL_TREE)
1689             lhs_kind = kind;
1690
1691           caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1692           if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1693             caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1694           image_index = gfc_caf_get_image_index (&se->pre, array_expr,
1695                                                  caf_decl);
1696           gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
1697                                     array_expr);
1698
1699           /* No overlap possible as we have generated a temporary.  */
1700           if (lhs == NULL_TREE)
1701             may_require_tmp = boolean_false_node;
1702
1703           /* It guarantees memory consistency within the same segment.  */
1704           tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1705           tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1706                             gfc_build_string_const (1, ""), NULL_TREE,
1707                             NULL_TREE, tree_cons (NULL_TREE, tmp, NULL_TREE),
1708                             NULL_TREE);
1709           ASM_VOLATILE_P (tmp) = 1;
1710           gfc_add_expr_to_block (&se->pre, tmp);
1711
1712           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get_by_ref,
1713                                      9, token, image_index, dst_var,
1714                                      caf_reference, lhs_kind, kind,
1715                                      may_require_tmp,
1716                                      may_realloc ? boolean_true_node :
1717                                                    boolean_false_node,
1718                                      stat);
1719
1720           gfc_add_expr_to_block (&se->pre, tmp);
1721
1722           if (se->ss)
1723             gfc_advance_se_ss_chain (se);
1724
1725           se->expr = res_var;
1726           if (array_expr->ts.type == BT_CHARACTER)
1727             se->string_length = argse.string_length;
1728
1729           return;
1730         }
1731     }
1732
1733   gfc_init_se (&argse, NULL);
1734   if (array_expr->rank == 0)
1735     {
1736       symbol_attribute attr;
1737
1738       gfc_clear_attr (&attr);
1739       gfc_conv_expr (&argse, array_expr);
1740
1741       if (lhs == NULL_TREE)
1742         {
1743           gfc_clear_attr (&attr);
1744           if (array_expr->ts.type == BT_CHARACTER)
1745             res_var = gfc_conv_string_tmp (se, build_pointer_type (type),
1746                                            argse.string_length);
1747           else
1748             res_var = gfc_create_var (type, "caf_res");
1749           dst_var = gfc_conv_scalar_to_descriptor (&argse, res_var, attr);
1750           dst_var = gfc_build_addr_expr (NULL_TREE, dst_var);
1751         }
1752       argse.expr = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
1753       argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1754     }
1755   else
1756     {
1757       /* If has_vector, pass descriptor for whole array and the
1758          vector bounds separately.  */
1759       gfc_array_ref *ar, ar2;
1760       bool has_vector = false;
1761
1762       if (gfc_is_coindexed (expr) && gfc_has_vector_subscript (expr))
1763         {
1764           has_vector = true;
1765           ar = gfc_find_array_ref (expr);
1766           ar2 = *ar;
1767           memset (ar, '\0', sizeof (*ar));
1768           ar->as = ar2.as;
1769           ar->type = AR_FULL;
1770         }
1771       // TODO: Check whether argse.want_coarray = 1 can help with the below.
1772       gfc_conv_expr_descriptor (&argse, array_expr);
1773       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1774          has the wrong type if component references are done.  */
1775       gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
1776                       gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1777                                                           : array_expr->rank,
1778                                                type));
1779       if (has_vector)
1780         {
1781           vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
1782           *ar = ar2;
1783         }
1784
1785       if (lhs == NULL_TREE)
1786         {
1787           /* Create temporary.  */
1788           for (int n = 0; n < se->ss->loop->dimen; n++)
1789             if (se->loop->to[n] == NULL_TREE)
1790               {
1791                 se->loop->from[n] = gfc_conv_descriptor_lbound_get (argse.expr,
1792                                                                gfc_rank_cst[n]);
1793                 se->loop->to[n] = gfc_conv_descriptor_ubound_get (argse.expr,
1794                                                                gfc_rank_cst[n]);
1795               }
1796           gfc_trans_create_temp_array (&argse.pre, &argse.post, se->ss, type,
1797                                        NULL_TREE, false, true, false,
1798                                        &array_expr->where);
1799           res_var = se->ss->info->data.array.descriptor;
1800           dst_var = gfc_build_addr_expr (NULL_TREE, res_var);
1801         }
1802       argse.expr = gfc_build_addr_expr (NULL_TREE, argse.expr);
1803     }
1804
1805   kind = build_int_cst (integer_type_node, expr->ts.kind);
1806   if (lhs_kind == NULL_TREE)
1807     lhs_kind = kind;
1808
1809   gfc_add_block_to_block (&se->pre, &argse.pre);
1810   gfc_add_block_to_block (&se->post, &argse.post);
1811
1812   caf_decl = gfc_get_tree_for_caf_expr (array_expr);
1813   if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1814     caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1815   image_index = gfc_caf_get_image_index (&se->pre, array_expr, caf_decl);
1816   gfc_get_caf_token_offset (se, &token, &offset, caf_decl, argse.expr,
1817                             array_expr);
1818
1819   /* No overlap possible as we have generated a temporary.  */
1820   if (lhs == NULL_TREE)
1821     may_require_tmp = boolean_false_node;
1822
1823   /* It guarantees memory consistency within the same segment.  */
1824   tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
1825   tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
1826                     gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
1827                     tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
1828   ASM_VOLATILE_P (tmp) = 1;
1829   gfc_add_expr_to_block (&se->pre, tmp);
1830
1831   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 10,
1832                              token, offset, image_index, argse.expr, vec,
1833                              dst_var, kind, lhs_kind, may_require_tmp, stat);
1834
1835   gfc_add_expr_to_block (&se->pre, tmp);
1836
1837   if (se->ss)
1838     gfc_advance_se_ss_chain (se);
1839
1840   se->expr = res_var;
1841   if (array_expr->ts.type == BT_CHARACTER)
1842     se->string_length = argse.string_length;
1843 }
1844
1845
1846 /* Send data to a remote coarray.  */
1847
1848 static tree
1849 conv_caf_send (gfc_code *code) {
1850   gfc_expr *lhs_expr, *rhs_expr, *tmp_stat;
1851   gfc_se lhs_se, rhs_se;
1852   stmtblock_t block;
1853   tree caf_decl, token, offset, image_index, tmp, lhs_kind, rhs_kind;
1854   tree may_require_tmp, src_stat, dst_stat;
1855   tree lhs_type = NULL_TREE;
1856   tree vec = null_pointer_node, rhs_vec = null_pointer_node;
1857   symbol_attribute lhs_caf_attr, rhs_caf_attr;
1858
1859   gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
1860
1861   lhs_expr = code->ext.actual->expr;
1862   rhs_expr = code->ext.actual->next->expr;
1863   may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, false) == 0
1864                     ? boolean_false_node : boolean_true_node;
1865   gfc_init_block (&block);
1866
1867   lhs_caf_attr = gfc_caf_attr (lhs_expr);
1868   rhs_caf_attr = gfc_caf_attr (rhs_expr);
1869   src_stat = dst_stat = null_pointer_node;
1870
1871   /* LHS.  */
1872   gfc_init_se (&lhs_se, NULL);
1873   if (lhs_expr->rank == 0)
1874     {
1875       symbol_attribute attr;
1876       gfc_clear_attr (&attr);
1877       gfc_conv_expr (&lhs_se, lhs_expr);
1878       lhs_type = TREE_TYPE (lhs_se.expr);
1879       lhs_se.expr = gfc_conv_scalar_to_descriptor (&lhs_se, lhs_se.expr, attr);
1880       lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
1881     }
1882   else if ((lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
1883            && lhs_caf_attr.codimension)
1884     {
1885       lhs_se.want_pointer = 1;
1886       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1887       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1888          has the wrong type if component references are done.  */
1889       lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1890       tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1891       gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1892                       gfc_get_dtype_rank_type (
1893                         gfc_has_vector_subscript (lhs_expr)
1894                         ? gfc_find_array_ref (lhs_expr)->dimen
1895                         : lhs_expr->rank,
1896                       lhs_type));
1897     }
1898   else
1899     {
1900       /* If has_vector, pass descriptor for whole array and the
1901          vector bounds separately.  */
1902       gfc_array_ref *ar, ar2;
1903       bool has_vector = false;
1904
1905       if (gfc_is_coindexed (lhs_expr) && gfc_has_vector_subscript (lhs_expr))
1906         {
1907           has_vector = true;
1908           ar = gfc_find_array_ref (lhs_expr);
1909           ar2 = *ar;
1910           memset (ar, '\0', sizeof (*ar));
1911           ar->as = ar2.as;
1912           ar->type = AR_FULL;
1913         }
1914       lhs_se.want_pointer = 1;
1915       gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
1916       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
1917          has the wrong type if component references are done.  */
1918       lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
1919       tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
1920       gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
1921                       gfc_get_dtype_rank_type (has_vector ? ar2.dimen
1922                                                           : lhs_expr->rank,
1923                       lhs_type));
1924       if (has_vector)
1925         {
1926           vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
1927           *ar = ar2;
1928         }
1929     }
1930
1931   lhs_kind = build_int_cst (integer_type_node, lhs_expr->ts.kind);
1932
1933   /* Special case: RHS is a coarray but LHS is not; this code path avoids a
1934      temporary and a loop.  */
1935   if (!gfc_is_coindexed (lhs_expr)
1936       && (!lhs_caf_attr.codimension
1937           || !(lhs_expr->rank > 0
1938                && (lhs_caf_attr.allocatable || lhs_caf_attr.pointer))))
1939     {
1940       bool lhs_may_realloc = lhs_expr->rank > 0 && lhs_caf_attr.allocatable;
1941       gcc_assert (gfc_is_coindexed (rhs_expr));
1942       gfc_init_se (&rhs_se, NULL);
1943       if (lhs_expr->rank == 0 && lhs_caf_attr.allocatable)
1944         {
1945           gfc_se scal_se;
1946           gfc_init_se (&scal_se, NULL);
1947           scal_se.want_pointer = 1;
1948           gfc_conv_expr (&scal_se, lhs_expr);
1949           /* Ensure scalar on lhs is allocated.  */
1950           gfc_add_block_to_block (&block, &scal_se.pre);
1951
1952           gfc_allocate_using_malloc (&scal_se.pre, scal_se.expr,
1953                                     TYPE_SIZE_UNIT (
1954                                        gfc_typenode_for_spec (&lhs_expr->ts)),
1955                                     NULL_TREE);
1956           tmp = fold_build2 (EQ_EXPR, boolean_type_node, scal_se.expr,
1957                              null_pointer_node);
1958           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
1959                                  tmp, gfc_finish_block (&scal_se.pre),
1960                                  build_empty_stmt (input_location));
1961           gfc_add_expr_to_block (&block, tmp);
1962         }
1963       else
1964         lhs_may_realloc = lhs_may_realloc
1965             && gfc_full_array_ref_p (lhs_expr->ref, NULL);
1966       gfc_add_block_to_block (&block, &lhs_se.pre);
1967       gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
1968                                   may_require_tmp, lhs_may_realloc,
1969                                   &rhs_caf_attr);
1970       gfc_add_block_to_block (&block, &rhs_se.pre);
1971       gfc_add_block_to_block (&block, &rhs_se.post);
1972       gfc_add_block_to_block (&block, &lhs_se.post);
1973       return gfc_finish_block (&block);
1974     }
1975
1976   gfc_add_block_to_block (&block, &lhs_se.pre);
1977
1978   /* Obtain token, offset and image index for the LHS.  */
1979   caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
1980   if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
1981     caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
1982   image_index = gfc_caf_get_image_index (&block, lhs_expr, caf_decl);
1983   tmp = lhs_se.expr;
1984   if (lhs_caf_attr.alloc_comp)
1985     gfc_get_caf_token_offset (&lhs_se, &token, NULL, caf_decl, NULL_TREE,
1986                               NULL);
1987   else
1988     gfc_get_caf_token_offset (&lhs_se, &token, &offset, caf_decl, tmp,
1989                               lhs_expr);
1990   lhs_se.expr = tmp;
1991
1992   /* RHS.  */
1993   gfc_init_se (&rhs_se, NULL);
1994   if (rhs_expr->expr_type == EXPR_FUNCTION && rhs_expr->value.function.isym
1995       && rhs_expr->value.function.isym->id == GFC_ISYM_CONVERSION)
1996     rhs_expr = rhs_expr->value.function.actual->expr;
1997   if (rhs_expr->rank == 0)
1998     {
1999       symbol_attribute attr;
2000       gfc_clear_attr (&attr);
2001       gfc_conv_expr (&rhs_se, rhs_expr);
2002       rhs_se.expr = gfc_conv_scalar_to_descriptor (&rhs_se, rhs_se.expr, attr);
2003       rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
2004     }
2005   else if ((rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2006            && rhs_caf_attr.codimension)
2007     {
2008       tree tmp2;
2009       rhs_se.want_pointer = 1;
2010       gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2011       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2012          has the wrong type if component references are done.  */
2013       tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2014       tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2015       gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2016                       gfc_get_dtype_rank_type (
2017                         gfc_has_vector_subscript (rhs_expr)
2018                         ? gfc_find_array_ref (rhs_expr)->dimen
2019                         : rhs_expr->rank,
2020                       tmp2));
2021     }
2022   else
2023     {
2024       /* If has_vector, pass descriptor for whole array and the
2025          vector bounds separately.  */
2026       gfc_array_ref *ar, ar2;
2027       bool has_vector = false;
2028       tree tmp2;
2029
2030       if (gfc_is_coindexed (rhs_expr) && gfc_has_vector_subscript (rhs_expr))
2031         {
2032           has_vector = true;
2033           ar = gfc_find_array_ref (rhs_expr);
2034           ar2 = *ar;
2035           memset (ar, '\0', sizeof (*ar));
2036           ar->as = ar2.as;
2037           ar->type = AR_FULL;
2038         }
2039       rhs_se.want_pointer = 1;
2040       gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
2041       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
2042          has the wrong type if component references are done.  */
2043       tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
2044       tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
2045       gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
2046                       gfc_get_dtype_rank_type (has_vector ? ar2.dimen
2047                                                           : rhs_expr->rank,
2048                       tmp2));
2049       if (has_vector)
2050         {
2051           rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
2052           *ar = ar2;
2053         }
2054     }
2055
2056   gfc_add_block_to_block (&block, &rhs_se.pre);
2057
2058   rhs_kind = build_int_cst (integer_type_node, rhs_expr->ts.kind);
2059
2060   tmp_stat = gfc_find_stat_co (lhs_expr);
2061
2062   if (tmp_stat)
2063     {
2064       gfc_se stat_se;
2065       gfc_init_se (&stat_se, NULL);
2066       gfc_conv_expr_reference (&stat_se, tmp_stat);
2067       dst_stat = stat_se.expr;
2068       gfc_add_block_to_block (&block, &stat_se.pre);
2069       gfc_add_block_to_block (&block, &stat_se.post);
2070     }
2071
2072   if (!gfc_is_coindexed (rhs_expr))
2073     {
2074       if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
2075         {
2076           tree reference, dst_realloc;
2077           reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2078           dst_realloc = lhs_caf_attr.allocatable ? boolean_true_node
2079                                              : boolean_false_node;
2080           tmp = build_call_expr_loc (input_location,
2081                                      gfor_fndecl_caf_send_by_ref,
2082                                      9, token, image_index, rhs_se.expr,
2083                                      reference, lhs_kind, rhs_kind,
2084                                      may_require_tmp, dst_realloc, src_stat);
2085           }
2086       else
2087         tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 10,
2088                                    token, offset, image_index, lhs_se.expr, vec,
2089                                    rhs_se.expr, lhs_kind, rhs_kind,
2090                                    may_require_tmp, src_stat);
2091     }
2092   else
2093     {
2094       tree rhs_token, rhs_offset, rhs_image_index;
2095
2096       /* It guarantees memory consistency within the same segment.  */
2097       tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2098       tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2099                           gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2100                           tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2101       ASM_VOLATILE_P (tmp) = 1;
2102       gfc_add_expr_to_block (&block, tmp);
2103
2104       caf_decl = gfc_get_tree_for_caf_expr (rhs_expr);
2105       if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
2106         caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
2107       rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
2108       tmp = rhs_se.expr;
2109       if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
2110         {
2111           tmp_stat = gfc_find_stat_co (lhs_expr);
2112
2113           if (tmp_stat)
2114             {
2115               gfc_se stat_se;
2116               gfc_init_se (&stat_se, NULL);
2117               gfc_conv_expr_reference (&stat_se, tmp_stat);
2118               src_stat = stat_se.expr;
2119               gfc_add_block_to_block (&block, &stat_se.pre);
2120               gfc_add_block_to_block (&block, &stat_se.post);
2121             }
2122
2123           gfc_get_caf_token_offset (&rhs_se, &rhs_token, NULL, caf_decl,
2124                                     NULL_TREE, NULL);
2125           tree lhs_reference, rhs_reference;
2126           lhs_reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
2127           rhs_reference = conv_expr_ref_to_caf_ref (&block, rhs_expr);
2128           tmp = build_call_expr_loc (input_location,
2129                                      gfor_fndecl_caf_sendget_by_ref, 11,
2130                                      token, image_index, lhs_reference,
2131                                      rhs_token, rhs_image_index, rhs_reference,
2132                                      lhs_kind, rhs_kind, may_require_tmp,
2133                                      dst_stat, src_stat);
2134         }
2135       else
2136         {
2137           gfc_get_caf_token_offset (&rhs_se, &rhs_token, &rhs_offset, caf_decl,
2138                                     tmp, rhs_expr);
2139           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sendget,
2140                                      14, token, offset, image_index,
2141                                      lhs_se.expr, vec, rhs_token, rhs_offset,
2142                                      rhs_image_index, tmp, rhs_vec, lhs_kind,
2143                                      rhs_kind, may_require_tmp, src_stat);
2144         }
2145     }
2146   gfc_add_expr_to_block (&block, tmp);
2147   gfc_add_block_to_block (&block, &lhs_se.post);
2148   gfc_add_block_to_block (&block, &rhs_se.post);
2149
2150   /* It guarantees memory consistency within the same segment.  */
2151   tmp = gfc_build_string_const (strlen ("memory") + 1, "memory");
2152   tmp = build5_loc (input_location, ASM_EXPR, void_type_node,
2153                     gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE,
2154                     tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE);
2155   ASM_VOLATILE_P (tmp) = 1;
2156   gfc_add_expr_to_block (&block, tmp);
2157
2158   return gfc_finish_block (&block);
2159 }
2160
2161
2162 static void
2163 trans_this_image (gfc_se * se, gfc_expr *expr)
2164 {
2165   stmtblock_t loop;
2166   tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
2167        lbound, ubound, extent, ml;
2168   gfc_se argse;
2169   int rank, corank;
2170   gfc_expr *distance = expr->value.function.actual->next->next->expr;
2171
2172   if (expr->value.function.actual->expr
2173       && !gfc_is_coarray (expr->value.function.actual->expr))
2174     distance = expr->value.function.actual->expr;
2175
2176   /* The case -fcoarray=single is handled elsewhere.  */
2177   gcc_assert (flag_coarray != GFC_FCOARRAY_SINGLE);
2178
2179   /* Argument-free version: THIS_IMAGE().  */
2180   if (distance || expr->value.function.actual->expr == NULL)
2181     {
2182       if (distance)
2183         {
2184           gfc_init_se (&argse, NULL);
2185           gfc_conv_expr_val (&argse, distance);
2186           gfc_add_block_to_block (&se->pre, &argse.pre);
2187           gfc_add_block_to_block (&se->post, &argse.post);
2188           tmp = fold_convert (integer_type_node, argse.expr);
2189         }
2190       else
2191         tmp = integer_zero_node;
2192       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2193                                  tmp);
2194       se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
2195                                tmp);
2196       return;
2197     }
2198
2199   /* Coarray-argument version: THIS_IMAGE(coarray [, dim]).  */
2200
2201   type = gfc_get_int_type (gfc_default_integer_kind);
2202   corank = gfc_get_corank (expr->value.function.actual->expr);
2203   rank = expr->value.function.actual->expr->rank;
2204
2205   /* Obtain the descriptor of the COARRAY.  */
2206   gfc_init_se (&argse, NULL);
2207   argse.want_coarray = 1;
2208   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2209   gfc_add_block_to_block (&se->pre, &argse.pre);
2210   gfc_add_block_to_block (&se->post, &argse.post);
2211   desc = argse.expr;
2212
2213   if (se->ss)
2214     {
2215       /* Create an implicit second parameter from the loop variable.  */
2216       gcc_assert (!expr->value.function.actual->next->expr);
2217       gcc_assert (corank > 0);
2218       gcc_assert (se->loop->dimen == 1);
2219       gcc_assert (se->ss->info->expr == expr);
2220
2221       dim_arg = se->loop->loopvar[0];
2222       dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
2223                                  gfc_array_index_type, dim_arg,
2224                                  build_int_cst (TREE_TYPE (dim_arg), 1));
2225       gfc_advance_se_ss_chain (se);
2226     }
2227   else
2228     {
2229       /* Use the passed DIM= argument.  */
2230       gcc_assert (expr->value.function.actual->next->expr);
2231       gfc_init_se (&argse, NULL);
2232       gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
2233                           gfc_array_index_type);
2234       gfc_add_block_to_block (&se->pre, &argse.pre);
2235       dim_arg = argse.expr;
2236
2237       if (INTEGER_CST_P (dim_arg))
2238         {
2239           if (wi::ltu_p (dim_arg, 1)
2240               || wi::gtu_p (dim_arg, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2241             gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2242                        "dimension index", expr->value.function.isym->name,
2243                        &expr->where);
2244         }
2245      else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2246         {
2247           dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
2248           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2249                                   dim_arg,
2250                                   build_int_cst (TREE_TYPE (dim_arg), 1));
2251           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2252           tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2253                                  dim_arg, tmp);
2254           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2255                                   boolean_type_node, cond, tmp);
2256           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2257                                    gfc_msg_fault);
2258         }
2259     }
2260
2261   /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
2262      one always has a dim_arg argument.
2263
2264      m = this_image() - 1
2265      if (corank == 1)
2266        {
2267          sub(1) = m + lcobound(corank)
2268          return;
2269        }
2270      i = rank
2271      min_var = min (rank + corank - 2, rank + dim_arg - 1)
2272      for (;;)
2273        {
2274          extent = gfc_extent(i)
2275          ml = m
2276          m  = m/extent
2277          if (i >= min_var)
2278            goto exit_label
2279          i++
2280        }
2281      exit_label:
2282      sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
2283                                        : m + lcobound(corank)
2284   */
2285
2286   /* this_image () - 1.  */
2287   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_this_image, 1,
2288                              integer_zero_node);
2289   tmp = fold_build2_loc (input_location, MINUS_EXPR, type,
2290                          fold_convert (type, tmp), build_int_cst (type, 1));
2291   if (corank == 1)
2292     {
2293       /* sub(1) = m + lcobound(corank).  */
2294       lbound = gfc_conv_descriptor_lbound_get (desc,
2295                         build_int_cst (TREE_TYPE (gfc_array_index_type),
2296                                        corank+rank-1));
2297       lbound = fold_convert (type, lbound);
2298       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2299
2300       se->expr = tmp;
2301       return;
2302     }
2303
2304   m = gfc_create_var (type, NULL);
2305   ml = gfc_create_var (type, NULL);
2306   loop_var = gfc_create_var (integer_type_node, NULL);
2307   min_var = gfc_create_var (integer_type_node, NULL);
2308
2309   /* m = this_image () - 1.  */
2310   gfc_add_modify (&se->pre, m, tmp);
2311
2312   /* min_var = min (rank + corank-2, rank + dim_arg - 1).  */
2313   tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2314                          fold_convert (integer_type_node, dim_arg),
2315                          build_int_cst (integer_type_node, rank - 1));
2316   tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
2317                          build_int_cst (integer_type_node, rank + corank - 2),
2318                          tmp);
2319   gfc_add_modify (&se->pre, min_var, tmp);
2320
2321   /* i = rank.  */
2322   tmp = build_int_cst (integer_type_node, rank);
2323   gfc_add_modify (&se->pre, loop_var, tmp);
2324
2325   exit_label = gfc_build_label_decl (NULL_TREE);
2326   TREE_USED (exit_label) = 1;
2327
2328   /* Loop body.  */
2329   gfc_init_block (&loop);
2330
2331   /* ml = m.  */
2332   gfc_add_modify (&loop, ml, m);
2333
2334   /* extent = ...  */
2335   lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
2336   ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
2337   extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2338   extent = fold_convert (type, extent);
2339
2340   /* m = m/extent.  */
2341   gfc_add_modify (&loop, m,
2342                   fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
2343                           m, extent));
2344
2345   /* Exit condition:  if (i >= min_var) goto exit_label.  */
2346   cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
2347                   min_var);
2348   tmp = build1_v (GOTO_EXPR, exit_label);
2349   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
2350                          build_empty_stmt (input_location));
2351   gfc_add_expr_to_block (&loop, tmp);
2352
2353   /* Increment loop variable: i++.  */
2354   gfc_add_modify (&loop, loop_var,
2355                   fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
2356                                    loop_var,
2357                                    build_int_cst (integer_type_node, 1)));
2358
2359   /* Making the loop... actually loop!  */
2360   tmp = gfc_finish_block (&loop);
2361   tmp = build1_v (LOOP_EXPR, tmp);
2362   gfc_add_expr_to_block (&se->pre, tmp);
2363
2364   /* The exit label.  */
2365   tmp = build1_v (LABEL_EXPR, exit_label);
2366   gfc_add_expr_to_block (&se->pre, tmp);
2367
2368   /*  sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
2369                                       : m + lcobound(corank) */
2370
2371   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
2372                           build_int_cst (TREE_TYPE (dim_arg), corank));
2373
2374   lbound = gfc_conv_descriptor_lbound_get (desc,
2375                 fold_build2_loc (input_location, PLUS_EXPR,
2376                                  gfc_array_index_type, dim_arg,
2377                                  build_int_cst (TREE_TYPE (dim_arg), rank-1)));
2378   lbound = fold_convert (type, lbound);
2379
2380   tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
2381                          fold_build2_loc (input_location, MULT_EXPR, type,
2382                                           m, extent));
2383   tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
2384
2385   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
2386                               fold_build2_loc (input_location, PLUS_EXPR, type,
2387                                                m, lbound));
2388 }
2389
2390
2391 static void
2392 trans_image_index (gfc_se * se, gfc_expr *expr)
2393 {
2394   tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
2395        tmp, invalid_bound;
2396   gfc_se argse, subse;
2397   int rank, corank, codim;
2398
2399   type = gfc_get_int_type (gfc_default_integer_kind);
2400   corank = gfc_get_corank (expr->value.function.actual->expr);
2401   rank = expr->value.function.actual->expr->rank;
2402
2403   /* Obtain the descriptor of the COARRAY.  */
2404   gfc_init_se (&argse, NULL);
2405   argse.want_coarray = 1;
2406   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2407   gfc_add_block_to_block (&se->pre, &argse.pre);
2408   gfc_add_block_to_block (&se->post, &argse.post);
2409   desc = argse.expr;
2410
2411   /* Obtain a handle to the SUB argument.  */
2412   gfc_init_se (&subse, NULL);
2413   gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr);
2414   gfc_add_block_to_block (&se->pre, &subse.pre);
2415   gfc_add_block_to_block (&se->post, &subse.post);
2416   subdesc = build_fold_indirect_ref_loc (input_location,
2417                         gfc_conv_descriptor_data_get (subse.expr));
2418
2419   /* Fortran 2008 does not require that the values remain in the cobounds,
2420      thus we need explicitly check this - and return 0 if they are exceeded.  */
2421
2422   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2423   tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
2424   invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2425                                  fold_convert (gfc_array_index_type, tmp),
2426                                  lbound);
2427
2428   for (codim = corank + rank - 2; codim >= rank; codim--)
2429     {
2430       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2431       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2432       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2433       cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2434                               fold_convert (gfc_array_index_type, tmp),
2435                               lbound);
2436       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2437                                        boolean_type_node, invalid_bound, cond);
2438       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2439                               fold_convert (gfc_array_index_type, tmp),
2440                               ubound);
2441       invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2442                                        boolean_type_node, invalid_bound, cond);
2443     }
2444
2445   invalid_bound = gfc_unlikely (invalid_bound, PRED_FORTRAN_INVALID_BOUND);
2446
2447   /* See Fortran 2008, C.10 for the following algorithm.  */
2448
2449   /* coindex = sub(corank) - lcobound(n).  */
2450   coindex = fold_convert (gfc_array_index_type,
2451                           gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
2452                                                NULL));
2453   lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
2454   coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2455                              fold_convert (gfc_array_index_type, coindex),
2456                              lbound);
2457
2458   for (codim = corank + rank - 2; codim >= rank; codim--)
2459     {
2460       tree extent, ubound;
2461
2462       /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
2463       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2464       ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
2465       extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
2466
2467       /* coindex *= extent.  */
2468       coindex = fold_build2_loc (input_location, MULT_EXPR,
2469                                  gfc_array_index_type, coindex, extent);
2470
2471       /* coindex += sub(codim).  */
2472       tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
2473       coindex = fold_build2_loc (input_location, PLUS_EXPR,
2474                                  gfc_array_index_type, coindex,
2475                                  fold_convert (gfc_array_index_type, tmp));
2476
2477       /* coindex -= lbound(codim).  */
2478       lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
2479       coindex = fold_build2_loc (input_location, MINUS_EXPR,
2480                                  gfc_array_index_type, coindex, lbound);
2481     }
2482
2483   coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
2484                              fold_convert(type, coindex),
2485                              build_int_cst (type, 1));
2486
2487   /* Return 0 if "coindex" exceeds num_images().  */
2488
2489   if (flag_coarray == GFC_FCOARRAY_SINGLE)
2490     num_images = build_int_cst (type, 1);
2491   else
2492     {
2493       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2494                                  integer_zero_node,
2495                                  build_int_cst (integer_type_node, -1));
2496       num_images = fold_convert (type, tmp);
2497     }
2498
2499   tmp = gfc_create_var (type, NULL);
2500   gfc_add_modify (&se->pre, tmp, coindex);
2501
2502   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
2503                           num_images);
2504   cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
2505                           cond,
2506                           fold_convert (boolean_type_node, invalid_bound));
2507   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
2508                               build_int_cst (type, 0), tmp);
2509 }
2510
2511
2512 static void
2513 trans_num_images (gfc_se * se, gfc_expr *expr)
2514 {
2515   tree tmp, distance, failed;
2516   gfc_se argse;
2517
2518   if (expr->value.function.actual->expr)
2519     {
2520       gfc_init_se (&argse, NULL);
2521       gfc_conv_expr_val (&argse, expr->value.function.actual->expr);
2522       gfc_add_block_to_block (&se->pre, &argse.pre);
2523       gfc_add_block_to_block (&se->post, &argse.post);
2524       distance = fold_convert (integer_type_node, argse.expr);
2525     }
2526   else
2527     distance = integer_zero_node;
2528
2529   if (expr->value.function.actual->next->expr)
2530     {
2531       gfc_init_se (&argse, NULL);
2532       gfc_conv_expr_val (&argse, expr->value.function.actual->next->expr);
2533       gfc_add_block_to_block (&se->pre, &argse.pre);
2534       gfc_add_block_to_block (&se->post, &argse.post);
2535       failed = fold_convert (integer_type_node, argse.expr);
2536     }
2537   else
2538     failed = build_int_cst (integer_type_node, -1);
2539
2540   tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, 2,
2541                              distance, failed);
2542   se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
2543 }
2544
2545
2546 static void
2547 gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
2548 {
2549   gfc_se argse;
2550
2551   gfc_init_se (&argse, NULL);
2552   argse.data_not_needed = 1;
2553   argse.descriptor_only = 1;
2554
2555   gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr);
2556   gfc_add_block_to_block (&se->pre, &argse.pre);
2557   gfc_add_block_to_block (&se->post, &argse.post);
2558
2559   se->expr = gfc_conv_descriptor_rank (argse.expr);
2560 }
2561
2562
2563 /* Evaluate a single upper or lower bound.  */
2564 /* TODO: bound intrinsic generates way too much unnecessary code.  */
2565
2566 static void
2567 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
2568 {
2569   gfc_actual_arglist *arg;
2570   gfc_actual_arglist *arg2;
2571   tree desc;
2572   tree type;
2573   tree bound;
2574   tree tmp;
2575   tree cond, cond1, cond3, cond4, size;
2576   tree ubound;
2577   tree lbound;
2578   gfc_se argse;
2579   gfc_array_spec * as;
2580   bool assumed_rank_lb_one;
2581
2582   arg = expr->value.function.actual;
2583   arg2 = arg->next;
2584
2585   if (se->ss)
2586     {
2587       /* Create an implicit second parameter from the loop variable.  */
2588       gcc_assert (!arg2->expr);
2589       gcc_assert (se->loop->dimen == 1);
2590       gcc_assert (se->ss->info->expr == expr);
2591       gfc_advance_se_ss_chain (se);
2592       bound = se->loop->loopvar[0];
2593       bound = fold_build2_loc (input_location, MINUS_EXPR,
2594                                gfc_array_index_type, bound,
2595                                se->loop->from[0]);
2596     }
2597   else
2598     {
2599       /* use the passed argument.  */
2600       gcc_assert (arg2->expr);
2601       gfc_init_se (&argse, NULL);
2602       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2603       gfc_add_block_to_block (&se->pre, &argse.pre);
2604       bound = argse.expr;
2605       /* Convert from one based to zero based.  */
2606       bound = fold_build2_loc (input_location, MINUS_EXPR,
2607                                gfc_array_index_type, bound,
2608                                gfc_index_one_node);
2609     }
2610
2611   /* TODO: don't re-evaluate the descriptor on each iteration.  */
2612   /* Get a descriptor for the first parameter.  */
2613   gfc_init_se (&argse, NULL);
2614   gfc_conv_expr_descriptor (&argse, arg->expr);
2615   gfc_add_block_to_block (&se->pre, &argse.pre);
2616   gfc_add_block_to_block (&se->post, &argse.post);
2617
2618   desc = argse.expr;
2619
2620   as = gfc_get_full_arrayspec_from_expr (arg->expr);
2621
2622   if (INTEGER_CST_P (bound))
2623     {
2624       if (((!as || as->type != AS_ASSUMED_RANK)
2625            && wi::geu_p (bound, GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))))
2626           || wi::gtu_p (bound, GFC_MAX_DIMENSIONS))
2627         gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2628                    "dimension index", upper ? "UBOUND" : "LBOUND",
2629                    &expr->where);
2630     }
2631
2632   if (!INTEGER_CST_P (bound) || (as && as->type == AS_ASSUMED_RANK))
2633     {
2634       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2635         {
2636           bound = gfc_evaluate_now (bound, &se->pre);
2637           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2638                                   bound, build_int_cst (TREE_TYPE (bound), 0));
2639           if (as && as->type == AS_ASSUMED_RANK)
2640             tmp = gfc_conv_descriptor_rank (desc);
2641           else
2642             tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
2643           tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2644                                  bound, fold_convert(TREE_TYPE (bound), tmp));
2645           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2646                                   boolean_type_node, cond, tmp);
2647           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2648                                    gfc_msg_fault);
2649         }
2650     }
2651
2652   /* Take care of the lbound shift for assumed-rank arrays, which are
2653      nonallocatable and nonpointers. Those has a lbound of 1.  */
2654   assumed_rank_lb_one = as && as->type == AS_ASSUMED_RANK
2655                         && ((arg->expr->ts.type != BT_CLASS
2656                              && !arg->expr->symtree->n.sym->attr.allocatable
2657                              && !arg->expr->symtree->n.sym->attr.pointer)
2658                             || (arg->expr->ts.type == BT_CLASS
2659                              && !CLASS_DATA (arg->expr)->attr.allocatable
2660                              && !CLASS_DATA (arg->expr)->attr.class_pointer));
2661
2662   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
2663   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
2664
2665   /* 13.14.53: Result value for LBOUND
2666
2667      Case (i): For an array section or for an array expression other than a
2668                whole array or array structure component, LBOUND(ARRAY, DIM)
2669                has the value 1.  For a whole array or array structure
2670                component, LBOUND(ARRAY, DIM) has the value:
2671                  (a) equal to the lower bound for subscript DIM of ARRAY if
2672                      dimension DIM of ARRAY does not have extent zero
2673                      or if ARRAY is an assumed-size array of rank DIM,
2674               or (b) 1 otherwise.
2675
2676      13.14.113: Result value for UBOUND
2677
2678      Case (i): For an array section or for an array expression other than a
2679                whole array or array structure component, UBOUND(ARRAY, DIM)
2680                has the value equal to the number of elements in the given
2681                dimension; otherwise, it has a value equal to the upper bound
2682                for subscript DIM of ARRAY if dimension DIM of ARRAY does
2683                not have size zero and has value zero if dimension DIM has
2684                size zero.  */
2685
2686   if (!upper && assumed_rank_lb_one)
2687     se->expr = gfc_index_one_node;
2688   else if (as)
2689     {
2690       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
2691
2692       cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2693                                ubound, lbound);
2694       cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
2695                                stride, gfc_index_zero_node);
2696       cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2697                                boolean_type_node, cond3, cond1);
2698       cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2699                                stride, gfc_index_zero_node);
2700
2701       if (upper)
2702         {
2703           tree cond5;
2704           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2705                                   boolean_type_node, cond3, cond4);
2706           cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2707                                    gfc_index_one_node, lbound);
2708           cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
2709                                    boolean_type_node, cond4, cond5);
2710
2711           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2712                                   boolean_type_node, cond, cond5);
2713
2714           if (assumed_rank_lb_one)
2715             {
2716               tmp = fold_build2_loc (input_location, MINUS_EXPR,
2717                                gfc_array_index_type, ubound, lbound);
2718               tmp = fold_build2_loc (input_location, PLUS_EXPR,
2719                                gfc_array_index_type, tmp, gfc_index_one_node);
2720             }
2721           else
2722             tmp = ubound;
2723
2724           se->expr = fold_build3_loc (input_location, COND_EXPR,
2725                                       gfc_array_index_type, cond,
2726                                       tmp, gfc_index_zero_node);
2727         }
2728       else
2729         {
2730           if (as->type == AS_ASSUMED_SIZE)
2731             cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2732                                     bound, build_int_cst (TREE_TYPE (bound),
2733                                                           arg->expr->rank - 1));
2734           else
2735             cond = boolean_false_node;
2736
2737           cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2738                                    boolean_type_node, cond3, cond4);
2739           cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2740                                   boolean_type_node, cond, cond1);
2741
2742           se->expr = fold_build3_loc (input_location, COND_EXPR,
2743                                       gfc_array_index_type, cond,
2744                                       lbound, gfc_index_one_node);
2745         }
2746     }
2747   else
2748     {
2749       if (upper)
2750         {
2751           size = fold_build2_loc (input_location, MINUS_EXPR,
2752                                   gfc_array_index_type, ubound, lbound);
2753           se->expr = fold_build2_loc (input_location, PLUS_EXPR,
2754                                       gfc_array_index_type, size,
2755                                   gfc_index_one_node);
2756           se->expr = fold_build2_loc (input_location, MAX_EXPR,
2757                                       gfc_array_index_type, se->expr,
2758                                       gfc_index_zero_node);
2759         }
2760       else
2761         se->expr = gfc_index_one_node;
2762     }
2763
2764   type = gfc_typenode_for_spec (&expr->ts);
2765   se->expr = convert (type, se->expr);
2766 }
2767
2768
2769 static void
2770 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
2771 {
2772   gfc_actual_arglist *arg;
2773   gfc_actual_arglist *arg2;
2774   gfc_se argse;
2775   tree bound, resbound, resbound2, desc, cond, tmp;
2776   tree type;
2777   int corank;
2778
2779   gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
2780               || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
2781               || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
2782
2783   arg = expr->value.function.actual;
2784   arg2 = arg->next;
2785
2786   gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
2787   corank = gfc_get_corank (arg->expr);
2788
2789   gfc_init_se (&argse, NULL);
2790   argse.want_coarray = 1;
2791
2792   gfc_conv_expr_descriptor (&argse, arg->expr);
2793   gfc_add_block_to_block (&se->pre, &argse.pre);
2794   gfc_add_block_to_block (&se->post, &argse.post);
2795   desc = argse.expr;
2796
2797   if (se->ss)
2798     {
2799       /* Create an implicit second parameter from the loop variable.  */
2800       gcc_assert (!arg2->expr);
2801       gcc_assert (corank > 0);
2802       gcc_assert (se->loop->dimen == 1);
2803       gcc_assert (se->ss->info->expr == expr);
2804
2805       bound = se->loop->loopvar[0];
2806       bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
2807                                bound, gfc_rank_cst[arg->expr->rank]);
2808       gfc_advance_se_ss_chain (se);
2809     }
2810   else
2811     {
2812       /* use the passed argument.  */
2813       gcc_assert (arg2->expr);
2814       gfc_init_se (&argse, NULL);
2815       gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
2816       gfc_add_block_to_block (&se->pre, &argse.pre);
2817       bound = argse.expr;
2818
2819       if (INTEGER_CST_P (bound))
2820         {
2821           if (wi::ltu_p (bound, 1)
2822               || wi::gtu_p (bound, GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))))
2823             gfc_error ("%<dim%> argument of %s intrinsic at %L is not a valid "
2824                        "dimension index", expr->value.function.isym->name,
2825                        &expr->where);
2826         }
2827       else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
2828         {
2829           bound = gfc_evaluate_now (bound, &se->pre);
2830           cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
2831                                   bound, build_int_cst (TREE_TYPE (bound), 1));
2832           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
2833           tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2834                                  bound, tmp);
2835           cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
2836                                   boolean_type_node, cond, tmp);
2837           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
2838                                    gfc_msg_fault);
2839         }
2840
2841
2842       /* Subtract 1 to get to zero based and add dimensions.  */
2843       switch (arg->expr->rank)
2844         {
2845         case 0:
2846           bound = fold_build2_loc (input_location, MINUS_EXPR,
2847                                    gfc_array_index_type, bound,
2848                                    gfc_index_one_node);
2849         case 1:
2850           break;
2851         default:
2852           bound = fold_build2_loc (input_location, PLUS_EXPR,
2853                                    gfc_array_index_type, bound,
2854                                    gfc_rank_cst[arg->expr->rank - 1]);
2855         }
2856     }
2857
2858   resbound = gfc_conv_descriptor_lbound_get (desc, bound);
2859
2860   /* Handle UCOBOUND with special handling of the last codimension.  */
2861   if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
2862     {
2863       /* Last codimension: For -fcoarray=single just return
2864          the lcobound - otherwise add
2865            ceiling (real (num_images ()) / real (size)) - 1
2866          = (num_images () + size - 1) / size - 1
2867          = (num_images - 1) / size(),
2868          where size is the product of the extent of all but the last
2869          codimension.  */
2870
2871       if (flag_coarray != GFC_FCOARRAY_SINGLE && corank > 1)
2872         {
2873           tree cosize;
2874
2875           cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
2876           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2877                                      2, integer_zero_node,
2878                                      build_int_cst (integer_type_node, -1));
2879           tmp = fold_build2_loc (input_location, MINUS_EXPR,
2880                                  gfc_array_index_type,
2881                                  fold_convert (gfc_array_index_type, tmp),
2882                                  build_int_cst (gfc_array_index_type, 1));
2883           tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
2884                                  gfc_array_index_type, tmp,
2885                                  fold_convert (gfc_array_index_type, cosize));
2886           resbound = fold_build2_loc (input_location, PLUS_EXPR,
2887                                       gfc_array_index_type, resbound, tmp);
2888         }
2889       else if (flag_coarray != GFC_FCOARRAY_SINGLE)
2890         {
2891           /* ubound = lbound + num_images() - 1.  */
2892           tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images,
2893                                      2, integer_zero_node,
2894                                      build_int_cst (integer_type_node, -1));
2895           tmp = fold_build2_loc (input_location, MINUS_EXPR,
2896                                  gfc_array_index_type,
2897                                  fold_convert (gfc_array_index_type, tmp),
2898                                  build_int_cst (gfc_array_index_type, 1));
2899           resbound = fold_build2_loc (input_location, PLUS_EXPR,
2900                                       gfc_array_index_type, resbound, tmp);
2901         }
2902
2903       if (corank > 1)
2904         {
2905           cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
2906                                   bound,
2907                                   build_int_cst (TREE_TYPE (bound),
2908                                                  arg->expr->rank + corank - 1));
2909
2910           resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
2911           se->expr = fold_build3_loc (input_location, COND_EXPR,
2912                                       gfc_array_index_type, cond,
2913                                       resbound, resbound2);
2914         }
2915       else
2916         se->expr = resbound;
2917     }
2918   else
2919     se->expr = resbound;
2920
2921   type = gfc_typenode_for_spec (&expr->ts);
2922   se->expr = convert (type, se->expr);
2923 }
2924
2925
2926 static void
2927 conv_intrinsic_stride (gfc_se * se, gfc_expr * expr)
2928 {
2929   gfc_actual_arglist *array_arg;
2930   gfc_actual_arglist *dim_arg;
2931   gfc_se argse;
2932   tree desc, tmp;
2933
2934   array_arg = expr->value.function.actual;
2935   dim_arg = array_arg->next;
2936
2937   gcc_assert (array_arg->expr->expr_type == EXPR_VARIABLE);
2938
2939   gfc_init_se (&argse, NULL);
2940   gfc_conv_expr_descriptor (&argse, array_arg->expr);
2941   gfc_add_block_to_block (&se->pre, &argse.pre);
2942   gfc_add_block_to_block (&se->post, &argse.post);
2943   desc = argse.expr;
2944
2945   gcc_assert (dim_arg->expr);
2946   gfc_init_se (&argse, NULL);
2947   gfc_conv_expr_type (&argse, dim_arg->expr, gfc_array_index_type);
2948   gfc_add_block_to_block (&se->pre, &argse.pre);
2949   tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
2950                          argse.expr, gfc_index_one_node);
2951   se->expr = gfc_conv_descriptor_stride_get (desc, tmp);
2952 }
2953
2954
2955 static void
2956 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
2957 {
2958   tree arg, cabs;
2959
2960   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2961
2962   switch (expr->value.function.actual->expr->ts.type)
2963     {
2964     case BT_INTEGER:
2965     case BT_REAL:
2966       se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
2967                                   arg);
2968       break;
2969
2970     case BT_COMPLEX:
2971       cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
2972       se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
2973       break;
2974
2975     default:
2976       gcc_unreachable ();
2977     }
2978 }
2979
2980
2981 /* Create a complex value from one or two real components.  */
2982
2983 static void
2984 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
2985 {
2986   tree real;
2987   tree imag;
2988   tree type;
2989   tree *args;
2990   unsigned int num_args;
2991
2992   num_args = gfc_intrinsic_argument_list_length (expr);
2993   args = XALLOCAVEC (tree, num_args);
2994
2995   type = gfc_typenode_for_spec (&expr->ts);
2996   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2997   real = convert (TREE_TYPE (type), args[0]);
2998   if (both)
2999     imag = convert (TREE_TYPE (type), args[1]);
3000   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
3001     {
3002       imag = fold_build1_loc (input_location, IMAGPART_EXPR,
3003                               TREE_TYPE (TREE_TYPE (args[0])), args[0]);
3004       imag = convert (TREE_TYPE (type), imag);
3005     }
3006   else
3007     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
3008
3009   se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
3010 }
3011
3012
3013 /* Remainder function MOD(A, P) = A - INT(A / P) * P
3014                       MODULO(A, P) = A - FLOOR (A / P) * P
3015
3016    The obvious algorithms above are numerically instable for large
3017    arguments, hence these intrinsics are instead implemented via calls
3018    to the fmod family of functions.  It is the responsibility of the
3019    user to ensure that the second argument is non-zero.  */
3020
3021 static void
3022 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
3023 {
3024   tree type;
3025   tree tmp;
3026   tree test;
3027   tree test2;
3028   tree fmod;
3029   tree zero;
3030   tree args[2];
3031
3032   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3033
3034   switch (expr->ts.type)
3035     {
3036     case BT_INTEGER:
3037       /* Integer case is easy, we've got a builtin op.  */
3038       type = TREE_TYPE (args[0]);
3039
3040       if (modulo)
3041        se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
3042                                    args[0], args[1]);
3043       else
3044        se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
3045                                    args[0], args[1]);
3046       break;
3047
3048     case BT_REAL:
3049       fmod = NULL_TREE;
3050       /* Check if we have a builtin fmod.  */
3051       fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
3052
3053       /* The builtin should always be available.  */
3054       gcc_assert (fmod != NULL_TREE);
3055
3056       tmp = build_addr (fmod);
3057       se->expr = build_call_array_loc (input_location,
3058                                        TREE_TYPE (TREE_TYPE (fmod)),
3059                                        tmp, 2, args);
3060       if (modulo == 0)
3061         return;
3062
3063       type = TREE_TYPE (args[0]);
3064
3065       args[0] = gfc_evaluate_now (args[0], &se->pre);
3066       args[1] = gfc_evaluate_now (args[1], &se->pre);
3067
3068       /* Definition:
3069          modulo = arg - floor (arg/arg2) * arg2
3070
3071          In order to calculate the result accurately, we use the fmod
3072          function as follows.
3073
3074          res = fmod (arg, arg2);
3075          if (res)
3076            {
3077              if ((arg < 0) xor (arg2 < 0))
3078                res += arg2;
3079            }
3080          else
3081            res = copysign (0., arg2);
3082
3083          => As two nested ternary exprs:
3084
3085          res = res ? (((arg < 0) xor (arg2 < 0)) ? res + arg2 : res)
3086                : copysign (0., arg2);
3087
3088       */
3089
3090       zero = gfc_build_const (type, integer_zero_node);
3091       tmp = gfc_evaluate_now (se->expr, &se->pre);
3092       if (!flag_signed_zeros)
3093         {
3094           test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3095                                   args[0], zero);
3096           test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3097                                    args[1], zero);
3098           test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3099                                    boolean_type_node, test, test2);
3100           test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3101                                   tmp, zero);
3102           test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
3103                                   boolean_type_node, test, test2);
3104           test = gfc_evaluate_now (test, &se->pre);
3105           se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3106                                       fold_build2_loc (input_location,
3107                                                        PLUS_EXPR,
3108                                                        type, tmp, args[1]),
3109                                       tmp);
3110         }
3111       else
3112         {
3113           tree expr1, copysign, cscall;
3114           copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN,
3115                                                       expr->ts.kind);
3116           test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3117                                   args[0], zero);
3118           test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
3119                                    args[1], zero);
3120           test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
3121                                    boolean_type_node, test, test2);
3122           expr1 = fold_build3_loc (input_location, COND_EXPR, type, test2,
3123                                    fold_build2_loc (input_location,
3124                                                     PLUS_EXPR,
3125                                                     type, tmp, args[1]),
3126                                    tmp);
3127           test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
3128                                   tmp, zero);
3129           cscall = build_call_expr_loc (input_location, copysign, 2, zero,
3130                                         args[1]);
3131           se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
3132                                       expr1, cscall);
3133         }
3134       return;
3135
3136     default:
3137       gcc_unreachable ();
3138     }
3139 }
3140
3141 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
3142    DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
3143    where the right shifts are logical (i.e. 0's are shifted in).
3144    Because SHIFT_EXPR's want shifts strictly smaller than the integral
3145    type width, we have to special-case both S == 0 and S == BITSIZE(J):
3146      DSHIFTL(I,J,0) = I
3147      DSHIFTL(I,J,BITSIZE) = J
3148      DSHIFTR(I,J,0) = J
3149      DSHIFTR(I,J,BITSIZE) = I.  */
3150
3151 static void
3152 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
3153 {
3154   tree type, utype, stype, arg1, arg2, shift, res, left, right;
3155   tree args[3], cond, tmp;
3156   int bitsize;
3157
3158   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3159
3160   gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
3161   type = TREE_TYPE (args[0]);
3162   bitsize = TYPE_PRECISION (type);
3163   utype = unsigned_type_for (type);
3164   stype = TREE_TYPE (args[2]);
3165
3166   arg1 = gfc_evaluate_now (args[0], &se->pre);
3167   arg2 = gfc_evaluate_now (args[1], &se->pre);
3168   shift = gfc_evaluate_now (args[2], &se->pre);
3169
3170   /* The generic case.  */
3171   tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
3172                          build_int_cst (stype, bitsize), shift);
3173   left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3174                           arg1, dshiftl ? shift : tmp);
3175
3176   right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
3177                            fold_convert (utype, arg2), dshiftl ? tmp : shift);
3178   right = fold_convert (type, right);
3179
3180   res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
3181
3182   /* Special cases.  */
3183   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
3184                           build_int_cst (stype, 0));
3185   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3186                          dshiftl ? arg1 : arg2, res);
3187
3188   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
3189                           build_int_cst (stype, bitsize));
3190   res = fold_build3_loc (input_location, COND_EXPR, type, cond,
3191                          dshiftl ? arg2 : arg1, res);
3192
3193   se->expr = res;
3194 }
3195
3196
3197 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
3198
3199 static void
3200 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
3201 {
3202   tree val;
3203   tree tmp;
3204   tree type;
3205   tree zero;
3206   tree args[2];
3207
3208   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3209   type = TREE_TYPE (args[0]);
3210
3211   val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
3212   val = gfc_evaluate_now (val, &se->pre);
3213
3214   zero = gfc_build_const (type, integer_zero_node);
3215   tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
3216   se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
3217 }
3218
3219
3220 /* SIGN(A, B) is absolute value of A times sign of B.
3221    The real value versions use library functions to ensure the correct
3222    handling of negative zero.  Integer case implemented as:
3223    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
3224   */
3225
3226 static void
3227 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
3228 {
3229   tree tmp;
3230   tree type;
3231   tree args[2];
3232
3233   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3234   if (expr->ts.type == BT_REAL)
3235     {
3236       tree abs;
3237
3238       tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3239       abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3240
3241       /* We explicitly have to ignore the minus sign. We do so by using
3242          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
3243       if (!flag_sign_zero
3244           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
3245         {
3246           tree cond, zero;
3247           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
3248           cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
3249                                   args[1], zero);
3250           se->expr = fold_build3_loc (input_location, COND_EXPR,
3251                                   TREE_TYPE (args[0]), cond,
3252                                   build_call_expr_loc (input_location, abs, 1,
3253                                                        args[0]),
3254                                   build_call_expr_loc (input_location, tmp, 2,
3255                                                        args[0], args[1]));
3256         }
3257       else
3258         se->expr = build_call_expr_loc (input_location, tmp, 2,
3259                                         args[0], args[1]);
3260       return;
3261     }
3262
3263   /* Having excluded floating point types, we know we are now dealing
3264      with signed integer types.  */
3265   type = TREE_TYPE (args[0]);
3266
3267   /* Args[0] is used multiple times below.  */
3268   args[0] = gfc_evaluate_now (args[0], &se->pre);
3269
3270   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
3271      the signs of A and B are the same, and of all ones if they differ.  */
3272   tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
3273   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
3274                          build_int_cst (type, TYPE_PRECISION (type) - 1));
3275   tmp = gfc_evaluate_now (tmp, &se->pre);
3276
3277   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
3278      is all ones (i.e. -1).  */
3279   se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
3280                               fold_build2_loc (input_location, PLUS_EXPR,
3281                                                type, args[0], tmp), tmp);
3282 }
3283
3284
3285 /* Test for the presence of an optional argument.  */
3286
3287 static void
3288 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
3289 {
3290   gfc_expr *arg;
3291
3292   arg = expr->value.function.actual->expr;
3293   gcc_assert (arg->expr_type == EXPR_VARIABLE);
3294   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
3295   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3296 }
3297
3298
3299 /* Calculate the double precision product of two single precision values.  */
3300
3301 static void
3302 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
3303 {
3304   tree type;
3305   tree args[2];
3306
3307   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3308
3309   /* Convert the args to double precision before multiplying.  */
3310   type = gfc_typenode_for_spec (&expr->ts);
3311   args[0] = convert (type, args[0]);
3312   args[1] = convert (type, args[1]);
3313   se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
3314                               args[1]);
3315 }
3316
3317
3318 /* Return a length one character string containing an ascii character.  */
3319
3320 static void
3321 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
3322 {
3323   tree arg[2];
3324   tree var;
3325   tree type;
3326   unsigned int num_args;
3327
3328   num_args = gfc_intrinsic_argument_list_length (expr);
3329   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
3330
3331   type = gfc_get_char_type (expr->ts.kind);
3332   var = gfc_create_var (type, "char");
3333
3334   arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
3335   gfc_add_modify (&se->pre, var, arg[0]);
3336   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
3337   se->string_length = build_int_cst (gfc_charlen_type_node, 1);
3338 }
3339
3340
3341 static void
3342 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
3343 {
3344   tree var;
3345   tree len;
3346   tree tmp;
3347   tree cond;
3348   tree fndecl;
3349   tree *args;
3350   unsigned int num_args;
3351
3352   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3353   args = XALLOCAVEC (tree, num_args);
3354
3355   var = gfc_create_var (pchar_type_node, "pstr");
3356   len = gfc_create_var (gfc_charlen_type_node, "len");
3357
3358   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3359   args[0] = gfc_build_addr_expr (NULL_TREE, var);
3360   args[1] = gfc_build_addr_expr (NULL_TREE, len);
3361
3362   fndecl = build_addr (gfor_fndecl_ctime);
3363   tmp = build_call_array_loc (input_location,
3364                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
3365                           fndecl, num_args, args);
3366   gfc_add_expr_to_block (&se->pre, tmp);
3367
3368   /* Free the temporary afterwards, if necessary.  */
3369   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3370                           len, build_int_cst (TREE_TYPE (len), 0));
3371   tmp = gfc_call_free (var);
3372   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3373   gfc_add_expr_to_block (&se->post, tmp);
3374
3375   se->expr = var;
3376   se->string_length = len;
3377 }
3378
3379
3380 static void
3381 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
3382 {
3383   tree var;
3384   tree len;
3385   tree tmp;
3386   tree cond;
3387   tree fndecl;
3388   tree *args;
3389   unsigned int num_args;
3390
3391   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3392   args = XALLOCAVEC (tree, num_args);
3393
3394   var = gfc_create_var (pchar_type_node, "pstr");
3395   len = gfc_create_var (gfc_charlen_type_node, "len");
3396
3397   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3398   args[0] = gfc_build_addr_expr (NULL_TREE, var);
3399   args[1] = gfc_build_addr_expr (NULL_TREE, len);
3400
3401   fndecl = build_addr (gfor_fndecl_fdate);
3402   tmp = build_call_array_loc (input_location,
3403                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
3404                           fndecl, num_args, args);
3405   gfc_add_expr_to_block (&se->pre, tmp);
3406
3407   /* Free the temporary afterwards, if necessary.  */
3408   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3409                           len, build_int_cst (TREE_TYPE (len), 0));
3410   tmp = gfc_call_free (var);
3411   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3412   gfc_add_expr_to_block (&se->post, tmp);
3413
3414   se->expr = var;
3415   se->string_length = len;
3416 }
3417
3418
3419 /* Generate a direct call to free() for the FREE subroutine.  */
3420
3421 static tree
3422 conv_intrinsic_free (gfc_code *code)
3423 {
3424   stmtblock_t block;
3425   gfc_se argse;
3426   tree arg, call;
3427
3428   gfc_init_se (&argse, NULL);
3429   gfc_conv_expr (&argse, code->ext.actual->expr);
3430   arg = fold_convert (ptr_type_node, argse.expr);
3431
3432   gfc_init_block (&block);
3433   call = build_call_expr_loc (input_location,
3434                               builtin_decl_explicit (BUILT_IN_FREE), 1, arg);
3435   gfc_add_expr_to_block (&block, call);
3436   return gfc_finish_block (&block);
3437 }
3438
3439
3440 /* Call the SYSTEM_CLOCK library functions, handling the type and kind
3441    conversions.  */
3442
3443 static tree
3444 conv_intrinsic_system_clock (gfc_code *code)
3445 {
3446   stmtblock_t block;
3447   gfc_se count_se, count_rate_se, count_max_se;
3448   tree arg1 = NULL_TREE, arg2 = NULL_TREE, arg3 = NULL_TREE;
3449   tree tmp;
3450   int least;
3451
3452   gfc_expr *count = code->ext.actual->expr;
3453   gfc_expr *count_rate = code->ext.actual->next->expr;
3454   gfc_expr *count_max = code->ext.actual->next->next->expr;
3455
3456   /* Evaluate our arguments.  */
3457   if (count)
3458     {
3459       gfc_init_se (&count_se, NULL);
3460       gfc_conv_expr (&count_se, count);
3461     }
3462
3463   if (count_rate)
3464     {
3465       gfc_init_se (&count_rate_se, NULL);
3466       gfc_conv_expr (&count_rate_se, count_rate);
3467     }
3468
3469   if (count_max)
3470     {
3471       gfc_init_se (&count_max_se, NULL);
3472       gfc_conv_expr (&count_max_se, count_max);
3473     }
3474
3475   /* Find the smallest kind found of the arguments.  */
3476   least = 16;
3477   least = (count && count->ts.kind < least) ? count->ts.kind : least;
3478   least = (count_rate && count_rate->ts.kind < least) ? count_rate->ts.kind
3479                                                       : least;
3480   least = (count_max && count_max->ts.kind < least) ? count_max->ts.kind
3481                                                     : least;
3482
3483   /* Prepare temporary variables.  */
3484
3485   if (count)
3486     {
3487       if (least >= 8)
3488         arg1 = gfc_create_var (gfc_get_int_type (8), "count");
3489       else if (least == 4)
3490         arg1 = gfc_create_var (gfc_get_int_type (4), "count");
3491       else if (count->ts.kind == 1)
3492         arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[0].pedantic_min_int,
3493                                      count->ts.kind);
3494       else
3495         arg1 = gfc_conv_mpz_to_tree (gfc_integer_kinds[1].pedantic_min_int,
3496                                      count->ts.kind);
3497     }
3498
3499   if (count_rate)
3500     {
3501       if (least >= 8)
3502         arg2 = gfc_create_var (gfc_get_int_type (8), "count_rate");
3503       else if (least == 4)
3504         arg2 = gfc_create_var (gfc_get_int_type (4), "count_rate");
3505       else
3506         arg2 = integer_zero_node;
3507     }
3508
3509   if (count_max)
3510     {
3511       if (least >= 8)
3512         arg3 = gfc_create_var (gfc_get_int_type (8), "count_max");
3513       else if (least == 4)
3514         arg3 = gfc_create_var (gfc_get_int_type (4), "count_max");
3515       else
3516         arg3 = integer_zero_node;
3517     }
3518
3519   /* Make the function call.  */
3520   gfc_init_block (&block);
3521
3522 if (least <= 2)
3523   {
3524     if (least == 1)
3525       {
3526         arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3527                : null_pointer_node;
3528         arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3529                : null_pointer_node;
3530         arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3531                : null_pointer_node;
3532       }
3533
3534     if (least == 2)
3535       {
3536         arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3537                : null_pointer_node;
3538         arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3539                : null_pointer_node;
3540         arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3541                : null_pointer_node;
3542       }
3543   }
3544 else
3545   {
3546     if (least == 4)
3547       {
3548         tmp = build_call_expr_loc (input_location,
3549                 gfor_fndecl_system_clock4, 3,
3550                 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3551                        : null_pointer_node,
3552                 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3553                        : null_pointer_node,
3554                 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3555                        : null_pointer_node);
3556         gfc_add_expr_to_block (&block, tmp);
3557       }
3558     /* Handle kind>=8, 10, or 16 arguments */
3559     if (least >= 8)
3560       {
3561         tmp = build_call_expr_loc (input_location,
3562                 gfor_fndecl_system_clock8, 3,
3563                 arg1 ? gfc_build_addr_expr (NULL_TREE, arg1)
3564                        : null_pointer_node,
3565                 arg2 ? gfc_build_addr_expr (NULL_TREE, arg2)
3566                        : null_pointer_node,
3567                 arg3 ? gfc_build_addr_expr (NULL_TREE, arg3)
3568                        : null_pointer_node);
3569         gfc_add_expr_to_block (&block, tmp);
3570       }
3571   }
3572
3573   /* And store values back if needed.  */
3574   if (arg1 && arg1 != count_se.expr)
3575     gfc_add_modify (&block, count_se.expr,
3576                     fold_convert (TREE_TYPE (count_se.expr), arg1));
3577   if (arg2 && arg2 != count_rate_se.expr)
3578     gfc_add_modify (&block, count_rate_se.expr,
3579                     fold_convert (TREE_TYPE (count_rate_se.expr), arg2));
3580   if (arg3 && arg3 != count_max_se.expr)
3581     gfc_add_modify (&block, count_max_se.expr,
3582                     fold_convert (TREE_TYPE (count_max_se.expr), arg3));
3583
3584   return gfc_finish_block (&block);
3585 }
3586
3587
3588 /* Return a character string containing the tty name.  */
3589
3590 static void
3591 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
3592 {
3593   tree var;
3594   tree len;
3595   tree tmp;
3596   tree cond;
3597   tree fndecl;
3598   tree *args;
3599   unsigned int num_args;
3600
3601   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3602   args = XALLOCAVEC (tree, num_args);
3603
3604   var = gfc_create_var (pchar_type_node, "pstr");
3605   len = gfc_create_var (gfc_charlen_type_node, "len");
3606
3607   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3608   args[0] = gfc_build_addr_expr (NULL_TREE, var);
3609   args[1] = gfc_build_addr_expr (NULL_TREE, len);
3610
3611   fndecl = build_addr (gfor_fndecl_ttynam);
3612   tmp = build_call_array_loc (input_location,
3613                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
3614                           fndecl, num_args, args);
3615   gfc_add_expr_to_block (&se->pre, tmp);
3616
3617   /* Free the temporary afterwards, if necessary.  */
3618   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3619                           len, build_int_cst (TREE_TYPE (len), 0));
3620   tmp = gfc_call_free (var);
3621   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3622   gfc_add_expr_to_block (&se->post, tmp);
3623
3624   se->expr = var;
3625   se->string_length = len;
3626 }
3627
3628
3629 /* Get the minimum/maximum value of all the parameters.
3630     minmax (a1, a2, a3, ...)
3631     {
3632       mvar = a1;
3633       if (a2 .op. mvar || isnan (mvar))
3634         mvar = a2;
3635       if (a3 .op. mvar || isnan (mvar))
3636         mvar = a3;
3637       ...
3638       return mvar
3639     }
3640  */
3641
3642 /* TODO: Mismatching types can occur when specific names are used.
3643    These should be handled during resolution.  */
3644 static void
3645 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
3646 {
3647   tree tmp;
3648   tree mvar;
3649   tree val;
3650   tree thencase;
3651   tree *args;
3652   tree type;
3653   gfc_actual_arglist *argexpr;
3654   unsigned int i, nargs;
3655
3656   nargs = gfc_intrinsic_argument_list_length (expr);
3657   args = XALLOCAVEC (tree, nargs);
3658
3659   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
3660   type = gfc_typenode_for_spec (&expr->ts);
3661
3662   argexpr = expr->value.function.actual;
3663   if (TREE_TYPE (args[0]) != type)
3664     args[0] = convert (type, args[0]);
3665   /* Only evaluate the argument once.  */
3666   if (!VAR_P (args[0]) && !TREE_CONSTANT (args[0]))
3667     args[0] = gfc_evaluate_now (args[0], &se->pre);
3668
3669   mvar = gfc_create_var (type, "M");
3670   gfc_add_modify (&se->pre, mvar, args[0]);
3671   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
3672     {
3673       tree cond, isnan;
3674
3675       val = args[i];
3676
3677       /* Handle absent optional arguments by ignoring the comparison.  */
3678       if (argexpr->expr->expr_type == EXPR_VARIABLE
3679           && argexpr->expr->symtree->n.sym->attr.optional
3680           && TREE_CODE (val) == INDIRECT_REF)
3681         cond = fold_build2_loc (input_location,
3682                                 NE_EXPR, boolean_type_node,
3683                                 TREE_OPERAND (val, 0),
3684                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
3685       else
3686       {
3687         cond = NULL_TREE;
3688
3689         /* Only evaluate the argument once.  */
3690         if (!VAR_P (val) && !TREE_CONSTANT (val))
3691           val = gfc_evaluate_now (val, &se->pre);
3692       }
3693
3694       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
3695
3696       tmp = fold_build2_loc (input_location, op, boolean_type_node,
3697                              convert (type, val), mvar);
3698
3699       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
3700          __builtin_isnan might be made dependent on that module being loaded,
3701          to help performance of programs that don't rely on IEEE semantics.  */
3702       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
3703         {
3704           isnan = build_call_expr_loc (input_location,
3705                                        builtin_decl_explicit (BUILT_IN_ISNAN),
3706                                        1, mvar);
3707           tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
3708                                  boolean_type_node, tmp,
3709                                  fold_convert (boolean_type_node, isnan));
3710         }
3711       tmp = build3_v (COND_EXPR, tmp, thencase,
3712                       build_empty_stmt (input_location));
3713
3714       if (cond != NULL_TREE)
3715         tmp = build3_v (COND_EXPR, cond, tmp,
3716                         build_empty_stmt (input_location));
3717
3718       gfc_add_expr_to_block (&se->pre, tmp);
3719       argexpr = argexpr->next;
3720     }
3721   se->expr = mvar;
3722 }
3723
3724
3725 /* Generate library calls for MIN and MAX intrinsics for character
3726    variables.  */
3727 static void
3728 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
3729 {
3730   tree *args;
3731   tree var, len, fndecl, tmp, cond, function;
3732   unsigned int nargs;
3733
3734   nargs = gfc_intrinsic_argument_list_length (expr);
3735   args = XALLOCAVEC (tree, nargs + 4);
3736   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
3737
3738   /* Create the result variables.  */
3739   len = gfc_create_var (gfc_charlen_type_node, "len");
3740   args[0] = gfc_build_addr_expr (NULL_TREE, len);
3741   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3742   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
3743   args[2] = build_int_cst (integer_type_node, op);
3744   args[3] = build_int_cst (integer_type_node, nargs / 2);
3745
3746   if (expr->ts.kind == 1)
3747     function = gfor_fndecl_string_minmax;
3748   else if (expr->ts.kind == 4)
3749     function = gfor_fndecl_string_minmax_char4;
3750   else
3751     gcc_unreachable ();
3752
3753   /* Make the function call.  */
3754   fndecl = build_addr (function);
3755   tmp = build_call_array_loc (input_location,
3756                           TREE_TYPE (TREE_TYPE (function)), fndecl,
3757                           nargs + 4, args);
3758   gfc_add_expr_to_block (&se->pre, tmp);
3759
3760   /* Free the temporary afterwards, if necessary.  */
3761   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
3762                           len, build_int_cst (TREE_TYPE (len), 0));
3763   tmp = gfc_call_free (var);
3764   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
3765   gfc_add_expr_to_block (&se->post, tmp);
3766
3767   se->expr = var;
3768   se->string_length = len;
3769 }
3770
3771
3772 /* Create a symbol node for this intrinsic.  The symbol from the frontend
3773    has the generic name.  */
3774
3775 static gfc_symbol *
3776 gfc_get_symbol_for_expr (gfc_expr * expr, bool ignore_optional)
3777 {
3778   gfc_symbol *sym;
3779
3780   /* TODO: Add symbols for intrinsic function to the global namespace.  */
3781   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
3782   sym = gfc_new_symbol (expr->value.function.name, NULL);
3783
3784   sym->ts = expr->ts;
3785   sym->attr.external = 1;
3786   sym->attr.function = 1;
3787   sym->attr.always_explicit = 1;
3788   sym->attr.proc = PROC_INTRINSIC;
3789   sym->attr.flavor = FL_PROCEDURE;
3790   sym->result = sym;
3791   if (expr->rank > 0)
3792     {
3793       sym->attr.dimension = 1;
3794       sym->as = gfc_get_array_spec ();
3795       sym->as->type = AS_ASSUMED_SHAPE;
3796       sym->as->rank = expr->rank;
3797     }
3798
3799   gfc_copy_formal_args_intr (sym, expr->value.function.isym,
3800                              ignore_optional ? expr->value.function.actual
3801                                              : NULL);
3802
3803   return sym;
3804 }
3805
3806 /* Generate a call to an external intrinsic function.  */
3807 static void
3808 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
3809 {
3810   gfc_symbol *sym;
3811   vec<tree, va_gc> *append_args;
3812
3813   gcc_assert (!se->ss || se->ss->info->expr == expr);
3814
3815   if (se->ss)
3816     gcc_assert (expr->rank > 0);
3817   else
3818     gcc_assert (expr->rank == 0);
3819
3820   sym = gfc_get_symbol_for_expr (expr, se->ignore_optional);
3821
3822   /* Calls to libgfortran_matmul need to be appended special arguments,
3823      to be able to call the BLAS ?gemm functions if required and possible.  */
3824   append_args = NULL;
3825   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
3826       && sym->ts.type != BT_LOGICAL)
3827     {
3828       tree cint = gfc_get_int_type (gfc_c_int_kind);
3829
3830       if (flag_external_blas
3831           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
3832           && (sym->ts.kind == 4 || sym->ts.kind == 8))
3833         {
3834           tree gemm_fndecl;
3835
3836           if (sym->ts.type == BT_REAL)
3837             {
3838               if (sym->ts.kind == 4)
3839                 gemm_fndecl = gfor_fndecl_sgemm;
3840               else
3841                 gemm_fndecl = gfor_fndecl_dgemm;
3842             }
3843           else
3844             {
3845               if (sym->ts.kind == 4)
3846                 gemm_fndecl = gfor_fndecl_cgemm;
3847               else
3848                 gemm_fndecl = gfor_fndecl_zgemm;
3849             }
3850
3851           vec_alloc (append_args, 3);
3852           append_args->quick_push (build_int_cst (cint, 1));
3853           append_args->quick_push (build_int_cst (cint,
3854                                                   flag_blas_matmul_limit));
3855           append_args->quick_push (gfc_build_addr_expr (NULL_TREE,
3856                                                         gemm_fndecl));
3857         }
3858       else
3859         {
3860           vec_alloc (append_args, 3);
3861           append_args->quick_push (build_int_cst (cint, 0));
3862           append_args->quick_push (build_int_cst (cint, 0));
3863           append_args->quick_push (null_pointer_node);
3864         }
3865     }
3866
3867   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3868                           append_args);
3869   gfc_free_symbol (sym);
3870 }
3871
3872 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
3873    Implemented as
3874     any(a)
3875     {
3876       forall (i=...)
3877         if (a[i] != 0)
3878           return 1
3879       end forall
3880       return 0
3881     }
3882     all(a)
3883     {
3884       forall (i=...)
3885         if (a[i] == 0)
3886           return 0
3887       end forall
3888       return 1
3889     }
3890  */
3891 static void
3892 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
3893 {
3894   tree resvar;
3895   stmtblock_t block;
3896   stmtblock_t body;
3897   tree type;
3898   tree tmp;
3899   tree found;
3900   gfc_loopinfo loop;
3901   gfc_actual_arglist *actual;
3902   gfc_ss *arrayss;
3903   gfc_se arrayse;
3904   tree exit_label;
3905
3906   if (se->ss)
3907     {
3908       gfc_conv_intrinsic_funcall (se, expr);
3909       return;
3910     }
3911
3912   actual = expr->value.function.actual;
3913   type = gfc_typenode_for_spec (&expr->ts);
3914   /* Initialize the result.  */
3915   resvar = gfc_create_var (type, "test");
3916   if (op == EQ_EXPR)
3917     tmp = convert (type, boolean_true_node);
3918   else
3919     tmp = convert (type, boolean_false_node);
3920   gfc_add_modify (&se->pre, resvar, tmp);
3921
3922   /* Walk the arguments.  */
3923   arrayss = gfc_walk_expr (actual->expr);
3924   gcc_assert (arrayss != gfc_ss_terminator);
3925
3926   /* Initialize the scalarizer.  */
3927   gfc_init_loopinfo (&loop);
3928   exit_label = gfc_build_label_decl (NULL_TREE);
3929   TREE_USED (exit_label) = 1;
3930   gfc_add_ss_to_loop (&loop, arrayss);
3931
3932   /* Initialize the loop.  */
3933   gfc_conv_ss_startstride (&loop);
3934   gfc_conv_loop_setup (&loop, &expr->where);
3935
3936   gfc_mark_ss_chain_used (arrayss, 1);
3937   /* Generate the loop body.  */
3938   gfc_start_scalarized_body (&loop, &body);
3939
3940   /* If the condition matches then set the return value.  */
3941   gfc_start_block (&block);
3942   if (op == EQ_EXPR)
3943     tmp = convert (type, boolean_false_node);
3944   else
3945     tmp = convert (type, boolean_true_node);
3946   gfc_add_modify (&block, resvar, tmp);
3947
3948   /* And break out of the loop.  */
3949   tmp = build1_v (GOTO_EXPR, exit_label);
3950   gfc_add_expr_to_block (&block, tmp);
3951
3952   found = gfc_finish_block (&block);
3953
3954   /* Check this element.  */
3955   gfc_init_se (&arrayse, NULL);
3956   gfc_copy_loopinfo_to_se (&arrayse, &loop);
3957   arrayse.ss = arrayss;
3958   gfc_conv_expr_val (&arrayse, actual->expr);
3959
3960   gfc_add_block_to_block (&body, &arrayse.pre);
3961   tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
3962                          build_int_cst (TREE_TYPE (arrayse.expr), 0));
3963   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
3964   gfc_add_expr_to_block (&body, tmp);
3965   gfc_add_block_to_block (&body, &arrayse.post);
3966
3967   gfc_trans_scalarizing_loops (&loop, &body);
3968
3969   /* Add the exit label.  */
3970   tmp = build1_v (LABEL_EXPR, exit_label);
3971   gfc_add_expr_to_block (&loop.pre, tmp);
3972
3973   gfc_add_block_to_block (&se->pre, &loop.pre);
3974   gfc_add_block_to_block (&se->pre, &loop.post);
3975   gfc_cleanup_loop (&loop);
3976
3977   se->expr = resvar;
3978 }
3979
3980 /* COUNT(A) = Number of true elements in A.  */
3981 static void
3982 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
3983 {
3984   tree resvar;
3985   tree type;
3986   stmtblock_t body;
3987   tree tmp;
3988   gfc_loopinfo loop;
3989   gfc_actual_arglist *actual;
3990   gfc_ss *arrayss;
3991   gfc_se arrayse;
3992
3993   if (se->ss)
3994     {
3995       gfc_conv_intrinsic_funcall (se, expr);
3996       return;
3997     }
3998
3999   actual = expr->value.function.actual;
4000
4001   type = gfc_typenode_for_spec (&expr->ts);
4002   /* Initialize the result.  */
4003   resvar = gfc_create_var (type, "count");
4004   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
4005
4006   /* Walk the arguments.  */
4007   arrayss = gfc_walk_expr (actual->expr);
4008   gcc_assert (arrayss != gfc_ss_terminator);
4009
4010   /* Initialize the scalarizer.  */
4011   gfc_init_loopinfo (&loop);
4012   gfc_add_ss_to_loop (&loop, arrayss);
4013
4014   /* Initialize the loop.  */
4015   gfc_conv_ss_startstride (&loop);
4016   gfc_conv_loop_setup (&loop, &expr->where);
4017
4018   gfc_mark_ss_chain_used (arrayss, 1);
4019   /* Generate the loop body.  */
4020   gfc_start_scalarized_body (&loop, &body);
4021
4022   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
4023                          resvar, build_int_cst (TREE_TYPE (resvar), 1));
4024   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
4025
4026   gfc_init_se (&arrayse, NULL);
4027   gfc_copy_loopinfo_to_se (&arrayse, &loop);
4028   arrayse.ss = arrayss;
4029   gfc_conv_expr_val (&arrayse, actual->expr);
4030   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
4031                   build_empty_stmt (input_location));
4032
4033   gfc_add_block_to_block (&body, &arrayse.pre);
4034   gfc_add_expr_to_block (&body, tmp);
4035   gfc_add_block_to_block (&body, &arrayse.post);
4036
4037   gfc_trans_scalarizing_loops (&loop, &body);
4038
4039   gfc_add_block_to_block (&se->pre, &loop.pre);
4040   gfc_add_block_to_block (&se->pre, &loop.post);
4041   gfc_cleanup_loop (&loop);
4042
4043   se->expr = resvar;
4044 }
4045
4046
4047 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
4048    struct and return the corresponding loopinfo.  */
4049
4050 static gfc_loopinfo *
4051 enter_nested_loop (gfc_se *se)
4052 {
4053   se->ss = se->ss->nested_ss;
4054   gcc_assert (se->ss == se->ss->loop->ss);
4055
4056   return se->ss->loop;
4057 }
4058
4059
4060 /* Inline implementation of the sum and product intrinsics.  */
4061 static void
4062 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
4063                           bool norm2)
4064 {
4065   tree resvar;
4066   tree scale = NULL_TREE;
4067   tree type;
4068   stmtblock_t body;
4069   stmtblock_t block;
4070   tree tmp;
4071   gfc_loopinfo loop, *ploop;
4072   gfc_actual_arglist *arg_array, *arg_mask;
4073   gfc_ss *arrayss = NULL;
4074   gfc_ss *maskss = NULL;
4075   gfc_se arrayse;
4076   gfc_se maskse;
4077   gfc_se *parent_se;
4078   gfc_expr *arrayexpr;
4079   gfc_expr *maskexpr;
4080
4081   if (expr->rank > 0)
4082     {
4083       gcc_assert (gfc_inline_intrinsic_function_p (expr));
4084       parent_se = se;
4085     }
4086   else
4087     parent_se = NULL;
4088
4089   type = gfc_typenode_for_spec (&expr->ts);
4090   /* Initialize the result.  */
4091   resvar = gfc_create_var (type, "val");
4092   if (norm2)
4093     {
4094       /* result = 0.0;
4095          scale = 1.0.  */
4096       scale = gfc_create_var (type, "scale");
4097       gfc_add_modify (&se->pre, scale,
4098                       gfc_build_const (type, integer_one_node));
4099       tmp = gfc_build_const (type, integer_zero_node);
4100     }
4101   else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
4102     tmp = gfc_build_const (type, integer_zero_node);
4103   else if (op == NE_EXPR)
4104     /* PARITY.  */
4105     tmp = convert (type, boolean_false_node);
4106   else if (op == BIT_AND_EXPR)
4107     tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
4108                                                   type, integer_one_node));
4109   else
4110     tmp = gfc_build_const (type, integer_one_node);
4111
4112   gfc_add_modify (&se->pre, resvar, tmp);
4113
4114   arg_array = expr->value.function.actual;
4115
4116   arrayexpr = arg_array->expr;
4117
4118   if (op == NE_EXPR || norm2)
4119     /* PARITY and NORM2.  */
4120     maskexpr = NULL;
4121   else
4122     {
4123       arg_mask  = arg_array->next->next;
4124       gcc_assert (arg_mask != NULL);
4125       maskexpr = arg_mask->expr;
4126     }
4127
4128   if (expr->rank == 0)
4129     {
4130       /* Walk the arguments.  */
4131       arrayss = gfc_walk_expr (arrayexpr);
4132       gcc_assert (arrayss != gfc_ss_terminator);
4133
4134       if (maskexpr && maskexpr->rank > 0)
4135         {
4136           maskss = gfc_walk_expr (maskexpr);
4137           gcc_assert (maskss != gfc_ss_terminator);
4138         }
4139       else
4140         maskss = NULL;
4141
4142       /* Initialize the scalarizer.  */
4143       gfc_init_loopinfo (&loop);
4144       gfc_add_ss_to_loop (&loop, arrayss);
4145       if (maskexpr && maskexpr->rank > 0)
4146         gfc_add_ss_to_loop (&loop, maskss);
4147
4148       /* Initialize the loop.  */
4149       gfc_conv_ss_startstride (&loop);
4150       gfc_conv_loop_setup (&loop, &expr->where);
4151
4152       gfc_mark_ss_chain_used (arrayss, 1);
4153       if (maskexpr && maskexpr->rank > 0)
4154         gfc_mark_ss_chain_used (maskss, 1);
4155
4156       ploop = &loop;
4157     }
4158   else
4159     /* All the work has been done in the parent loops.  */
4160     ploop = enter_nested_loop (se);
4161
4162   gcc_assert (ploop);
4163
4164   /* Generate the loop body.  */
4165   gfc_start_scalarized_body (ploop, &body);
4166
4167   /* If we have a mask, only add this element if the mask is set.  */
4168   if (maskexpr && maskexpr->rank > 0)
4169     {
4170       gfc_init_se (&maskse, parent_se);
4171       gfc_copy_loopinfo_to_se (&maskse, ploop);
4172       if (expr->rank == 0)
4173         maskse.ss = maskss;
4174       gfc_conv_expr_val (&maskse, maskexpr);
4175       gfc_add_block_to_block (&body, &maskse.pre);
4176
4177       gfc_start_block (&block);
4178     }
4179   else
4180     gfc_init_block (&block);
4181
4182   /* Do the actual summation/product.  */
4183   gfc_init_se (&arrayse, parent_se);
4184   gfc_copy_loopinfo_to_se (&arrayse, ploop);
4185   if (expr->rank == 0)
4186     arrayse.ss = arrayss;
4187   gfc_conv_expr_val (&arrayse, arrayexpr);
4188   gfc_add_block_to_block (&block, &arrayse.pre);
4189
4190   if (norm2)
4191     {
4192       /* if (x (i) != 0.0)
4193            {
4194              absX = abs(x(i))
4195              if (absX > scale)
4196                {
4197                  val = scale/absX;
4198                  result = 1.0 + result * val * val;
4199                  scale = absX;
4200                }
4201              else
4202                {
4203                  val = absX/scale;
4204                  result += val * val;
4205                }
4206            }  */
4207       tree res1, res2, cond, absX, val;
4208       stmtblock_t ifblock1, ifblock2, ifblock3;
4209
4210       gfc_init_block (&ifblock1);
4211
4212       absX = gfc_create_var (type, "absX");
4213       gfc_add_modify (&ifblock1, absX,
4214                       fold_build1_loc (input_location, ABS_EXPR, type,
4215                                        arrayse.expr));
4216       val = gfc_create_var (type, "val");
4217       gfc_add_expr_to_block (&ifblock1, val);
4218
4219       gfc_init_block (&ifblock2);
4220       gfc_add_modify (&ifblock2, val,
4221                       fold_build2_loc (input_location, RDIV_EXPR, type, scale,
4222                                        absX));
4223       res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4224       res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
4225       res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
4226                               gfc_build_const (type, integer_one_node));
4227       gfc_add_modify (&ifblock2, resvar, res1);
4228       gfc_add_modify (&ifblock2, scale, absX);
4229       res1 = gfc_finish_block (&ifblock2);
4230
4231       gfc_init_block (&ifblock3);
4232       gfc_add_modify (&ifblock3, val,
4233                       fold_build2_loc (input_location, RDIV_EXPR, type, absX,
4234                                        scale));
4235       res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
4236       res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
4237       gfc_add_modify (&ifblock3, resvar, res2);
4238       res2 = gfc_finish_block (&ifblock3);
4239
4240       cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
4241                               absX, scale);
4242       tmp = build3_v (COND_EXPR, cond, res1, res2);
4243       gfc_add_expr_to_block (&ifblock1, tmp);
4244       tmp = gfc_finish_block (&ifblock1);
4245
4246       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4247                               arrayse.expr,
4248                               gfc_build_const (type, integer_zero_node));
4249
4250       tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4251       gfc_add_expr_to_block (&block, tmp);
4252     }
4253   else
4254     {
4255       tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
4256       gfc_add_modify (&block, resvar, tmp);
4257     }
4258
4259   gfc_add_block_to_block (&block, &arrayse.post);
4260
4261   if (maskexpr && maskexpr->rank > 0)
4262     {
4263       /* We enclose the above in if (mask) {...} .  */
4264
4265       tmp = gfc_finish_block (&block);
4266       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4267                       build_empty_stmt (input_location));
4268     }
4269   else
4270     tmp = gfc_finish_block (&block);
4271   gfc_add_expr_to_block (&body, tmp);
4272
4273   gfc_trans_scalarizing_loops (ploop, &body);
4274
4275   /* For a scalar mask, enclose the loop in an if statement.  */
4276   if (maskexpr && maskexpr->rank == 0)
4277     {
4278       gfc_init_block (&block);
4279       gfc_add_block_to_block (&block, &ploop->pre);
4280       gfc_add_block_to_block (&block, &ploop->post);
4281       tmp = gfc_finish_block (&block);
4282
4283       if (expr->rank > 0)
4284         {
4285           tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
4286                           build_empty_stmt (input_location));
4287           gfc_advance_se_ss_chain (se);
4288         }
4289       else
4290         {
4291           gcc_assert (expr->rank == 0);
4292           gfc_init_se (&maskse, NULL);
4293           gfc_conv_expr_val (&maskse, maskexpr);
4294           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4295                           build_empty_stmt (input_location));
4296         }
4297
4298       gfc_add_expr_to_block (&block, tmp);
4299       gfc_add_block_to_block (&se->pre, &block);
4300       gcc_assert (se->post.head == NULL);
4301     }
4302   else
4303     {
4304       gfc_add_block_to_block (&se->pre, &ploop->pre);
4305       gfc_add_block_to_block (&se->pre, &ploop->post);
4306     }
4307
4308   if (expr->rank == 0)
4309     gfc_cleanup_loop (ploop);
4310
4311   if (norm2)
4312     {
4313       /* result = scale * sqrt(result).  */
4314       tree sqrt;
4315       sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
4316       resvar = build_call_expr_loc (input_location,
4317                                     sqrt, 1, resvar);
4318       resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
4319     }
4320
4321   se->expr = resvar;
4322 }
4323
4324
4325 /* Inline implementation of the dot_product intrinsic. This function
4326    is based on gfc_conv_intrinsic_arith (the previous function).  */
4327 static void
4328 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
4329 {
4330   tree resvar;
4331   tree type;
4332   stmtblock_t body;
4333   stmtblock_t block;
4334   tree tmp;
4335   gfc_loopinfo loop;
4336   gfc_actual_arglist *actual;
4337   gfc_ss *arrayss1, *arrayss2;
4338   gfc_se arrayse1, arrayse2;
4339   gfc_expr *arrayexpr1, *arrayexpr2;
4340
4341   type = gfc_typenode_for_spec (&expr->ts);
4342
4343   /* Initialize the result.  */
4344   resvar = gfc_create_var (type, "val");
4345   if (expr->ts.type == BT_LOGICAL)
4346     tmp = build_int_cst (type, 0);
4347   else
4348     tmp = gfc_build_const (type, integer_zero_node);
4349
4350   gfc_add_modify (&se->pre, resvar, tmp);
4351
4352   /* Walk argument #1.  */
4353   actual = expr->value.function.actual;
4354   arrayexpr1 = actual->expr;
4355   arrayss1 = gfc_walk_expr (arrayexpr1);
4356   gcc_assert (arrayss1 != gfc_ss_terminator);
4357
4358   /* Walk argument #2.  */
4359   actual = actual->next;
4360   arrayexpr2 = actual->expr;
4361   arrayss2 = gfc_walk_expr (arrayexpr2);
4362   gcc_assert (arrayss2 != gfc_ss_terminator);
4363
4364   /* Initialize the scalarizer.  */
4365   gfc_init_loopinfo (&loop);
4366   gfc_add_ss_to_loop (&loop, arrayss1);
4367   gfc_add_ss_to_loop (&loop, arrayss2);
4368
4369   /* Initialize the loop.  */
4370   gfc_conv_ss_startstride (&loop);
4371   gfc_conv_loop_setup (&loop, &expr->where);
4372
4373   gfc_mark_ss_chain_used (arrayss1, 1);
4374   gfc_mark_ss_chain_used (arrayss2, 1);
4375
4376   /* Generate the loop body.  */
4377   gfc_start_scalarized_body (&loop, &body);
4378   gfc_init_block (&block);
4379
4380   /* Make the tree expression for [conjg(]array1[)].  */
4381   gfc_init_se (&arrayse1, NULL);
4382   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
4383   arrayse1.ss = arrayss1;
4384   gfc_conv_expr_val (&arrayse1, arrayexpr1);
4385   if (expr->ts.type == BT_COMPLEX)
4386     arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
4387                                      arrayse1.expr);
4388   gfc_add_block_to_block (&block, &arrayse1.pre);
4389
4390   /* Make the tree expression for array2.  */
4391   gfc_init_se (&arrayse2, NULL);
4392   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
4393   arrayse2.ss = arrayss2;
4394   gfc_conv_expr_val (&arrayse2, arrayexpr2);
4395   gfc_add_block_to_block (&block, &arrayse2.pre);
4396
4397   /* Do the actual product and sum.  */
4398   if (expr->ts.type == BT_LOGICAL)
4399     {
4400       tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
4401                              arrayse1.expr, arrayse2.expr);
4402       tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
4403     }
4404   else
4405     {
4406       tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
4407                              arrayse2.expr);
4408       tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
4409     }
4410   gfc_add_modify (&block, resvar, tmp);
4411
4412   /* Finish up the loop block and the loop.  */
4413   tmp = gfc_finish_block (&block);
4414   gfc_add_expr_to_block (&body, tmp);
4415
4416   gfc_trans_scalarizing_loops (&loop, &body);
4417   gfc_add_block_to_block (&se->pre, &loop.pre);
4418   gfc_add_block_to_block (&se->pre, &loop.post);
4419   gfc_cleanup_loop (&loop);
4420
4421   se->expr = resvar;
4422 }
4423
4424
4425 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
4426    we need to handle.  For performance reasons we sometimes create two
4427    loops instead of one, where the second one is much simpler.
4428    Examples for minloc intrinsic:
4429    1) Result is an array, a call is generated
4430    2) Array mask is used and NaNs need to be supported:
4431       limit = Infinity;
4432       pos = 0;
4433       S = from;
4434       while (S <= to) {
4435         if (mask[S]) {
4436           if (pos == 0) pos = S + (1 - from);
4437           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4438         }
4439         S++;
4440       }
4441       goto lab2;
4442       lab1:;
4443       while (S <= to) {
4444         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4445         S++;
4446       }
4447       lab2:;
4448    3) NaNs need to be supported, but it is known at compile time or cheaply
4449       at runtime whether array is nonempty or not:
4450       limit = Infinity;
4451       pos = 0;
4452       S = from;
4453       while (S <= to) {
4454         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4455         S++;
4456       }
4457       if (from <= to) pos = 1;
4458       goto lab2;
4459       lab1:;
4460       while (S <= to) {
4461         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4462         S++;
4463       }
4464       lab2:;
4465    4) NaNs aren't supported, array mask is used:
4466       limit = infinities_supported ? Infinity : huge (limit);
4467       pos = 0;
4468       S = from;
4469       while (S <= to) {
4470         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
4471         S++;
4472       }
4473       goto lab2;
4474       lab1:;
4475       while (S <= to) {
4476         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4477         S++;
4478       }
4479       lab2:;
4480    5) Same without array mask:
4481       limit = infinities_supported ? Infinity : huge (limit);
4482       pos = (from <= to) ? 1 : 0;
4483       S = from;
4484       while (S <= to) {
4485         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
4486         S++;
4487       }
4488    For 3) and 5), if mask is scalar, this all goes into a conditional,
4489    setting pos = 0; in the else branch.  */
4490
4491 static void
4492 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
4493 {
4494   stmtblock_t body;
4495   stmtblock_t block;
4496   stmtblock_t ifblock;
4497   stmtblock_t elseblock;
4498   tree limit;
4499   tree type;
4500   tree tmp;
4501   tree cond;
4502   tree elsetmp;
4503   tree ifbody;
4504   tree offset;
4505   tree nonempty;
4506   tree lab1, lab2;
4507   gfc_loopinfo loop;
4508   gfc_actual_arglist *actual;
4509   gfc_ss *arrayss;
4510   gfc_ss *maskss;
4511   gfc_se arrayse;
4512   gfc_se maskse;
4513   gfc_expr *arrayexpr;
4514   gfc_expr *maskexpr;
4515   tree pos;
4516   int n;
4517
4518   if (se->ss)
4519     {
4520       gfc_conv_intrinsic_funcall (se, expr);
4521       return;
4522     }
4523
4524   /* Initialize the result.  */
4525   pos = gfc_create_var (gfc_array_index_type, "pos");
4526   offset = gfc_create_var (gfc_array_index_type, "offset");
4527   type = gfc_typenode_for_spec (&expr->ts);
4528
4529   /* Walk the arguments.  */
4530   actual = expr->value.function.actual;
4531   arrayexpr = actual->expr;
4532   arrayss = gfc_walk_expr (arrayexpr);
4533   gcc_assert (arrayss != gfc_ss_terminator);
4534
4535   actual = actual->next->next;
4536   gcc_assert (actual);
4537   maskexpr = actual->expr;
4538   nonempty = NULL;
4539   if (maskexpr && maskexpr->rank != 0)
4540     {
4541       maskss = gfc_walk_expr (maskexpr);
4542       gcc_assert (maskss != gfc_ss_terminator);
4543     }
4544   else
4545     {
4546       mpz_t asize;
4547       if (gfc_array_size (arrayexpr, &asize))
4548         {
4549           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
4550           mpz_clear (asize);
4551           nonempty = fold_build2_loc (input_location, GT_EXPR,
4552                                       boolean_type_node, nonempty,
4553                                       gfc_index_zero_node);
4554         }
4555       maskss = NULL;
4556     }
4557
4558   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
4559   switch (arrayexpr->ts.type)
4560     {
4561     case BT_REAL:
4562       tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
4563       break;
4564
4565     case BT_INTEGER:
4566       n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
4567       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
4568                                   arrayexpr->ts.kind);
4569       break;
4570
4571     default:
4572       gcc_unreachable ();
4573     }
4574
4575   /* We start with the most negative possible value for MAXLOC, and the most
4576      positive possible value for MINLOC. The most negative possible value is
4577      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
4578      possible value is HUGE in both cases.  */
4579   if (op == GT_EXPR)
4580     tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
4581   if (op == GT_EXPR && arrayexpr->ts.type == BT_INTEGER)
4582     tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
4583                            build_int_cst (TREE_TYPE (tmp), 1));
4584
4585   gfc_add_modify (&se->pre, limit, tmp);
4586
4587   /* Initialize the scalarizer.  */
4588   gfc_init_loopinfo (&loop);
4589   gfc_add_ss_to_loop (&loop, arrayss);
4590   if (maskss)
4591     gfc_add_ss_to_loop (&loop, maskss);
4592
4593   /* Initialize the loop.  */
4594   gfc_conv_ss_startstride (&loop);
4595
4596   /* The code generated can have more than one loop in sequence (see the
4597      comment at the function header).  This doesn't work well with the
4598      scalarizer, which changes arrays' offset when the scalarization loops
4599      are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}loc
4600      are  currently inlined in the scalar case only (for which loop is of rank
4601      one).  As there is no dependency to care about in that case, there is no
4602      temporary, so that we can use the scalarizer temporary code to handle
4603      multiple loops.  Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
4604      with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
4605      to restore offset.
4606      TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
4607      should eventually go away.  We could either create two loops properly,
4608      or find another way to save/restore the array offsets between the two
4609      loops (without conflicting with temporary management), or use a single
4610      loop minmaxloc implementation.  See PR 31067.  */
4611   loop.temp_dim = loop.dimen;
4612   gfc_conv_loop_setup (&loop, &expr->where);
4613
4614   gcc_assert (loop.dimen == 1);
4615   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
4616     nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
4617                                 loop.from[0], loop.to[0]);
4618
4619   lab1 = NULL;
4620   lab2 = NULL;
4621   /* Initialize the position to zero, following Fortran 2003.  We are free
4622      to do this because Fortran 95 allows the result of an entirely false
4623      mask to be processor dependent.  If we know at compile time the array
4624      is non-empty and no MASK is used, we can initialize to 1 to simplify
4625      the inner loop.  */
4626   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
4627     gfc_add_modify (&loop.pre, pos,
4628                     fold_build3_loc (input_location, COND_EXPR,
4629                                      gfc_array_index_type,
4630                                      nonempty, gfc_index_one_node,
4631                                      gfc_index_zero_node));
4632   else
4633     {
4634       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
4635       lab1 = gfc_build_label_decl (NULL_TREE);
4636       TREE_USED (lab1) = 1;
4637       lab2 = gfc_build_label_decl (NULL_TREE);
4638       TREE_USED (lab2) = 1;
4639     }
4640
4641   /* An offset must be added to the loop
4642      counter to obtain the required position.  */
4643   gcc_assert (loop.from[0]);
4644
4645   tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
4646                          gfc_index_one_node, loop.from[0]);
4647   gfc_add_modify (&loop.pre, offset, tmp);
4648
4649   gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
4650   if (maskss)
4651     gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
4652   /* Generate the loop body.  */
4653   gfc_start_scalarized_body (&loop, &body);
4654
4655   /* If we have a mask, only check this element if the mask is set.  */
4656   if (maskss)
4657     {
4658       gfc_init_se (&maskse, NULL);
4659       gfc_copy_loopinfo_to_se (&maskse, &loop);
4660       maskse.ss = maskss;
4661       gfc_conv_expr_val (&maskse, maskexpr);
4662       gfc_add_block_to_block (&body, &maskse.pre);
4663
4664       gfc_start_block (&block);
4665     }
4666   else
4667     gfc_init_block (&block);
4668
4669   /* Compare with the current limit.  */
4670   gfc_init_se (&arrayse, NULL);
4671   gfc_copy_loopinfo_to_se (&arrayse, &loop);
4672   arrayse.ss = arrayss;
4673   gfc_conv_expr_val (&arrayse, arrayexpr);
4674   gfc_add_block_to_block (&block, &arrayse.pre);
4675
4676   /* We do the following if this is a more extreme value.  */
4677   gfc_start_block (&ifblock);
4678
4679   /* Assign the value to the limit...  */
4680   gfc_add_modify (&ifblock, limit, arrayse.expr);
4681
4682   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
4683     {
4684       stmtblock_t ifblock2;
4685       tree ifbody2;
4686
4687       gfc_start_block (&ifblock2);
4688       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4689                              loop.loopvar[0], offset);
4690       gfc_add_modify (&ifblock2, pos, tmp);
4691       ifbody2 = gfc_finish_block (&ifblock2);
4692       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
4693                               gfc_index_zero_node);
4694       tmp = build3_v (COND_EXPR, cond, ifbody2,
4695                       build_empty_stmt (input_location));
4696       gfc_add_expr_to_block (&block, tmp);
4697     }
4698
4699   tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4700                          loop.loopvar[0], offset);
4701   gfc_add_modify (&ifblock, pos, tmp);
4702
4703   if (lab1)
4704     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
4705
4706   ifbody = gfc_finish_block (&ifblock);
4707
4708   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
4709     {
4710       if (lab1)
4711         cond = fold_build2_loc (input_location,
4712                                 op == GT_EXPR ? GE_EXPR : LE_EXPR,
4713                                 boolean_type_node, arrayse.expr, limit);
4714       else
4715         cond = fold_build2_loc (input_location, op, boolean_type_node,
4716                                 arrayse.expr, limit);
4717
4718       ifbody = build3_v (COND_EXPR, cond, ifbody,
4719                          build_empty_stmt (input_location));
4720     }
4721   gfc_add_expr_to_block (&block, ifbody);
4722
4723   if (maskss)
4724     {
4725       /* We enclose the above in if (mask) {...}.  */
4726       tmp = gfc_finish_block (&block);
4727
4728       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4729                       build_empty_stmt (input_location));
4730     }
4731   else
4732     tmp = gfc_finish_block (&block);
4733   gfc_add_expr_to_block (&body, tmp);
4734
4735   if (lab1)
4736     {
4737       gfc_trans_scalarized_loop_boundary (&loop, &body);
4738
4739       if (HONOR_NANS (DECL_MODE (limit)))
4740         {
4741           if (nonempty != NULL)
4742             {
4743               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
4744               tmp = build3_v (COND_EXPR, nonempty, ifbody,
4745                               build_empty_stmt (input_location));
4746               gfc_add_expr_to_block (&loop.code[0], tmp);
4747             }
4748         }
4749
4750       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
4751       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
4752
4753       /* If we have a mask, only check this element if the mask is set.  */
4754       if (maskss)
4755         {
4756           gfc_init_se (&maskse, NULL);
4757           gfc_copy_loopinfo_to_se (&maskse, &loop);
4758           maskse.ss = maskss;
4759           gfc_conv_expr_val (&maskse, maskexpr);
4760           gfc_add_block_to_block (&body, &maskse.pre);
4761
4762           gfc_start_block (&block);
4763         }
4764       else
4765         gfc_init_block (&block);
4766
4767       /* Compare with the current limit.  */
4768       gfc_init_se (&arrayse, NULL);
4769       gfc_copy_loopinfo_to_se (&arrayse, &loop);
4770       arrayse.ss = arrayss;
4771       gfc_conv_expr_val (&arrayse, arrayexpr);
4772       gfc_add_block_to_block (&block, &arrayse.pre);
4773
4774       /* We do the following if this is a more extreme value.  */
4775       gfc_start_block (&ifblock);
4776
4777       /* Assign the value to the limit...  */
4778       gfc_add_modify (&ifblock, limit, arrayse.expr);
4779
4780       tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
4781                              loop.loopvar[0], offset);
4782       gfc_add_modify (&ifblock, pos, tmp);
4783
4784       ifbody = gfc_finish_block (&ifblock);
4785
4786       cond = fold_build2_loc (input_location, op, boolean_type_node,
4787                               arrayse.expr, limit);
4788
4789       tmp = build3_v (COND_EXPR, cond, ifbody,
4790                       build_empty_stmt (input_location));
4791       gfc_add_expr_to_block (&block, tmp);
4792
4793       if (maskss)
4794         {
4795           /* We enclose the above in if (mask) {...}.  */
4796           tmp = gfc_finish_block (&block);
4797
4798           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
4799                           build_empty_stmt (input_location));
4800         }
4801       else
4802         tmp = gfc_finish_block (&block);
4803       gfc_add_expr_to_block (&body, tmp);
4804       /* Avoid initializing loopvar[0] again, it should be left where
4805          it finished by the first loop.  */
4806       loop.from[0] = loop.loopvar[0];
4807     }
4808
4809   gfc_trans_scalarizing_loops (&loop, &body);
4810
4811   if (lab2)
4812     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
4813
4814   /* For a scalar mask, enclose the loop in an if statement.  */
4815   if (maskexpr && maskss == NULL)
4816     {
4817       gfc_init_se (&maskse, NULL);
4818       gfc_conv_expr_val (&maskse, maskexpr);
4819       gfc_init_block (&block);
4820       gfc_add_block_to_block (&block, &loop.pre);
4821       gfc_add_block_to_block (&block, &loop.post);
4822       tmp = gfc_finish_block (&block);
4823
4824       /* For the else part of the scalar mask, just initialize
4825          the pos variable the same way as above.  */
4826
4827       gfc_init_block (&elseblock);
4828       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
4829       elsetmp = gfc_finish_block (&elseblock);
4830
4831       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
4832       gfc_add_expr_to_block (&block, tmp);
4833       gfc_add_block_to_block (&se->pre, &block);
4834     }
4835   else
4836     {
4837       gfc_add_block_to_block (&se->pre, &loop.pre);
4838       gfc_add_block_to_block (&se->pre, &loop.post);
4839     }
4840   gfc_cleanup_loop (&loop);
4841
4842   se->expr = convert (type, pos);
4843 }
4844
4845 /* Emit code for minval or maxval intrinsic.  There are many different cases
4846    we need to handle.  For performance reasons we sometimes create two
4847    loops instead of one, where the second one is much simpler.
4848    Examples for minval intrinsic:
4849    1) Result is an array, a call is generated
4850    2) Array mask is used and NaNs need to be supported, rank 1:
4851       limit = Infinity;
4852       nonempty = false;
4853       S = from;
4854       while (S <= to) {
4855         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
4856         S++;
4857       }
4858       limit = nonempty ? NaN : huge (limit);
4859       lab:
4860       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
4861    3) NaNs need to be supported, but it is known at compile time or cheaply
4862       at runtime whether array is nonempty or not, rank 1:
4863       limit = Infinity;
4864       S = from;
4865       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
4866       limit = (from <= to) ? NaN : huge (limit);
4867       lab:
4868       while (S <= to) { limit = min (a[S], limit); S++; }
4869    4) Array mask is used and NaNs need to be supported, rank > 1:
4870       limit = Infinity;
4871       nonempty = false;
4872       fast = false;
4873       S1 = from1;
4874       while (S1 <= to1) {
4875         S2 = from2;
4876         while (S2 <= to2) {
4877           if (mask[S1][S2]) {
4878             if (fast) limit = min (a[S1][S2], limit);
4879             else {
4880               nonempty = true;
4881               if (a[S1][S2] <= limit) {
4882                 limit = a[S1][S2];
4883                 fast = true;
4884               }
4885             }
4886           }
4887           S2++;
4888         }
4889         S1++;
4890       }
4891       if (!fast)
4892         limit = nonempty ? NaN : huge (limit);
4893    5) NaNs need to be supported, but it is known at compile time or cheaply
4894       at runtime whether array is nonempty or not, rank > 1:
4895       limit = Infinity;
4896       fast = false;
4897       S1 = from1;
4898       while (S1 <= to1) {
4899         S2 = from2;
4900         while (S2 <= to2) {
4901           if (fast) limit = min (a[S1][S2], limit);
4902           else {
4903             if (a[S1][S2] <= limit) {
4904               limit = a[S1][S2];
4905               fast = true;
4906             }
4907           }
4908           S2++;
4909         }
4910         S1++;
4911       }
4912       if (!fast)
4913         limit = (nonempty_array) ? NaN : huge (limit);
4914    6) NaNs aren't supported, but infinities are.  Array mask is used:
4915       limit = Infinity;
4916       nonempty = false;
4917       S = from;
4918       while (S <= to) {
4919         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
4920         S++;
4921       }
4922       limit = nonempty ? limit : huge (limit);
4923    7) Same without array mask:
4924       limit = Infinity;
4925       S = from;
4926       while (S <= to) { limit = min (a[S], limit); S++; }
4927       limit = (from <= to) ? limit : huge (limit);
4928    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
4929       limit = huge (limit);
4930       S = from;
4931       while (S <= to) { limit = min (a[S], limit); S++); }
4932       (or
4933       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
4934       with array mask instead).
4935    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
4936    setting limit = huge (limit); in the else branch.  */
4937
4938 static void
4939 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
4940 {
4941   tree limit;
4942   tree type;
4943   tree tmp;
4944   tree ifbody;
4945   tree nonempty;
4946   tree nonempty_var;
4947   tree lab;
4948   tree fast;
4949   tree huge_cst = NULL, nan_cst = NULL;
4950   stmtblock_t body;
4951   stmtblock_t block, block2;
4952   gfc_loopinfo loop;
4953   gfc_actual_arglist *actual;
4954   gfc_ss *arrayss;
4955   gfc_ss *maskss;
4956   gfc_se arrayse;
4957   gfc_se maskse;
4958   gfc_expr *arrayexpr;
4959   gfc_expr *maskexpr;
4960   int n;
4961
4962   if (se->ss)
4963     {
4964       gfc_conv_intrinsic_funcall (se, expr);
4965       return;
4966     }
4967
4968   type = gfc_typenode_for_spec (&expr->ts);
4969   /* Initialize the result.  */
4970   limit = gfc_create_var (type, "limit");
4971   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
4972   switch (expr->ts.type)
4973     {
4974     case BT_REAL:
4975       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
4976                                         expr->ts.kind, 0);
4977       if (HONOR_INFINITIES (DECL_MODE (limit)))
4978         {
4979           REAL_VALUE_TYPE real;
4980           real_inf (&real);
4981           tmp = build_real (type, real);
4982         }
4983       else
4984         tmp = huge_cst;
4985       if (HONOR_NANS (DECL_MODE (limit)))
4986         nan_cst = gfc_build_nan (type, "");
4987       break;
4988
4989     case BT_INTEGER:
4990       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
4991       break;
4992
4993     default:
4994       gcc_unreachable ();
4995     }
4996
4997   /* We start with the most negative possible value for MAXVAL, and the most
4998      positive possible value for MINVAL. The most negative possible value is
4999      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
5000      possible value is HUGE in both cases.  */
5001   if (op == GT_EXPR)
5002     {
5003       tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
5004       if (huge_cst)
5005         huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
5006                                     TREE_TYPE (huge_cst), huge_cst);
5007     }
5008
5009   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
5010     tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
5011                            tmp, build_int_cst (type, 1));
5012
5013   gfc_add_modify (&se->pre, limit, tmp);
5014
5015   /* Walk the arguments.  */
5016   actual = expr->value.function.actual;
5017   arrayexpr = actual->expr;
5018   arrayss = gfc_walk_expr (arrayexpr);
5019   gcc_assert (arrayss != gfc_ss_terminator);
5020
5021   actual = actual->next->next;
5022   gcc_assert (actual);
5023   maskexpr = actual->expr;
5024   nonempty = NULL;
5025   if (maskexpr && maskexpr->rank != 0)
5026     {
5027       maskss = gfc_walk_expr (maskexpr);
5028       gcc_assert (maskss != gfc_ss_terminator);
5029     }
5030   else
5031     {
5032       mpz_t asize;
5033       if (gfc_array_size (arrayexpr, &asize))
5034         {
5035           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
5036           mpz_clear (asize);
5037           nonempty = fold_build2_loc (input_location, GT_EXPR,
5038                                       boolean_type_node, nonempty,
5039                                       gfc_index_zero_node);
5040         }
5041       maskss = NULL;
5042     }
5043
5044   /* Initialize the scalarizer.  */
5045   gfc_init_loopinfo (&loop);
5046   gfc_add_ss_to_loop (&loop, arrayss);
5047   if (maskss)
5048     gfc_add_ss_to_loop (&loop, maskss);
5049
5050   /* Initialize the loop.  */
5051   gfc_conv_ss_startstride (&loop);
5052
5053   /* The code generated can have more than one loop in sequence (see the
5054      comment at the function header).  This doesn't work well with the
5055      scalarizer, which changes arrays' offset when the scalarization loops
5056      are generated (see gfc_trans_preloop_setup).  Fortunately, {min,max}val
5057      are  currently inlined in the scalar case only.  As there is no dependency
5058      to care about in that case, there is no temporary, so that we can use the
5059      scalarizer temporary code to handle multiple loops.  Thus, we set temp_dim
5060      here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
5061      gfc_trans_scalarized_loop_boundary even later to restore offset.
5062      TODO: this prevents inlining of rank > 0 minmaxval calls, so this
5063      should eventually go away.  We could either create two loops properly,
5064      or find another way to save/restore the array offsets between the two
5065      loops (without conflicting with temporary management), or use a single
5066      loop minmaxval implementation.  See PR 31067.  */
5067   loop.temp_dim = loop.dimen;
5068   gfc_conv_loop_setup (&loop, &expr->where);
5069
5070   if (nonempty == NULL && maskss == NULL
5071       && loop.dimen == 1 && loop.from[0] && loop.to[0])
5072     nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5073                                 loop.from[0], loop.to[0]);
5074   nonempty_var = NULL;
5075   if (nonempty == NULL
5076       && (HONOR_INFINITIES (DECL_MODE (limit))
5077           || HONOR_NANS (DECL_MODE (limit))))
5078     {
5079       nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
5080       gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
5081       nonempty = nonempty_var;
5082     }
5083   lab = NULL;
5084   fast = NULL;
5085   if (HONOR_NANS (DECL_MODE (limit)))
5086     {
5087       if (loop.dimen == 1)
5088         {
5089           lab = gfc_build_label_decl (NULL_TREE);
5090           TREE_USED (lab) = 1;
5091         }
5092       else
5093         {
5094           fast = gfc_create_var (boolean_type_node, "fast");
5095           gfc_add_modify (&se->pre, fast, boolean_false_node);
5096         }
5097     }
5098
5099   gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
5100   if (maskss)
5101     gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
5102   /* Generate the loop body.  */
5103   gfc_start_scalarized_body (&loop, &body);
5104
5105   /* If we have a mask, only add this element if the mask is set.  */
5106   if (maskss)
5107     {
5108       gfc_init_se (&maskse, NULL);
5109       gfc_copy_loopinfo_to_se (&maskse, &loop);
5110       maskse.ss = maskss;
5111       gfc_conv_expr_val (&maskse, maskexpr);
5112       gfc_add_block_to_block (&body, &maskse.pre);
5113
5114       gfc_start_block (&block);
5115     }
5116   else
5117     gfc_init_block (&block);
5118
5119   /* Compare with the current limit.  */
5120   gfc_init_se (&arrayse, NULL);
5121   gfc_copy_loopinfo_to_se (&arrayse, &loop);
5122   arrayse.ss = arrayss;
5123   gfc_conv_expr_val (&arrayse, arrayexpr);
5124   gfc_add_block_to_block (&block, &arrayse.pre);
5125
5126   gfc_init_block (&block2);
5127
5128   if (nonempty_var)
5129     gfc_add_modify (&block2, nonempty_var, boolean_true_node);
5130
5131   if (HONOR_NANS (DECL_MODE (limit)))
5132     {
5133       tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
5134                              boolean_type_node, arrayse.expr, limit);
5135       if (lab)
5136         ifbody = build1_v (GOTO_EXPR, lab);
5137       else
5138         {
5139           stmtblock_t ifblock;
5140
5141           gfc_init_block (&ifblock);
5142           gfc_add_modify (&ifblock, limit, arrayse.expr);
5143           gfc_add_modify (&ifblock, fast, boolean_true_node);
5144           ifbody = gfc_finish_block (&ifblock);
5145         }
5146       tmp = build3_v (COND_EXPR, tmp, ifbody,
5147                       build_empty_stmt (input_location));
5148       gfc_add_expr_to_block (&block2, tmp);
5149     }
5150   else
5151     {
5152       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5153          signed zeros.  */
5154       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5155         {
5156           tmp = fold_build2_loc (input_location, op, boolean_type_node,
5157                                  arrayse.expr, limit);
5158           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5159           tmp = build3_v (COND_EXPR, tmp, ifbody,
5160                           build_empty_stmt (input_location));
5161           gfc_add_expr_to_block (&block2, tmp);
5162         }
5163       else
5164         {
5165           tmp = fold_build2_loc (input_location,
5166                                  op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5167                                  type, arrayse.expr, limit);
5168           gfc_add_modify (&block2, limit, tmp);
5169         }
5170     }
5171
5172   if (fast)
5173     {
5174       tree elsebody = gfc_finish_block (&block2);
5175
5176       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5177          signed zeros.  */
5178       if (HONOR_NANS (DECL_MODE (limit))
5179           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5180         {
5181           tmp = fold_build2_loc (input_location, op, boolean_type_node,
5182                                  arrayse.expr, limit);
5183           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5184           ifbody = build3_v (COND_EXPR, tmp, ifbody,
5185                              build_empty_stmt (input_location));
5186         }
5187       else
5188         {
5189           tmp = fold_build2_loc (input_location,
5190                                  op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5191                                  type, arrayse.expr, limit);
5192           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5193         }
5194       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
5195       gfc_add_expr_to_block (&block, tmp);
5196     }
5197   else
5198     gfc_add_block_to_block (&block, &block2);
5199
5200   gfc_add_block_to_block (&block, &arrayse.post);
5201
5202   tmp = gfc_finish_block (&block);
5203   if (maskss)
5204     /* We enclose the above in if (mask) {...}.  */
5205     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5206                     build_empty_stmt (input_location));
5207   gfc_add_expr_to_block (&body, tmp);
5208
5209   if (lab)
5210     {
5211       gfc_trans_scalarized_loop_boundary (&loop, &body);
5212
5213       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5214                              nan_cst, huge_cst);
5215       gfc_add_modify (&loop.code[0], limit, tmp);
5216       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
5217
5218       /* If we have a mask, only add this element if the mask is set.  */
5219       if (maskss)
5220         {
5221           gfc_init_se (&maskse, NULL);
5222           gfc_copy_loopinfo_to_se (&maskse, &loop);
5223           maskse.ss = maskss;
5224           gfc_conv_expr_val (&maskse, maskexpr);
5225           gfc_add_block_to_block (&body, &maskse.pre);
5226
5227           gfc_start_block (&block);
5228         }
5229       else
5230         gfc_init_block (&block);
5231
5232       /* Compare with the current limit.  */
5233       gfc_init_se (&arrayse, NULL);
5234       gfc_copy_loopinfo_to_se (&arrayse, &loop);
5235       arrayse.ss = arrayss;
5236       gfc_conv_expr_val (&arrayse, arrayexpr);
5237       gfc_add_block_to_block (&block, &arrayse.pre);
5238
5239       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
5240          signed zeros.  */
5241       if (HONOR_NANS (DECL_MODE (limit))
5242           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
5243         {
5244           tmp = fold_build2_loc (input_location, op, boolean_type_node,
5245                                  arrayse.expr, limit);
5246           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
5247           tmp = build3_v (COND_EXPR, tmp, ifbody,
5248                           build_empty_stmt (input_location));
5249           gfc_add_expr_to_block (&block, tmp);
5250         }
5251       else
5252         {
5253           tmp = fold_build2_loc (input_location,
5254                                  op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
5255                                  type, arrayse.expr, limit);
5256           gfc_add_modify (&block, limit, tmp);
5257         }
5258
5259       gfc_add_block_to_block (&block, &arrayse.post);
5260
5261       tmp = gfc_finish_block (&block);
5262       if (maskss)
5263         /* We enclose the above in if (mask) {...}.  */
5264         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
5265                         build_empty_stmt (input_location));
5266       gfc_add_expr_to_block (&body, tmp);
5267       /* Avoid initializing loopvar[0] again, it should be left where
5268          it finished by the first loop.  */
5269       loop.from[0] = loop.loopvar[0];
5270     }
5271   gfc_trans_scalarizing_loops (&loop, &body);
5272
5273   if (fast)
5274     {
5275       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
5276                              nan_cst, huge_cst);
5277       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
5278       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
5279                       ifbody);
5280       gfc_add_expr_to_block (&loop.pre, tmp);
5281     }
5282   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
5283     {
5284       tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
5285                              huge_cst);
5286       gfc_add_modify (&loop.pre, limit, tmp);
5287     }
5288
5289   /* For a scalar mask, enclose the loop in an if statement.  */
5290   if (maskexpr && maskss == NULL)
5291     {
5292       tree else_stmt;
5293
5294       gfc_init_se (&maskse, NULL);
5295       gfc_conv_expr_val (&maskse, maskexpr);
5296       gfc_init_block (&block);
5297       gfc_add_block_to_block (&block, &loop.pre);
5298       gfc_add_block_to_block (&block, &loop.post);
5299       tmp = gfc_finish_block (&block);
5300
5301       if (HONOR_INFINITIES (DECL_MODE (limit)))
5302         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
5303       else
5304         else_stmt = build_empty_stmt (input_location);
5305       tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
5306       gfc_add_expr_to_block (&block, tmp);
5307       gfc_add_block_to_block (&se->pre, &block);
5308     }
5309   else
5310     {
5311       gfc_add_block_to_block (&se->pre, &loop.pre);
5312       gfc_add_block_to_block (&se->pre, &loop.post);
5313     }
5314
5315   gfc_cleanup_loop (&loop);
5316
5317   se->expr = limit;
5318 }
5319
5320 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
5321 static void
5322 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
5323 {
5324   tree args[2];
5325   tree type;
5326   tree tmp;
5327
5328   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5329   type = TREE_TYPE (args[0]);
5330
5331   tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5332                          build_int_cst (type, 1), args[1]);
5333   tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
5334   tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5335                          build_int_cst (type, 0));
5336   type = gfc_typenode_for_spec (&expr->ts);
5337   se->expr = convert (type, tmp);
5338 }
5339
5340
5341 /* Generate code for BGE, BGT, BLE and BLT intrinsics.  */
5342 static void
5343 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5344 {
5345   tree args[2];
5346
5347   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5348
5349   /* Convert both arguments to the unsigned type of the same size.  */
5350   args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
5351   args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
5352
5353   /* If they have unequal type size, convert to the larger one.  */
5354   if (TYPE_PRECISION (TREE_TYPE (args[0]))
5355       > TYPE_PRECISION (TREE_TYPE (args[1])))
5356     args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
5357   else if (TYPE_PRECISION (TREE_TYPE (args[1]))
5358            > TYPE_PRECISION (TREE_TYPE (args[0])))
5359     args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
5360
5361   /* Now, we compare them.  */
5362   se->expr = fold_build2_loc (input_location, op, boolean_type_node,
5363                               args[0], args[1]);
5364 }
5365
5366
5367 /* Generate code to perform the specified operation.  */
5368 static void
5369 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
5370 {
5371   tree args[2];
5372
5373   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5374   se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
5375                               args[0], args[1]);
5376 }
5377
5378 /* Bitwise not.  */
5379 static void
5380 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
5381 {
5382   tree arg;
5383
5384   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5385   se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
5386                               TREE_TYPE (arg), arg);
5387 }
5388
5389 /* Set or clear a single bit.  */
5390 static void
5391 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
5392 {
5393   tree args[2];
5394   tree type;
5395   tree tmp;
5396   enum tree_code op;
5397
5398   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5399   type = TREE_TYPE (args[0]);
5400
5401   tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
5402                          build_int_cst (type, 1), args[1]);
5403   if (set)
5404     op = BIT_IOR_EXPR;
5405   else
5406     {
5407       op = BIT_AND_EXPR;
5408       tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
5409     }
5410   se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
5411 }
5412
5413 /* Extract a sequence of bits.
5414     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
5415 static void
5416 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
5417 {
5418   tree args[3];
5419   tree type;
5420   tree tmp;
5421   tree mask;
5422
5423   gfc_conv_intrinsic_function_args (se, expr, args, 3);
5424   type = TREE_TYPE (args[0]);
5425
5426   mask = build_int_cst (type, -1);
5427   mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
5428   mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
5429
5430   tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
5431
5432   se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
5433 }
5434
5435 static void
5436 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
5437                           bool arithmetic)
5438 {
5439   tree args[2], type, num_bits, cond;
5440
5441   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5442
5443   args[0] = gfc_evaluate_now (args[0], &se->pre);
5444   args[1] = gfc_evaluate_now (args[1], &se->pre);
5445   type = TREE_TYPE (args[0]);
5446
5447   if (!arithmetic)
5448     args[0] = fold_convert (unsigned_type_for (type), args[0]);
5449   else
5450     gcc_assert (right_shift);
5451
5452   se->expr = fold_build2_loc (input_location,
5453                               right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
5454                               TREE_TYPE (args[0]), args[0], args[1]);
5455
5456   if (!arithmetic)
5457     se->expr = fold_convert (type, se->expr);
5458
5459   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5460      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5461      special case.  */
5462   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5463   cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
5464                           args[1], num_bits);
5465
5466   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5467                               build_int_cst (type, 0), se->expr);
5468 }
5469
5470 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
5471                         ? 0
5472                         : ((shift >= 0) ? i << shift : i >> -shift)
5473    where all shifts are logical shifts.  */
5474 static void
5475 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
5476 {
5477   tree args[2];
5478   tree type;
5479   tree utype;
5480   tree tmp;
5481   tree width;
5482   tree num_bits;
5483   tree cond;
5484   tree lshift;
5485   tree rshift;
5486
5487   gfc_conv_intrinsic_function_args (se, expr, args, 2);
5488
5489   args[0] = gfc_evaluate_now (args[0], &se->pre);
5490   args[1] = gfc_evaluate_now (args[1], &se->pre);
5491
5492   type = TREE_TYPE (args[0]);
5493   utype = unsigned_type_for (type);
5494
5495   width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
5496                            args[1]);
5497
5498   /* Left shift if positive.  */
5499   lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
5500
5501   /* Right shift if negative.
5502      We convert to an unsigned type because we want a logical shift.
5503      The standard doesn't define the case of shifting negative
5504      numbers, and we try to be compatible with other compilers, most
5505      notably g77, here.  */
5506   rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
5507                                     utype, convert (utype, args[0]), width));
5508
5509   tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
5510                          build_int_cst (TREE_TYPE (args[1]), 0));
5511   tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
5512
5513   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
5514      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
5515      special case.  */
5516   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
5517   cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
5518                           num_bits);
5519   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
5520                               build_int_cst (type, 0), tmp);
5521 }
5522
5523
5524 /* Circular shift.  AKA rotate or barrel shift.  */
5525
5526 static void
5527 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
5528 {
5529   tree *args;
5530   tree type;
5531   tree tmp;
5532   tree lrot;
5533   tree rrot;
5534   tree zero;
5535   unsigned int num_args;
5536
5537   num_args = gfc_intrinsic_argument_list_length (expr);
5538   args = XALLOCAVEC (tree, num_args);
5539
5540   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
5541
5542   if (num_args == 3)
5543     {
5544       /* Use a library function for the 3 parameter version.  */
5545       tree int4type = gfc_get_int_type (4);
5546
5547       type = TREE_TYPE (args[0]);
5548       /* We convert the first argument to at least 4 bytes, and
5549          convert back afterwards.  This removes the need for library
5550          functions for all argument sizes, and function will be
5551          aligned to at least 32 bits, so there's no loss.  */
5552       if (expr->ts.kind < 4)
5553         args[0] = convert (int4type, args[0]);
5554
5555       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
5556          need loads of library  functions.  They cannot have values >
5557          BIT_SIZE (I) so the conversion is safe.  */
5558       args[1] = convert (int4type, args[1]);
5559       args[2] = convert (int4type, args[2]);
5560
5561       switch (expr->ts.kind)
5562         {
5563         case 1:
5564         case 2:
5565         case 4:
5566           tmp = gfor_fndecl_math_ishftc4;
5567           break;
5568         case 8:
5569           tmp = gfor_fndecl_math_ishftc8;
5570           break;
5571         case 16:
5572           tmp = gfor_fndecl_math_ishftc16;
5573           break;
5574         default:
5575           gcc_unreachable ();
5576         }
5577       se->expr = build_call_expr_loc (input_location,
5578                                       tmp, 3, args[0], args[1], args[2]);
5579       /* Convert the result back to the original type, if we extended
5580          the first argument's width above.  */
5581       if (expr->ts.kind < 4)
5582         se->expr = convert (type, se->expr);
5583
5584       return;
5585     }
5586   type = TREE_TYPE (args[0]);
5587
5588   /* Evaluate arguments only once.  */
5589   args[0] = gfc_evaluate_now (args[0], &se->pre);
5590   args[1] = gfc_evaluate_now (args[1], &se->pre);
5591
5592   /* Rotate left if positive.  */
5593   lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
5594
5595   /* Rotate right if negative.  */
5596   tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
5597                          args[1]);
5598   rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
5599
5600   zero = build_int_cst (TREE_TYPE (args[1]), 0);
5601   tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
5602                          zero);
5603   rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
5604
5605   /* Do nothing if shift == 0.  */
5606   tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
5607                          zero);
5608   se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
5609                               rrot);
5610 }
5611
5612
5613 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
5614                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
5615
5616    The conditional expression is necessary because the result of LEADZ(0)
5617    is defined, but the result of __builtin_clz(0) is undefined for most
5618    targets.
5619
5620    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
5621    difference in bit size between the argument of LEADZ and the C int.  */
5622
5623 static void
5624 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
5625 {
5626   tree arg;
5627   tree arg_type;
5628   tree cond;
5629   tree result_type;
5630   tree leadz;
5631   tree bit_size;
5632   tree tmp;
5633   tree func;
5634   int s, argsize;
5635
5636   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5637   argsize = TYPE_PRECISION (TREE_TYPE (arg));
5638
5639   /* Which variant of __builtin_clz* should we call?  */
5640   if (argsize <= INT_TYPE_SIZE)
5641     {
5642       arg_type = unsigned_type_node;
5643       func = builtin_decl_explicit (BUILT_IN_CLZ);
5644     }
5645   else if (argsize <= LONG_TYPE_SIZE)
5646     {
5647       arg_type = long_unsigned_type_node;
5648       func = builtin_decl_explicit (BUILT_IN_CLZL);
5649     }
5650   else if (argsize <= LONG_LONG_TYPE_SIZE)
5651     {
5652       arg_type = long_long_unsigned_type_node;
5653       func = builtin_decl_explicit (BUILT_IN_CLZLL);
5654     }
5655   else
5656     {
5657       gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5658       arg_type = gfc_build_uint_type (argsize);
5659       func = NULL_TREE;
5660     }
5661
5662   /* Convert the actual argument twice: first, to the unsigned type of the
5663      same size; then, to the proper argument type for the built-in
5664      function.  But the return type is of the default INTEGER kind.  */
5665   arg = fold_convert (gfc_build_uint_type (argsize), arg);
5666   arg = fold_convert (arg_type, arg);
5667   arg = gfc_evaluate_now (arg, &se->pre);
5668   result_type = gfc_get_int_type (gfc_default_integer_kind);
5669
5670   /* Compute LEADZ for the case i .ne. 0.  */
5671   if (func)
5672     {
5673       s = TYPE_PRECISION (arg_type) - argsize;
5674       tmp = fold_convert (result_type,
5675                           build_call_expr_loc (input_location, func,
5676                                                1, arg));
5677       leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
5678                                tmp, build_int_cst (result_type, s));
5679     }
5680   else
5681     {
5682       /* We end up here if the argument type is larger than 'long long'.
5683          We generate this code:
5684
5685             if (x & (ULL_MAX << ULL_SIZE) != 0)
5686               return clzll ((unsigned long long) (x >> ULLSIZE));
5687             else
5688               return ULL_SIZE + clzll ((unsigned long long) x);
5689          where ULL_MAX is the largest value that a ULL_MAX can hold
5690          (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5691          is the bit-size of the long long type (64 in this example).  */
5692       tree ullsize, ullmax, tmp1, tmp2, btmp;
5693
5694       ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5695       ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5696                                 long_long_unsigned_type_node,
5697                                 build_int_cst (long_long_unsigned_type_node,
5698                                                0));
5699
5700       cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
5701                               fold_convert (arg_type, ullmax), ullsize);
5702       cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
5703                               arg, cond);
5704       cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5705                               cond, build_int_cst (arg_type, 0));
5706
5707       tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5708                               arg, ullsize);
5709       tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5710       btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5711       tmp1 = fold_convert (result_type,
5712                            build_call_expr_loc (input_location, btmp, 1, tmp1));
5713
5714       tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5715       btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
5716       tmp2 = fold_convert (result_type,
5717                            build_call_expr_loc (input_location, btmp, 1, tmp2));
5718       tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5719                               tmp2, ullsize);
5720
5721       leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
5722                                cond, tmp1, tmp2);
5723     }
5724
5725   /* Build BIT_SIZE.  */
5726   bit_size = build_int_cst (result_type, argsize);
5727
5728   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5729                           arg, build_int_cst (arg_type, 0));
5730   se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5731                               bit_size, leadz);
5732 }
5733
5734
5735 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
5736
5737    The conditional expression is necessary because the result of TRAILZ(0)
5738    is defined, but the result of __builtin_ctz(0) is undefined for most
5739    targets.  */
5740
5741 static void
5742 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
5743 {
5744   tree arg;
5745   tree arg_type;
5746   tree cond;
5747   tree result_type;
5748   tree trailz;
5749   tree bit_size;
5750   tree func;
5751   int argsize;
5752
5753   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5754   argsize = TYPE_PRECISION (TREE_TYPE (arg));
5755
5756   /* Which variant of __builtin_ctz* should we call?  */
5757   if (argsize <= INT_TYPE_SIZE)
5758     {
5759       arg_type = unsigned_type_node;
5760       func = builtin_decl_explicit (BUILT_IN_CTZ);
5761     }
5762   else if (argsize <= LONG_TYPE_SIZE)
5763     {
5764       arg_type = long_unsigned_type_node;
5765       func = builtin_decl_explicit (BUILT_IN_CTZL);
5766     }
5767   else if (argsize <= LONG_LONG_TYPE_SIZE)
5768     {
5769       arg_type = long_long_unsigned_type_node;
5770       func = builtin_decl_explicit (BUILT_IN_CTZLL);
5771     }
5772   else
5773     {
5774       gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5775       arg_type = gfc_build_uint_type (argsize);
5776       func = NULL_TREE;
5777     }
5778
5779   /* Convert the actual argument twice: first, to the unsigned type of the
5780      same size; then, to the proper argument type for the built-in
5781      function.  But the return type is of the default INTEGER kind.  */
5782   arg = fold_convert (gfc_build_uint_type (argsize), arg);
5783   arg = fold_convert (arg_type, arg);
5784   arg = gfc_evaluate_now (arg, &se->pre);
5785   result_type = gfc_get_int_type (gfc_default_integer_kind);
5786
5787   /* Compute TRAILZ for the case i .ne. 0.  */
5788   if (func)
5789     trailz = fold_convert (result_type, build_call_expr_loc (input_location,
5790                                                              func, 1, arg));
5791   else
5792     {
5793       /* We end up here if the argument type is larger than 'long long'.
5794          We generate this code:
5795
5796             if ((x & ULL_MAX) == 0)
5797               return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
5798             else
5799               return ctzll ((unsigned long long) x);
5800
5801          where ULL_MAX is the largest value that a ULL_MAX can hold
5802          (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
5803          is the bit-size of the long long type (64 in this example).  */
5804       tree ullsize, ullmax, tmp1, tmp2, btmp;
5805
5806       ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
5807       ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
5808                                 long_long_unsigned_type_node,
5809                                 build_int_cst (long_long_unsigned_type_node, 0));
5810
5811       cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
5812                               fold_convert (arg_type, ullmax));
5813       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
5814                               build_int_cst (arg_type, 0));
5815
5816       tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
5817                               arg, ullsize);
5818       tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
5819       btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5820       tmp1 = fold_convert (result_type,
5821                            build_call_expr_loc (input_location, btmp, 1, tmp1));
5822       tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5823                               tmp1, ullsize);
5824
5825       tmp2 = fold_convert (long_long_unsigned_type_node, arg);
5826       btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
5827       tmp2 = fold_convert (result_type,
5828                            build_call_expr_loc (input_location, btmp, 1, tmp2));
5829
5830       trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
5831                                 cond, tmp1, tmp2);
5832     }
5833
5834   /* Build BIT_SIZE.  */
5835   bit_size = build_int_cst (result_type, argsize);
5836
5837   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5838                           arg, build_int_cst (arg_type, 0));
5839   se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
5840                               bit_size, trailz);
5841 }
5842
5843 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
5844    for types larger than "long long", we call the long long built-in for
5845    the lower and higher bits and combine the result.  */
5846
5847 static void
5848 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
5849 {
5850   tree arg;
5851   tree arg_type;
5852   tree result_type;
5853   tree func;
5854   int argsize;
5855
5856   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5857   argsize = TYPE_PRECISION (TREE_TYPE (arg));
5858   result_type = gfc_get_int_type (gfc_default_integer_kind);
5859
5860   /* Which variant of the builtin should we call?  */
5861   if (argsize <= INT_TYPE_SIZE)
5862     {
5863       arg_type = unsigned_type_node;
5864       func = builtin_decl_explicit (parity
5865                                     ? BUILT_IN_PARITY
5866                                     : BUILT_IN_POPCOUNT);
5867     }
5868   else if (argsize <= LONG_TYPE_SIZE)
5869     {
5870       arg_type = long_unsigned_type_node;
5871       func = builtin_decl_explicit (parity
5872                                     ? BUILT_IN_PARITYL
5873                                     : BUILT_IN_POPCOUNTL);
5874     }
5875   else if (argsize <= LONG_LONG_TYPE_SIZE)
5876     {
5877       arg_type = long_long_unsigned_type_node;
5878       func = builtin_decl_explicit (parity
5879                                     ? BUILT_IN_PARITYLL
5880                                     : BUILT_IN_POPCOUNTLL);
5881     }
5882   else
5883     {
5884       /* Our argument type is larger than 'long long', which mean none
5885          of the POPCOUNT builtins covers it.  We thus call the 'long long'
5886          variant multiple times, and add the results.  */
5887       tree utype, arg2, call1, call2;
5888
5889       /* For now, we only cover the case where argsize is twice as large
5890          as 'long long'.  */
5891       gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
5892
5893       func = builtin_decl_explicit (parity
5894                                     ? BUILT_IN_PARITYLL
5895                                     : BUILT_IN_POPCOUNTLL);
5896
5897       /* Convert it to an integer, and store into a variable.  */
5898       utype = gfc_build_uint_type (argsize);
5899       arg = fold_convert (utype, arg);
5900       arg = gfc_evaluate_now (arg, &se->pre);
5901
5902       /* Call the builtin twice.  */
5903       call1 = build_call_expr_loc (input_location, func, 1,
5904                                    fold_convert (long_long_unsigned_type_node,
5905                                                  arg));
5906
5907       arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
5908                               build_int_cst (utype, LONG_LONG_TYPE_SIZE));
5909       call2 = build_call_expr_loc (input_location, func, 1,
5910                                    fold_convert (long_long_unsigned_type_node,
5911                                                  arg2));
5912
5913       /* Combine the results.  */
5914       if (parity)
5915         se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
5916                                     call1, call2);
5917       else
5918         se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
5919                                     call1, call2);
5920
5921       return;
5922     }
5923
5924   /* Convert the actual argument twice: first, to the unsigned type of the
5925      same size; then, to the proper argument type for the built-in
5926      function.  */
5927   arg = fold_convert (gfc_build_uint_type (argsize), arg);
5928   arg = fold_convert (arg_type, arg);
5929
5930   se->expr = fold_convert (result_type,
5931                            build_call_expr_loc (input_location, func, 1, arg));
5932 }
5933
5934
5935 /* Process an intrinsic with unspecified argument-types that has an optional
5936    argument (which could be of type character), e.g. EOSHIFT.  For those, we
5937    need to append the string length of the optional argument if it is not
5938    present and the type is really character.
5939    primary specifies the position (starting at 1) of the non-optional argument
5940    specifying the type and optional gives the position of the optional
5941    argument in the arglist.  */
5942
5943 static void
5944 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
5945                                      unsigned primary, unsigned optional)
5946 {
5947   gfc_actual_arglist* prim_arg;
5948   gfc_actual_arglist* opt_arg;
5949   unsigned cur_pos;
5950   gfc_actual_arglist* arg;
5951   gfc_symbol* sym;
5952   vec<tree, va_gc> *append_args;
5953
5954   /* Find the two arguments given as position.  */
5955   cur_pos = 0;
5956   prim_arg = NULL;
5957   opt_arg = NULL;
5958   for (arg = expr->value.function.actual; arg; arg = arg->next)
5959     {
5960       ++cur_pos;
5961
5962       if (cur_pos == primary)
5963         prim_arg = arg;
5964       if (cur_pos == optional)
5965         opt_arg = arg;
5966
5967       if (cur_pos >= primary && cur_pos >= optional)
5968         break;
5969     }
5970   gcc_assert (prim_arg);
5971   gcc_assert (prim_arg->expr);
5972   gcc_assert (opt_arg);
5973
5974   /* If we do have type CHARACTER and the optional argument is really absent,
5975      append a dummy 0 as string length.  */
5976   append_args = NULL;
5977   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
5978     {
5979       tree dummy;
5980
5981       dummy = build_int_cst (gfc_charlen_type_node, 0);
5982       vec_alloc (append_args, 1);
5983       append_args->quick_push (dummy);
5984     }
5985
5986   /* Build the call itself.  */
5987   gcc_assert (!se->ignore_optional);
5988   sym = gfc_get_symbol_for_expr (expr, false);
5989   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
5990                           append_args);
5991   gfc_free_symbol (sym);
5992 }
5993
5994
5995 /* The length of a character string.  */
5996 static void
5997 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
5998 {
5999   tree len;
6000   tree type;
6001   tree decl;
6002   gfc_symbol *sym;
6003   gfc_se argse;
6004   gfc_expr *arg;
6005
6006   gcc_assert (!se->ss);
6007
6008   arg = expr->value.function.actual->expr;
6009
6010   type = gfc_typenode_for_spec (&expr->ts);
6011   switch (arg->expr_type)
6012     {
6013     case EXPR_CONSTANT:
6014       len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
6015       break;
6016
6017     case EXPR_ARRAY:
6018       /* Obtain the string length from the function used by
6019          trans-array.c(gfc_trans_array_constructor).  */
6020       len = NULL_TREE;
6021       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
6022       break;
6023
6024     case EXPR_VARIABLE:
6025       if (arg->ref == NULL
6026             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
6027         {
6028           /* This doesn't catch all cases.
6029              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
6030              and the surrounding thread.  */
6031           sym = arg->symtree->n.sym;
6032           decl = gfc_get_symbol_decl (sym);
6033           if (decl == current_function_decl && sym->attr.function
6034                 && (sym->result == sym))
6035             decl = gfc_get_fake_result_decl (sym, 0);
6036
6037           len = sym->ts.u.cl->backend_decl;
6038           gcc_assert (len);
6039           break;
6040         }
6041
6042       /* Fall through.  */
6043
6044     default:
6045       /* Anybody stupid enough to do this deserves inefficient code.  */
6046       gfc_init_se (&argse, se);
6047       if (arg->rank == 0)
6048         gfc_conv_expr (&argse, arg);
6049       else
6050         gfc_conv_expr_descriptor (&argse, arg);
6051       gfc_add_block_to_block (&se->pre, &argse.pre);
6052       gfc_add_block_to_block (&se->post, &argse.post);
6053       len = argse.string_length;
6054       break;
6055     }
6056   se->expr = convert (type, len);
6057 }
6058
6059 /* The length of a character string not including trailing blanks.  */
6060 static void
6061 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
6062 {
6063   int kind = expr->value.function.actual->expr->ts.kind;
6064   tree args[2], type, fndecl;
6065
6066   gfc_conv_intrinsic_function_args (se, expr, args, 2);
6067   type = gfc_typenode_for_spec (&expr->ts);
6068
6069   if (kind == 1)
6070     fndecl = gfor_fndecl_string_len_trim;
6071   else if (kind == 4)
6072     fndecl = gfor_fndecl_string_len_trim_char4;
6073   else
6074     gcc_unreachable ();
6075
6076   se->expr = build_call_expr_loc (input_location,
6077                               fndecl, 2, args[0], args[1]);
6078   se->expr = convert (type, se->expr);
6079 }
6080
6081
6082 /* Returns the starting position of a substring within a string.  */
6083
6084 static void
6085 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
6086                                       tree function)
6087 {
6088   tree logical4_type_node = gfc_get_logical_type (4);
6089   tree type;
6090   tree fndecl;
6091   tree *args;
6092   unsigned int num_args;
6093
6094   args = XALLOCAVEC (tree, 5);
6095
6096   /* Get number of arguments; characters count double due to the
6097      string length argument. Kind= is not passed to the library
6098      and thus ignored.  */
6099   if (expr->value.function.actual->next->next->expr == NULL)
6100     num_args = 4;
6101   else
6102     num_args = 5;
6103
6104   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6105   type = gfc_typenode_for_spec (&expr->ts);
6106
6107   if (num_args == 4)
6108     args[4] = build_int_cst (logical4_type_node, 0);
6109   else
6110     args[4] = convert (logical4_type_node, args[4]);
6111
6112   fndecl = build_addr (function);
6113   se->expr = build_call_array_loc (input_location,
6114                                TREE_TYPE (TREE_TYPE (function)), fndecl,
6115                                5, args);
6116   se->expr = convert (type, se->expr);
6117
6118 }
6119
6120 /* The ascii value for a single character.  */
6121 static void
6122 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
6123 {
6124   tree args[3], type, pchartype;
6125   int nargs;
6126
6127   nargs = gfc_intrinsic_argument_list_length (expr);
6128   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
6129   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
6130   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
6131   args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
6132   type = gfc_typenode_for_spec (&expr->ts);
6133
6134   se->expr = build_fold_indirect_ref_loc (input_location,
6135                                       args[1]);
6136   se->expr = convert (type, se->expr);
6137 }
6138
6139
6140 /* Intrinsic ISNAN calls __builtin_isnan.  */
6141
6142 static void
6143 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
6144 {
6145   tree arg;
6146
6147   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6148   se->expr = build_call_expr_loc (input_location,
6149                                   builtin_decl_explicit (BUILT_IN_ISNAN),
6150                                   1, arg);
6151   STRIP_TYPE_NOPS (se->expr);
6152   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
6153 }
6154
6155
6156 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
6157    their argument against a constant integer value.  */
6158
6159 static void
6160 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
6161 {
6162   tree arg;
6163
6164   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6165   se->expr = fold_build2_loc (input_location, EQ_EXPR,
6166                               gfc_typenode_for_spec (&expr->ts),
6167                               arg, build_int_cst (TREE_TYPE (arg), value));
6168 }
6169
6170
6171
6172 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
6173
6174 static void
6175 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
6176 {
6177   tree tsource;
6178   tree fsource;
6179   tree mask;
6180   tree type;
6181   tree len, len2;
6182   tree *args;
6183   unsigned int num_args;
6184
6185   num_args = gfc_intrinsic_argument_list_length (expr);
6186   args = XALLOCAVEC (tree, num_args);
6187
6188   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
6189   if (expr->ts.type != BT_CHARACTER)
6190     {
6191       tsource = args[0];
6192       fsource = args[1];
6193       mask = args[2];
6194     }
6195   else
6196     {
6197       /* We do the same as in the non-character case, but the argument
6198          list is different because of the string length arguments. We
6199          also have to set the string length for the result.  */
6200       len = args[0];
6201       tsource = args[1];
6202       len2 = args[2];
6203       fsource = args[3];
6204       mask = args[4];
6205
6206       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
6207                                    &se->pre);
6208       se->string_length = len;
6209     }
6210   type = TREE_TYPE (tsource);
6211   se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
6212                               fold_convert (type, fsource));
6213 }
6214
6215
6216 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)).  */
6217
6218 static void
6219 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
6220 {
6221   tree args[3], mask, type;
6222
6223   gfc_conv_intrinsic_function_args (se, expr, args, 3);
6224   mask = gfc_evaluate_now (args[2], &se->pre);
6225
6226   type = TREE_TYPE (args[0]);
6227   gcc_assert (TREE_TYPE (args[1]) == type);
6228   gcc_assert (TREE_TYPE (mask) == type);
6229
6230   args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
6231   args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
6232                              fold_build1_loc (input_location, BIT_NOT_EXPR,
6233                                               type, mask));
6234   se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
6235                               args[0], args[1]);
6236 }
6237
6238
6239 /* MASKL(n)  =  n == 0 ? 0 : (~0) << (BIT_SIZE - n)
6240    MASKR(n)  =  n == BIT_SIZE ? ~0 : ~((~0) << n)  */
6241
6242 static void
6243 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
6244 {
6245   tree arg, allones, type, utype, res, cond, bitsize;
6246   int i;
6247
6248   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6249   arg = gfc_evaluate_now (arg, &se->pre);
6250
6251   type = gfc_get_int_type (expr->ts.kind);
6252   utype = unsigned_type_for (type);
6253
6254   i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
6255   bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
6256
6257   allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
6258                              build_int_cst (utype, 0));
6259
6260   if (left)
6261     {
6262       /* Left-justified mask.  */
6263       res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
6264                              bitsize, arg);
6265       res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6266                              fold_convert (utype, res));
6267
6268       /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
6269          smaller than type width.  */
6270       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
6271                               build_int_cst (TREE_TYPE (arg), 0));
6272       res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
6273                              build_int_cst (utype, 0), res);
6274     }
6275   else
6276     {
6277       /* Right-justified mask.  */
6278       res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
6279                              fold_convert (utype, arg));
6280       res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
6281
6282       /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
6283          strictly smaller than type width.  */
6284       cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
6285                               arg, bitsize);
6286       res = fold_build3_loc (input_location, COND_EXPR, utype,
6287                              cond, allones, res);
6288     }
6289
6290   se->expr = fold_convert (type, res);
6291 }
6292
6293
6294 /* FRACTION (s) is translated into:
6295      isfinite (s) ? frexp (s, &dummy_int) : NaN  */
6296 static void
6297 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
6298 {
6299   tree arg, type, tmp, res, frexp, cond;
6300
6301   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6302
6303   type = gfc_typenode_for_spec (&expr->ts);
6304   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6305   arg = gfc_evaluate_now (arg, &se->pre);
6306
6307   cond = build_call_expr_loc (input_location,
6308                               builtin_decl_explicit (BUILT_IN_ISFINITE),
6309                               1, arg);
6310
6311   tmp = gfc_create_var (integer_type_node, NULL);
6312   res = build_call_expr_loc (input_location, frexp, 2,
6313                              fold_convert (type, arg),
6314                              gfc_build_addr_expr (NULL_TREE, tmp));
6315   res = fold_convert (type, res);
6316
6317   se->expr = fold_build3_loc (input_location, COND_EXPR, type,
6318                               cond, res, gfc_build_nan (type, ""));
6319 }
6320
6321
6322 /* NEAREST (s, dir) is translated into
6323      tmp = copysign (HUGE_VAL, dir);
6324      return nextafter (s, tmp);
6325  */
6326 static void
6327 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
6328 {
6329   tree args[2], type, tmp, nextafter, copysign, huge_val;
6330
6331   nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
6332   copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
6333
6334   type = gfc_typenode_for_spec (&expr->ts);
6335   gfc_conv_intrinsic_function_args (se, expr, args, 2);
6336
6337   huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
6338   tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
6339                              fold_convert (type, args[1]));
6340   se->expr = build_call_expr_loc (input_location, nextafter, 2,
6341                                   fold_convert (type, args[0]), tmp);
6342   se->expr = fold_convert (type, se->expr);
6343 }
6344
6345
6346 /* SPACING (s) is translated into
6347     int e;
6348     if (!isfinite (s))
6349       res = NaN;
6350     else if (s == 0)
6351       res = tiny;
6352     else
6353     {
6354       frexp (s, &e);
6355       e = e - prec;
6356       e = MAX_EXPR (e, emin);
6357       res = scalbn (1., e);
6358     }
6359     return res;
6360
6361  where prec is the precision of s, gfc_real_kinds[k].digits,
6362        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
6363    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
6364
6365 static void
6366 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
6367 {
6368   tree arg, type, prec, emin, tiny, res, e;
6369   tree cond, nan, tmp, frexp, scalbn;
6370   int k;
6371   stmtblock_t block;
6372
6373   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6374   prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
6375   emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
6376   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
6377
6378   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6379   scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6380
6381   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6382   arg = gfc_evaluate_now (arg, &se->pre);
6383
6384   type = gfc_typenode_for_spec (&expr->ts);
6385   e = gfc_create_var (integer_type_node, NULL);
6386   res = gfc_create_var (type, NULL);
6387
6388
6389   /* Build the block for s /= 0.  */
6390   gfc_start_block (&block);
6391   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6392                              gfc_build_addr_expr (NULL_TREE, e));
6393   gfc_add_expr_to_block (&block, tmp);
6394
6395   tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
6396                          prec);
6397   gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
6398                                               integer_type_node, tmp, emin));
6399
6400   tmp = build_call_expr_loc (input_location, scalbn, 2,
6401                          build_real_from_int_cst (type, integer_one_node), e);
6402   gfc_add_modify (&block, res, tmp);
6403
6404   /* Finish by building the IF statement for value zero.  */
6405   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
6406                           build_real_from_int_cst (type, integer_zero_node));
6407   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
6408                   gfc_finish_block (&block));
6409
6410   /* And deal with infinities and NaNs.  */
6411   cond = build_call_expr_loc (input_location,
6412                               builtin_decl_explicit (BUILT_IN_ISFINITE),
6413                               1, arg);
6414   nan = gfc_build_nan (type, "");
6415   tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, res, nan));
6416
6417   gfc_add_expr_to_block (&se->pre, tmp);
6418   se->expr = res;
6419 }
6420
6421
6422 /* RRSPACING (s) is translated into
6423       int e;
6424       real x;
6425       x = fabs (s);
6426       if (isfinite (x))
6427       {
6428         if (x != 0)
6429         {
6430           frexp (s, &e);
6431           x = scalbn (x, precision - e);
6432         }
6433       }
6434       else
6435         x = NaN;
6436       return x;
6437
6438  where precision is gfc_real_kinds[k].digits.  */
6439
6440 static void
6441 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
6442 {
6443   tree arg, type, e, x, cond, nan, stmt, tmp, frexp, scalbn, fabs;
6444   int prec, k;
6445   stmtblock_t block;
6446
6447   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
6448   prec = gfc_real_kinds[k].digits;
6449
6450   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6451   scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6452   fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
6453
6454   type = gfc_typenode_for_spec (&expr->ts);
6455   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
6456   arg = gfc_evaluate_now (arg, &se->pre);
6457
6458   e = gfc_create_var (integer_type_node, NULL);
6459   x = gfc_create_var (type, NULL);
6460   gfc_add_modify (&se->pre, x,
6461                   build_call_expr_loc (input_location, fabs, 1, arg));
6462
6463
6464   gfc_start_block (&block);
6465   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
6466                              gfc_build_addr_expr (NULL_TREE, e));
6467   gfc_add_expr_to_block (&block, tmp);
6468
6469   tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
6470                          build_int_cst (integer_type_node, prec), e);
6471   tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
6472   gfc_add_modify (&block, x, tmp);
6473   stmt = gfc_finish_block (&block);
6474
6475   /* if (x != 0) */
6476   cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
6477                           build_real_from_int_cst (type, integer_zero_node));
6478   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
6479
6480   /* And deal with infinities and NaNs.  */
6481   cond = build_call_expr_loc (input_location,
6482                               builtin_decl_explicit (BUILT_IN_ISFINITE),
6483                               1, x);
6484   nan = gfc_build_nan (type, "");
6485   tmp = build3_v (COND_EXPR, cond, tmp, build2_v (MODIFY_EXPR, x, nan));
6486
6487   gfc_add_expr_to_block (&se->pre, tmp);
6488   se->expr = fold_convert (type, x);
6489 }
6490
6491
6492 /* SCALE (s, i) is translated into scalbn (s, i).  */
6493 static void
6494 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
6495 {
6496   tree args[2], type, scalbn;
6497
6498   scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6499
6500   type = gfc_typenode_for_spec (&expr->ts);
6501   gfc_conv_intrinsic_function_args (se, expr, args, 2);
6502   se->expr = build_call_expr_loc (input_location, scalbn, 2,
6503                                   fold_convert (type, args[0]),
6504                                   fold_convert (integer_type_node, args[1]));
6505   se->expr = fold_convert (type, se->expr);
6506 }
6507
6508
6509 /* SET_EXPONENT (s, i) is translated into
6510    isfinite(s) ? scalbn (frexp (s, &dummy_int), i) : NaN  */
6511 static void
6512 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
6513 {
6514   tree args[2], type, tmp, frexp, scalbn, cond, nan, res;
6515
6516   frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
6517   scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
6518
6519   type = gfc_typenode_for_spec (&expr->ts);
6520   gfc_conv_intrinsic_function_args (se, expr, args, 2);
6521   args[0] = gfc_evaluate_now (args[0], &se->pre);
6522
6523   tmp = gfc_create_var (integer_type_node, NULL);
6524   tmp = build_call_expr_loc (input_location, frexp, 2,
6525                              fold_convert (type, args[0]),
6526                              gfc_build_addr_expr (NULL_TREE, tmp));
6527   res = build_call_expr_loc (input_location, scalbn, 2, tmp,
6528                              fold_convert (integer_type_node, args[1]));
6529   res = fold_convert (type, res);
6530
6531   /* Call to isfinite */
6532   cond = build_call_expr_loc (input_location,
6533                               builtin_decl_explicit (BUILT_IN_ISFINITE),
6534                               1, args[0]);
6535   nan = gfc_build_nan (type, "");
6536
6537   se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
6538                               res, nan);
6539 }
6540
6541
6542 static void
6543 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
6544 {
6545   gfc_actual_arglist *actual;
6546   tree arg1;
6547   tree type;
6548   tree fncall0;
6549   tree fncall1;
6550   gfc_se argse;
6551
6552   gfc_init_se (&argse, NULL);
6553   actual = expr->value.function.actual;
6554
6555   if (actual->expr->ts.type == BT_CLASS)
6556     gfc_add_class_array_ref (actual->expr);
6557
6558   argse.data_not_needed = 1;
6559   if (gfc_is_alloc_class_array_function (actual->expr))
6560     {
6561       /* For functions that return a class array conv_expr_descriptor is not
6562          able to get the descriptor right.  Therefore this special case.  */
6563       gfc_conv_expr_reference (&argse, actual->expr);
6564       argse.expr = gfc_build_addr_expr (NULL_TREE,
6565                                         gfc_class_data_get (argse.expr));
6566     }
6567   else
6568     {
6569       argse.want_pointer = 1;
6570       gfc_conv_expr_descriptor (&argse, actual->expr);
6571     }
6572   gfc_add_block_to_block (&se->pre, &argse.pre);
6573   gfc_add_block_to_block (&se->post, &argse.post);
6574   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
6575
6576   /* Build the call to size0.  */
6577   fncall0 = build_call_expr_loc (input_location,
6578                              gfor_fndecl_size0, 1, arg1);
6579
6580   actual = actual->next;
6581
6582   if (actual->expr)
6583     {
6584       gfc_init_se (&argse, NULL);
6585       gfc_conv_expr_type (&argse, actual->expr,
6586                           gfc_array_index_type);
6587       gfc_add_block_to_block (&se->pre, &argse.pre);
6588
6589       /* Unusually, for an intrinsic, size does not exclude
6590          an optional arg2, so we must test for it.  */
6591       if (actual->expr->expr_type == EXPR_VARIABLE
6592             && actual->expr->symtree->n.sym->attr.dummy
6593             && actual->expr->symtree->n.sym->attr.optional)
6594         {
6595           tree tmp;
6596           /* Build the call to size1.  */
6597           fncall1 = build_call_expr_loc (input_location,
6598                                      gfor_fndecl_size1, 2,
6599                                      arg1, argse.expr);
6600
6601           gfc_init_se (&argse, NULL);
6602           argse.want_pointer = 1;
6603           argse.data_not_needed = 1;
6604           gfc_conv_expr (&argse, actual->expr);
6605           gfc_add_block_to_block (&se->pre, &argse.pre);
6606           tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
6607                                  argse.expr, null_pointer_node);
6608           tmp = gfc_evaluate_now (tmp, &se->pre);
6609           se->expr = fold_build3_loc (input_location, COND_EXPR,
6610                                       pvoid_type_node, tmp, fncall1, fncall0);
6611         }
6612       else
6613         {
6614           se->expr = NULL_TREE;
6615           argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
6616                                         gfc_array_index_type,
6617                                         argse.expr, gfc_index_one_node);
6618         }
6619     }
6620   else if (expr->value.function.actual->expr->rank == 1)
6621     {
6622       argse.expr = gfc_index_zero_node;
6623       se->expr = NULL_TREE;
6624     }
6625   else
6626     se->expr = fncall0;
6627
6628   if (se->expr == NULL_TREE)
6629     {
6630       tree ubound, lbound;
6631
6632       arg1 = build_fold_indirect_ref_loc (input_location,
6633                                       arg1);
6634       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
6635       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
6636       se->expr = fold_build2_loc (input_location, MINUS_EXPR,
6637                                   gfc_array_index_type, ubound, lbound);
6638       se->expr = fold_build2_loc (input_location, PLUS_EXPR,
6639                                   gfc_array_index_type,
6640                                   se->expr, gfc_index_one_node);
6641       se->expr = fold_build2_loc (input_location, MAX_EXPR,
6642                                   gfc_array_index_type, se->expr,
6643                                   gfc_index_zero_node);
6644     }
6645
6646   type = gfc_typenode_for_spec (&expr->ts);
6647   se->expr = convert (type, se->expr);
6648 }
6649
6650
6651 /* Helper function to compute the size of a character variable,
6652    excluding the terminating null characters.  The result has
6653    gfc_array_index_type type.  */
6654
6655 tree
6656 size_of_string_in_bytes (int kind, tree string_length)
6657 {
6658   tree bytesize;
6659   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
6660
6661   bytesize = build_int_cst (gfc_array_index_type,
6662                             gfc_character_kinds[i].bit_size / 8);
6663
6664   return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
6665                           bytesize,
6666                           fold_convert (gfc_array_index_type, string_length));
6667 }
6668
6669
6670 static void
6671 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
6672 {
6673   gfc_expr *arg;
6674   gfc_se argse;
6675   tree source_bytes;
6676   tree tmp;
6677   tree lower;
6678   tree upper;
6679   tree byte_size;
6680   int n;
6681
6682   gfc_init_se (&argse, NULL);
6683   arg = expr->value.function.actual->expr;
6684
6685   if (arg->rank || arg->ts.type == BT_ASSUMED)
6686     gfc_conv_expr_descriptor (&argse, arg);
6687   else
6688     gfc_conv_expr_reference (&argse, arg);
6689
6690   if (arg->ts.type == BT_ASSUMED)
6691     {
6692       /* This only works if an array descriptor has been passed; thus, extract
6693          the size from the descriptor.  */
6694       gcc_assert (TYPE_PRECISION (gfc_array_index_type)
6695                   == TYPE_PRECISION (size_type_node));
6696       tmp = arg->symtree->n.sym->backend_decl;
6697       tmp = DECL_LANG_SPECIFIC (tmp)
6698             && GFC_DECL_SAVED_DESCRIPTOR (tmp) != NULL_TREE
6699             ? GFC_DECL_SAVED_DESCRIPTOR (tmp) : tmp;
6700       if (POINTER_TYPE_P (TREE_TYPE (tmp)))
6701         tmp = build_fold_indirect_ref_loc (input_location, tmp);
6702       tmp = fold_convert (size_type_node, gfc_conv_descriptor_dtype (tmp));
6703       tmp = fold_build2_loc (input_location, RSHIFT_EXPR, TREE_TYPE (tmp), tmp,
6704                              build_int_cst (TREE_TYPE (tmp),
6705                                             GFC_DTYPE_SIZE_SHIFT));
6706       byte_size = fold_convert (gfc_array_index_type, tmp);
6707     }
6708   else if (arg->ts.type == BT_CLASS)
6709     {
6710       /* Conv_expr_descriptor returns a component_ref to _data component of the
6711          class object.  The class object may be a non-pointer object, e.g.
6712          located on the stack, or a memory location pointed to, e.g. a
6713          parameter, i.e., an indirect_ref.  */
6714       if (arg->rank < 0
6715           || (arg->rank > 0 && !VAR_P (argse.expr)
6716               && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
6717                    && GFC_DECL_CLASS (TREE_OPERAND (
6718                                         TREE_OPERAND (argse.expr, 0), 0)))
6719                   || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
6720         byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6721       else if (arg->rank > 0
6722                || (arg->rank == 0
6723                    && arg->ref && arg->ref->type == REF_COMPONENT))
6724         /* The scalarizer added an additional temp.  To get the class' vptr
6725            one has to look at the original backend_decl.  */
6726         byte_size = gfc_class_vtab_size_get (
6727               GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6728       else
6729         byte_size = gfc_class_vtab_size_get (argse.expr);
6730     }
6731   else
6732     {
6733       if (arg->ts.type == BT_CHARACTER)
6734         byte_size = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6735       else
6736         {
6737           if (arg->rank == 0)
6738             byte_size = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6739                                                                 argse.expr));
6740           else
6741             byte_size = gfc_get_element_type (TREE_TYPE (argse.expr));
6742           byte_size = fold_convert (gfc_array_index_type,
6743                                     size_in_bytes (byte_size));
6744         }
6745     }
6746
6747   if (arg->rank == 0)
6748     se->expr = byte_size;
6749   else
6750     {
6751       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
6752       gfc_add_modify (&argse.pre, source_bytes, byte_size);
6753
6754       if (arg->rank == -1)
6755         {
6756           tree cond, loop_var, exit_label;
6757           stmtblock_t body;
6758
6759           tmp = fold_convert (gfc_array_index_type,
6760                               gfc_conv_descriptor_rank (argse.expr));
6761           loop_var = gfc_create_var (gfc_array_index_type, "i");
6762           gfc_add_modify (&argse.pre, loop_var, gfc_index_zero_node);
6763           exit_label = gfc_build_label_decl (NULL_TREE);
6764
6765           /* Create loop:
6766              for (;;)
6767                 {
6768                   if (i >= rank)
6769                     goto exit;
6770                   source_bytes = source_bytes * array.dim[i].extent;
6771                   i = i + 1;
6772                 }
6773               exit:  */
6774           gfc_start_block (&body);
6775           cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
6776                                   loop_var, tmp);
6777           tmp = build1_v (GOTO_EXPR, exit_label);
6778           tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
6779                                  cond, tmp, build_empty_stmt (input_location));
6780           gfc_add_expr_to_block (&body, tmp);
6781
6782           lower = gfc_conv_descriptor_lbound_get (argse.expr, loop_var);
6783           upper = gfc_conv_descriptor_ubound_get (argse.expr, loop_var);
6784           tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6785           tmp = fold_build2_loc (input_location, MULT_EXPR,
6786                                  gfc_array_index_type, tmp, source_bytes);
6787           gfc_add_modify (&body, source_bytes, tmp);
6788
6789           tmp = fold_build2_loc (input_location, PLUS_EXPR,
6790                                  gfc_array_index_type, loop_var,
6791                                  gfc_index_one_node);
6792           gfc_add_modify_loc (input_location, &body, loop_var, tmp);
6793
6794           tmp = gfc_finish_block (&body);
6795
6796           tmp = fold_build1_loc (input_location, LOOP_EXPR, void_type_node,
6797                                  tmp);
6798           gfc_add_expr_to_block (&argse.pre, tmp);
6799
6800           tmp = build1_v (LABEL_EXPR, exit_label);
6801           gfc_add_expr_to_block (&argse.pre, tmp);
6802         }
6803       else
6804         {
6805           /* Obtain the size of the array in bytes.  */
6806           for (n = 0; n < arg->rank; n++)
6807             {
6808               tree idx;
6809               idx = gfc_rank_cst[n];
6810               lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
6811               upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
6812               tmp = gfc_conv_array_extent_dim (lower, upper, NULL);
6813               tmp = fold_build2_loc (input_location, MULT_EXPR,
6814                                      gfc_array_index_type, tmp, source_bytes);
6815               gfc_add_modify (&argse.pre, source_bytes, tmp);
6816             }
6817         }
6818       se->expr = source_bytes;
6819     }
6820
6821   gfc_add_block_to_block (&se->pre, &argse.pre);
6822 }
6823
6824
6825 static void
6826 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
6827 {
6828   gfc_expr *arg;
6829   gfc_se argse;
6830   tree type, result_type, tmp;
6831
6832   arg = expr->value.function.actual->expr;
6833
6834   gfc_init_se (&argse, NULL);
6835   result_type = gfc_get_int_type (expr->ts.kind);
6836
6837   if (arg->rank == 0)
6838     {
6839       if (arg->ts.type == BT_CLASS)
6840         {
6841           gfc_add_vptr_component (arg);
6842           gfc_add_size_component (arg);
6843           gfc_conv_expr (&argse, arg);
6844           tmp = fold_convert (result_type, argse.expr);
6845           goto done;
6846         }
6847
6848       gfc_conv_expr_reference (&argse, arg);
6849       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
6850                                                      argse.expr));
6851     }
6852   else
6853     {
6854       argse.want_pointer = 0;
6855       gfc_conv_expr_descriptor (&argse, arg);
6856       if (arg->ts.type == BT_CLASS)
6857         {
6858           if (arg->rank > 0)
6859             tmp = gfc_class_vtab_size_get (
6860                  GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
6861           else
6862             tmp = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
6863           tmp = fold_convert (result_type, tmp);
6864           goto done;
6865         }
6866       type = gfc_get_element_type (TREE_TYPE (argse.expr));
6867     }
6868
6869   /* Obtain the argument's word length.  */
6870   if (arg->ts.type == BT_CHARACTER)
6871     tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
6872   else
6873     tmp = size_in_bytes (type);
6874   tmp = fold_convert (result_type, tmp);
6875
6876 done:
6877   se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
6878                               build_int_cst (result_type, BITS_PER_UNIT));
6879   gfc_add_block_to_block (&se->pre, &argse.pre);
6880 }
6881
6882
6883 /* Intrinsic string comparison functions.  */
6884
6885 static void
6886 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
6887 {
6888   tree args[4];
6889
6890   gfc_conv_intrinsic_function_args (se, expr, args, 4);
6891
6892   se->expr
6893     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
6894                                 expr->value.function.actual->expr->ts.kind,
6895                                 op);
6896   se->expr = fold_build2_loc (input_location, op,
6897                               gfc_typenode_for_spec (&expr->ts), se->expr,
6898                               build_int_cst (TREE_TYPE (se->expr), 0));
6899 }
6900
6901 /* Generate a call to the adjustl/adjustr library function.  */
6902 static void
6903 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
6904 {
6905   tree args[3];
6906   tree len;
6907   tree type;
6908   tree var;
6909   tree tmp;
6910
6911   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
6912   len = args[1];
6913
6914   type = TREE_TYPE (args[2]);
6915   var = gfc_conv_string_tmp (se, type, len);
6916   args[0] = var;
6917
6918   tmp = build_call_expr_loc (input_location,
6919                          fndecl, 3, args[0], args[1], args[2]);
6920   gfc_add_expr_to_block (&se->pre, tmp);
6921   se->expr = var;
6922   se->string_length = len;
6923 }
6924
6925
6926 /* Generate code for the TRANSFER intrinsic:
6927         For scalar results:
6928           DEST = TRANSFER (SOURCE, MOLD)
6929         where:
6930           typeof<DEST> = typeof<MOLD>
6931         and:
6932           MOLD is scalar.
6933
6934         For array results:
6935           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
6936         where:
6937           typeof<DEST> = typeof<MOLD>
6938         and:
6939           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
6940               sizeof (DEST(0) * SIZE).  */
6941 static void
6942 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
6943 {
6944   tree tmp;
6945   tree tmpdecl;
6946   tree ptr;
6947   tree extent;
6948   tree source;
6949   tree source_type;
6950   tree source_bytes;
6951   tree mold_type;
6952   tree dest_word_len;
6953   tree size_words;
6954   tree size_bytes;
6955   tree upper;
6956   tree lower;
6957   tree stmt;
6958   gfc_actual_arglist *arg;
6959   gfc_se argse;
6960   gfc_array_info *info;
6961   stmtblock_t block;
6962   int n;
6963   bool scalar_mold;
6964   gfc_expr *source_expr, *mold_expr;
6965
6966   info = NULL;
6967   if (se->loop)
6968     info = &se->ss->info->data.array;
6969
6970   /* Convert SOURCE.  The output from this stage is:-
6971         source_bytes = length of the source in bytes
6972         source = pointer to the source data.  */
6973   arg = expr->value.function.actual;
6974   source_expr = arg->expr;
6975
6976   /* Ensure double transfer through LOGICAL preserves all
6977      the needed bits.  */
6978   if (arg->expr->expr_type == EXPR_FUNCTION
6979         && arg->expr->value.function.esym == NULL
6980         && arg->expr->value.function.isym != NULL
6981         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
6982         && arg->expr->ts.type == BT_LOGICAL
6983         && expr->ts.type != arg->expr->ts.type)
6984     arg->expr->value.function.name = "__transfer_in_transfer";
6985
6986   gfc_init_se (&argse, NULL);
6987
6988   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
6989
6990   /* Obtain the pointer to source and the length of source in bytes.  */
6991   if (arg->expr->rank == 0)
6992     {
6993       gfc_conv_expr_reference (&argse, arg->expr);
6994       if (arg->expr->ts.type == BT_CLASS)
6995         source = gfc_class_data_get (argse.expr);
6996       else
6997         source = argse.expr;
6998
6999       /* Obtain the source word length.  */
7000       switch (arg->expr->ts.type)
7001         {
7002         case BT_CHARACTER:
7003           tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7004                                          argse.string_length);
7005           break;
7006         case BT_CLASS:
7007           tmp = gfc_class_vtab_size_get (argse.expr);
7008           break;
7009         default:
7010           source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7011                                                                 source));
7012           tmp = fold_convert (gfc_array_index_type,
7013                               size_in_bytes (source_type));
7014           break;
7015         }
7016     }
7017   else
7018     {
7019       argse.want_pointer = 0;
7020       gfc_conv_expr_descriptor (&argse, arg->expr);
7021       source = gfc_conv_descriptor_data_get (argse.expr);
7022       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7023
7024       /* Repack the source if not simply contiguous.  */
7025       if (!gfc_is_simply_contiguous (arg->expr, false, true))
7026         {
7027           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
7028
7029           if (warn_array_temporaries)
7030             gfc_warning (OPT_Warray_temporaries,
7031                          "Creating array temporary at %L", &expr->where);
7032
7033           source = build_call_expr_loc (input_location,
7034                                     gfor_fndecl_in_pack, 1, tmp);
7035           source = gfc_evaluate_now (source, &argse.pre);
7036
7037           /* Free the temporary.  */
7038           gfc_start_block (&block);
7039           tmp = gfc_call_free (source);
7040           gfc_add_expr_to_block (&block, tmp);
7041           stmt = gfc_finish_block (&block);
7042
7043           /* Clean up if it was repacked.  */
7044           gfc_init_block (&block);
7045           tmp = gfc_conv_array_data (argse.expr);
7046           tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7047                                  source, tmp);
7048           tmp = build3_v (COND_EXPR, tmp, stmt,
7049                           build_empty_stmt (input_location));
7050           gfc_add_expr_to_block (&block, tmp);
7051           gfc_add_block_to_block (&block, &se->post);
7052           gfc_init_block (&se->post);
7053           gfc_add_block_to_block (&se->post, &block);
7054         }
7055
7056       /* Obtain the source word length.  */
7057       if (arg->expr->ts.type == BT_CHARACTER)
7058         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
7059                                        argse.string_length);
7060       else
7061         tmp = fold_convert (gfc_array_index_type,
7062                             size_in_bytes (source_type));
7063
7064       /* Obtain the size of the array in bytes.  */
7065       extent = gfc_create_var (gfc_array_index_type, NULL);
7066       for (n = 0; n < arg->expr->rank; n++)
7067         {
7068           tree idx;
7069           idx = gfc_rank_cst[n];
7070           gfc_add_modify (&argse.pre, source_bytes, tmp);
7071           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
7072           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
7073           tmp = fold_build2_loc (input_location, MINUS_EXPR,
7074                                  gfc_array_index_type, upper, lower);
7075           gfc_add_modify (&argse.pre, extent, tmp);
7076           tmp = fold_build2_loc (input_location, PLUS_EXPR,
7077                                  gfc_array_index_type, extent,
7078                                  gfc_index_one_node);
7079           tmp = fold_build2_loc (input_location, MULT_EXPR,
7080                                  gfc_array_index_type, tmp, source_bytes);
7081         }
7082     }
7083
7084   gfc_add_modify (&argse.pre, source_bytes, tmp);
7085   gfc_add_block_to_block (&se->pre, &argse.pre);
7086   gfc_add_block_to_block (&se->post, &argse.post);
7087
7088   /* Now convert MOLD.  The outputs are:
7089         mold_type = the TREE type of MOLD
7090         dest_word_len = destination word length in bytes.  */
7091   arg = arg->next;
7092   mold_expr = arg->expr;
7093
7094   gfc_init_se (&argse, NULL);
7095
7096   scalar_mold = arg->expr->rank == 0;
7097
7098   if (arg->expr->rank == 0)
7099     {
7100       gfc_conv_expr_reference (&argse, arg->expr);
7101       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
7102                                                           argse.expr));
7103     }
7104   else
7105     {
7106       gfc_init_se (&argse, NULL);
7107       argse.want_pointer = 0;
7108       gfc_conv_expr_descriptor (&argse, arg->expr);
7109       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
7110     }
7111
7112   gfc_add_block_to_block (&se->pre, &argse.pre);
7113   gfc_add_block_to_block (&se->post, &argse.post);
7114
7115   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
7116     {
7117       /* If this TRANSFER is nested in another TRANSFER, use a type
7118          that preserves all bits.  */
7119       if (arg->expr->ts.type == BT_LOGICAL)
7120         mold_type = gfc_get_int_type (arg->expr->ts.kind);
7121     }
7122
7123   /* Obtain the destination word length.  */
7124   switch (arg->expr->ts.type)
7125     {
7126     case BT_CHARACTER:
7127       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
7128       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
7129       break;
7130     case BT_CLASS:
7131       tmp = gfc_class_vtab_size_get (argse.expr);
7132       break;
7133     default:
7134       tmp = fold_convert (gfc_array_index_type, size_in_bytes (mold_type));
7135       break;
7136     }
7137   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
7138   gfc_add_modify (&se->pre, dest_word_len, tmp);
7139
7140   /* Finally convert SIZE, if it is present.  */
7141   arg = arg->next;
7142   size_words = gfc_create_var (gfc_array_index_type, NULL);
7143
7144   if (arg->expr)
7145     {
7146       gfc_init_se (&argse, NULL);
7147       gfc_conv_expr_reference (&argse, arg->expr);
7148       tmp = convert (gfc_array_index_type,
7149                      build_fold_indirect_ref_loc (input_location,
7150                                               argse.expr));
7151       gfc_add_block_to_block (&se->pre, &argse.pre);
7152       gfc_add_block_to_block (&se->post, &argse.post);
7153     }
7154   else
7155     tmp = NULL_TREE;
7156
7157   /* Separate array and scalar results.  */
7158   if (scalar_mold && tmp == NULL_TREE)
7159     goto scalar_transfer;
7160
7161   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
7162   if (tmp != NULL_TREE)
7163     tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
7164                            tmp, dest_word_len);
7165   else
7166     tmp = source_bytes;
7167
7168   gfc_add_modify (&se->pre, size_bytes, tmp);
7169   gfc_add_modify (&se->pre, size_words,
7170                        fold_build2_loc (input_location, CEIL_DIV_EXPR,
7171                                         gfc_array_index_type,
7172                                         size_bytes, dest_word_len));
7173
7174   /* Evaluate the bounds of the result.  If the loop range exists, we have
7175      to check if it is too large.  If so, we modify loop->to be consistent
7176      with min(size, size(source)).  Otherwise, size is made consistent with
7177      the loop range, so that the right number of bytes is transferred.*/
7178   n = se->loop->order[0];
7179   if (se->loop->to[n] != NULL_TREE)
7180     {
7181       tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7182                              se->loop->to[n], se->loop->from[n]);
7183       tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7184                              tmp, gfc_index_one_node);
7185       tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7186                          tmp, size_words);
7187       gfc_add_modify (&se->pre, size_words, tmp);
7188       gfc_add_modify (&se->pre, size_bytes,
7189                            fold_build2_loc (input_location, MULT_EXPR,
7190                                             gfc_array_index_type,
7191                                             size_words, dest_word_len));
7192       upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
7193                                size_words, se->loop->from[n]);
7194       upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7195                                upper, gfc_index_one_node);
7196     }
7197   else
7198     {
7199       upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
7200                                size_words, gfc_index_one_node);
7201       se->loop->from[n] = gfc_index_zero_node;
7202     }
7203
7204   se->loop->to[n] = upper;
7205
7206   /* Build a destination descriptor, using the pointer, source, as the
7207      data field.  */
7208   gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
7209                                NULL_TREE, false, true, false, &expr->where);
7210
7211   /* Cast the pointer to the result.  */
7212   tmp = gfc_conv_descriptor_data_get (info->descriptor);
7213   tmp = fold_convert (pvoid_type_node, tmp);
7214
7215   /* Use memcpy to do the transfer.  */
7216   tmp
7217     = build_call_expr_loc (input_location,
7218                            builtin_decl_explicit (BUILT_IN_MEMCPY), 3, tmp,
7219                            fold_convert (pvoid_type_node, source),
7220                            fold_convert (size_type_node,
7221                                          fold_build2_loc (input_location,
7222                                                           MIN_EXPR,
7223                                                           gfc_array_index_type,
7224                                                           size_bytes,
7225                                                           source_bytes)));
7226   gfc_add_expr_to_block (&se->pre, tmp);
7227
7228   se->expr = info->descriptor;
7229   if (expr->ts.type == BT_CHARACTER)
7230     se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7231
7232   return;
7233
7234 /* Deal with scalar results.  */
7235 scalar_transfer:
7236   extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
7237                             dest_word_len, source_bytes);
7238   extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
7239                             extent, gfc_index_zero_node);
7240
7241   if (expr->ts.type == BT_CHARACTER)
7242     {
7243       tree direct, indirect, free;
7244
7245       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
7246       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
7247                                 "transfer");
7248
7249       /* If source is longer than the destination, use a pointer to
7250          the source directly.  */
7251       gfc_init_block (&block);
7252       gfc_add_modify (&block, tmpdecl, ptr);
7253       direct = gfc_finish_block (&block);
7254
7255       /* Otherwise, allocate a string with the length of the destination
7256          and copy the source into it.  */
7257       gfc_init_block (&block);
7258       tmp = gfc_get_pchar_type (expr->ts.kind);
7259       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
7260       gfc_add_modify (&block, tmpdecl,
7261                       fold_convert (TREE_TYPE (ptr), tmp));
7262       tmp = build_call_expr_loc (input_location,
7263                              builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7264                              fold_convert (pvoid_type_node, tmpdecl),
7265                              fold_convert (pvoid_type_node, ptr),
7266                              fold_convert (size_type_node, extent));
7267       gfc_add_expr_to_block (&block, tmp);
7268       indirect = gfc_finish_block (&block);
7269
7270       /* Wrap it up with the condition.  */
7271       tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
7272                              dest_word_len, source_bytes);
7273       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
7274       gfc_add_expr_to_block (&se->pre, tmp);
7275
7276       /* Free the temporary string, if necessary.  */
7277       free = gfc_call_free (tmpdecl);
7278       tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7279                              dest_word_len, source_bytes);
7280       tmp = build3_v (COND_EXPR, tmp, free, build_empty_stmt (input_location));
7281       gfc_add_expr_to_block (&se->post, tmp);
7282
7283       se->expr = tmpdecl;
7284       se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
7285     }
7286   else
7287     {
7288       tmpdecl = gfc_create_var (mold_type, "transfer");
7289
7290       ptr = convert (build_pointer_type (mold_type), source);
7291
7292       /* For CLASS results, allocate the needed memory first.  */
7293       if (mold_expr->ts.type == BT_CLASS)
7294         {
7295           tree cdata;
7296           cdata = gfc_class_data_get (tmpdecl);
7297           tmp = gfc_call_malloc (&se->pre, TREE_TYPE (cdata), dest_word_len);
7298           gfc_add_modify (&se->pre, cdata, tmp);
7299         }
7300
7301       /* Use memcpy to do the transfer.  */
7302       if (mold_expr->ts.type == BT_CLASS)
7303         tmp = gfc_class_data_get (tmpdecl);
7304       else
7305         tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
7306
7307       tmp = build_call_expr_loc (input_location,
7308                              builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
7309                              fold_convert (pvoid_type_node, tmp),
7310                              fold_convert (pvoid_type_node, ptr),
7311                              fold_convert (size_type_node, extent));
7312       gfc_add_expr_to_block (&se->pre, tmp);
7313
7314       /* For CLASS results, set the _vptr.  */
7315       if (mold_expr->ts.type == BT_CLASS)
7316         {
7317           tree vptr;
7318           gfc_symbol *vtab;
7319           vptr = gfc_class_vptr_get (tmpdecl);
7320           vtab = gfc_find_derived_vtab (source_expr->ts.u.derived);
7321           gcc_assert (vtab);
7322           tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
7323           gfc_add_modify (&se->pre, vptr, fold_convert (TREE_TYPE (vptr), tmp));
7324         }
7325
7326       se->expr = tmpdecl;
7327     }
7328 }
7329
7330
7331 /* Generate a call to caf_is_present.  */
7332
7333 static tree
7334 trans_caf_is_present (gfc_se *se, gfc_expr *expr)
7335 {
7336   tree caf_reference, caf_decl, token, image_index;
7337
7338   /* Compile the reference chain.  */
7339   caf_reference = conv_expr_ref_to_caf_ref (&se->pre, expr);
7340   gcc_assert (caf_reference != NULL_TREE);
7341
7342   caf_decl = gfc_get_tree_for_caf_expr (expr);
7343   if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
7344     caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
7345   image_index = gfc_caf_get_image_index (&se->pre, expr, caf_decl);
7346   gfc_get_caf_token_offset (se, &token, NULL, caf_decl, NULL,
7347                             expr);
7348
7349   return build_call_expr_loc (input_location, gfor_fndecl_caf_is_present,
7350                               3, token, image_index, caf_reference);
7351 }
7352
7353
7354 /* Test whether this ref-chain refs this image only.  */
7355
7356 static bool
7357 caf_this_image_ref (gfc_ref *ref)
7358 {
7359   for ( ; ref; ref = ref->next)
7360     if (ref->type == REF_ARRAY && ref->u.ar.codimen)
7361       return ref->u.ar.dimen_type[ref->u.ar.dimen] == DIMEN_THIS_IMAGE;
7362
7363   return false;
7364 }
7365
7366
7367 /* Generate code for the ALLOCATED intrinsic.
7368    Generate inline code that directly check the address of the argument.  */
7369
7370 static void
7371 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
7372 {
7373   gfc_actual_arglist *arg1;
7374   gfc_se arg1se;
7375   tree tmp;
7376   symbol_attribute caf_attr;
7377
7378   gfc_init_se (&arg1se, NULL);
7379   arg1 = expr->value.function.actual;
7380
7381   if (arg1->expr->ts.type == BT_CLASS)
7382     {
7383       /* Make sure that class array expressions have both a _data
7384          component reference and an array reference....  */
7385       if (CLASS_DATA (arg1->expr)->attr.dimension)
7386         gfc_add_class_array_ref (arg1->expr);
7387       /* .... whilst scalars only need the _data component.  */
7388       else
7389         gfc_add_data_component (arg1->expr);
7390     }
7391
7392   /* When arg1 references an allocatable component in a coarray, then call
7393      the caf-library function caf_is_present ().  */
7394   if (flag_coarray == GFC_FCOARRAY_LIB && arg1->expr->expr_type == EXPR_FUNCTION
7395       && arg1->expr->value.function.isym
7396       && arg1->expr->value.function.isym->id == GFC_ISYM_CAF_GET)
7397     caf_attr = gfc_caf_attr (arg1->expr->value.function.actual->expr);
7398   else
7399     gfc_clear_attr (&caf_attr);
7400   if (flag_coarray == GFC_FCOARRAY_LIB && caf_attr.codimension
7401       && !caf_this_image_ref (arg1->expr->value.function.actual->expr->ref))
7402     tmp = trans_caf_is_present (se, arg1->expr->value.function.actual->expr);
7403   else
7404     {
7405       if (arg1->expr->rank == 0)
7406         {
7407           /* Allocatable scalar.  */
7408           arg1se.want_pointer = 1;
7409           gfc_conv_expr (&arg1se, arg1->expr);
7410           tmp = arg1se.expr;
7411         }
7412       else
7413         {
7414           /* Allocatable array.  */
7415           arg1se.descriptor_only = 1;
7416           gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7417           tmp = gfc_conv_descriptor_data_get (arg1se.expr);
7418         }
7419
7420       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
7421                              fold_convert (TREE_TYPE (tmp), null_pointer_node));
7422     }
7423   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7424 }
7425
7426
7427 /* Generate code for the ASSOCIATED intrinsic.
7428    If both POINTER and TARGET are arrays, generate a call to library function
7429    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
7430    In other cases, generate inline code that directly compare the address of
7431    POINTER with the address of TARGET.  */
7432
7433 static void
7434 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
7435 {
7436   gfc_actual_arglist *arg1;
7437   gfc_actual_arglist *arg2;
7438   gfc_se arg1se;
7439   gfc_se arg2se;
7440   tree tmp2;
7441   tree tmp;
7442   tree nonzero_charlen;
7443   tree nonzero_arraylen;
7444   gfc_ss *ss;
7445   bool scalar;
7446
7447   gfc_init_se (&arg1se, NULL);
7448   gfc_init_se (&arg2se, NULL);
7449   arg1 = expr->value.function.actual;
7450   arg2 = arg1->next;
7451
7452   /* Check whether the expression is a scalar or not; we cannot use
7453      arg1->expr->rank as it can be nonzero for proc pointers.  */
7454   ss = gfc_walk_expr (arg1->expr);
7455   scalar = ss == gfc_ss_terminator;
7456   if (!scalar)
7457     gfc_free_ss_chain (ss);
7458
7459   if (!arg2->expr)
7460     {
7461       /* No optional target.  */
7462       if (scalar)
7463         {
7464           /* A pointer to a scalar.  */
7465           arg1se.want_pointer = 1;
7466           gfc_conv_expr (&arg1se, arg1->expr);
7467           if (arg1->expr->symtree->n.sym->attr.proc_pointer
7468               && arg1->expr->symtree->n.sym->attr.dummy)
7469             arg1se.expr = build_fold_indirect_ref_loc (input_location,
7470                                                        arg1se.expr);
7471           if (arg1->expr->ts.type == BT_CLASS)
7472             {
7473               tmp2 = gfc_class_data_get (arg1se.expr);
7474               if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
7475                 tmp2 = gfc_conv_descriptor_data_get (tmp2);
7476             }
7477           else
7478             tmp2 = arg1se.expr;
7479         }
7480       else
7481         {
7482           /* A pointer to an array.  */
7483           gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7484           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
7485         }
7486       gfc_add_block_to_block (&se->pre, &arg1se.pre);
7487       gfc_add_block_to_block (&se->post, &arg1se.post);
7488       tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
7489                              fold_convert (TREE_TYPE (tmp2), null_pointer_node));
7490       se->expr = tmp;
7491     }
7492   else
7493     {
7494       /* An optional target.  */
7495       if (arg2->expr->ts.type == BT_CLASS)
7496         gfc_add_data_component (arg2->expr);
7497
7498       nonzero_charlen = NULL_TREE;
7499       if (arg1->expr->ts.type == BT_CHARACTER)
7500         nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
7501                                            boolean_type_node,
7502                                            arg1->expr->ts.u.cl->backend_decl,
7503                                            integer_zero_node);
7504       if (scalar)
7505         {
7506           /* A pointer to a scalar.  */
7507           arg1se.want_pointer = 1;
7508           gfc_conv_expr (&arg1se, arg1->expr);
7509           if (arg1->expr->symtree->n.sym->attr.proc_pointer
7510               && arg1->expr->symtree->n.sym->attr.dummy)
7511             arg1se.expr = build_fold_indirect_ref_loc (input_location,
7512                                                        arg1se.expr);
7513           if (arg1->expr->ts.type == BT_CLASS)
7514             arg1se.expr = gfc_class_data_get (arg1se.expr);
7515
7516           arg2se.want_pointer = 1;
7517           gfc_conv_expr (&arg2se, arg2->expr);
7518           if (arg2->expr->symtree->n.sym->attr.proc_pointer
7519               && arg2->expr->symtree->n.sym->attr.dummy)
7520             arg2se.expr = build_fold_indirect_ref_loc (input_location,
7521                                                        arg2se.expr);
7522           gfc_add_block_to_block (&se->pre, &arg1se.pre);
7523           gfc_add_block_to_block (&se->post, &arg1se.post);
7524           gfc_add_block_to_block (&se->pre, &arg2se.pre);
7525           gfc_add_block_to_block (&se->post, &arg2se.post);
7526           tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
7527                                  arg1se.expr, arg2se.expr);
7528           tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7529                                   arg1se.expr, null_pointer_node);
7530           se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7531                                       boolean_type_node, tmp, tmp2);
7532         }
7533       else
7534         {
7535           /* An array pointer of zero length is not associated if target is
7536              present.  */
7537           arg1se.descriptor_only = 1;
7538           gfc_conv_expr_lhs (&arg1se, arg1->expr);
7539           if (arg1->expr->rank == -1)
7540             {
7541               tmp = gfc_conv_descriptor_rank (arg1se.expr);
7542               tmp = fold_build2_loc (input_location, MINUS_EXPR,
7543                                      TREE_TYPE (tmp), tmp, gfc_index_one_node);
7544             }
7545           else
7546             tmp = gfc_rank_cst[arg1->expr->rank - 1];
7547           tmp = gfc_conv_descriptor_stride_get (arg1se.expr, tmp);
7548           nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
7549                                               boolean_type_node, tmp,
7550                                               build_int_cst (TREE_TYPE (tmp), 0));
7551
7552           /* A pointer to an array, call library function _gfor_associated.  */
7553           arg1se.want_pointer = 1;
7554           gfc_conv_expr_descriptor (&arg1se, arg1->expr);
7555
7556           arg2se.want_pointer = 1;
7557           gfc_conv_expr_descriptor (&arg2se, arg2->expr);
7558           gfc_add_block_to_block (&se->pre, &arg2se.pre);
7559           gfc_add_block_to_block (&se->post, &arg2se.post);
7560           se->expr = build_call_expr_loc (input_location,
7561                                       gfor_fndecl_associated, 2,
7562                                       arg1se.expr, arg2se.expr);
7563           se->expr = convert (boolean_type_node, se->expr);
7564           se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7565                                       boolean_type_node, se->expr,
7566                                       nonzero_arraylen);
7567         }
7568
7569       /* If target is present zero character length pointers cannot
7570          be associated.  */
7571       if (nonzero_charlen != NULL_TREE)
7572         se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
7573                                     boolean_type_node,
7574                                     se->expr, nonzero_charlen);
7575     }
7576
7577   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7578 }
7579
7580
7581 /* Generate code for the SAME_TYPE_AS intrinsic.
7582    Generate inline code that directly checks the vindices.  */
7583
7584 static void
7585 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
7586 {
7587   gfc_expr *a, *b;
7588   gfc_se se1, se2;
7589   tree tmp;
7590   tree conda = NULL_TREE, condb = NULL_TREE;
7591
7592   gfc_init_se (&se1, NULL);
7593   gfc_init_se (&se2, NULL);
7594
7595   a = expr->value.function.actual->expr;
7596   b = expr->value.function.actual->next->expr;
7597
7598   if (UNLIMITED_POLY (a))
7599     {
7600       tmp = gfc_class_vptr_get (a->symtree->n.sym->backend_decl);
7601       conda = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7602                                tmp, build_int_cst (TREE_TYPE (tmp), 0));
7603     }
7604
7605   if (UNLIMITED_POLY (b))
7606     {
7607       tmp = gfc_class_vptr_get (b->symtree->n.sym->backend_decl);
7608       condb = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
7609                                tmp, build_int_cst (TREE_TYPE (tmp), 0));
7610     }
7611
7612   if (a->ts.type == BT_CLASS)
7613     {
7614       gfc_add_vptr_component (a);
7615       gfc_add_hash_component (a);
7616     }
7617   else if (a->ts.type == BT_DERIVED)
7618     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7619                           a->ts.u.derived->hash_value);
7620
7621   if (b->ts.type == BT_CLASS)
7622     {
7623       gfc_add_vptr_component (b);
7624       gfc_add_hash_component (b);
7625     }
7626   else if (b->ts.type == BT_DERIVED)
7627     b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
7628                           b->ts.u.derived->hash_value);
7629
7630   gfc_conv_expr (&se1, a);
7631   gfc_conv_expr (&se2, b);
7632
7633   tmp = fold_build2_loc (input_location, EQ_EXPR,
7634                          boolean_type_node, se1.expr,
7635                          fold_convert (TREE_TYPE (se1.expr), se2.expr));
7636
7637   if (conda)
7638     tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7639                            boolean_type_node, conda, tmp);
7640
7641   if (condb)
7642     tmp = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
7643                            boolean_type_node, condb, tmp);
7644
7645   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
7646 }
7647
7648
7649 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
7650
7651 static void
7652 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
7653 {
7654   tree args[2];
7655
7656   gfc_conv_intrinsic_function_args (se, expr, args, 2);
7657   se->expr = build_call_expr_loc (input_location,
7658                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
7659   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
7660 }
7661
7662
7663 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
7664
7665 static void
7666 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
7667 {
7668   tree arg, type;
7669
7670   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
7671
7672   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
7673   type = gfc_get_int_type (4);
7674   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
7675
7676   /* Convert it to the required type.  */
7677   type = gfc_typenode_for_spec (&expr->ts);
7678   se->expr = build_call_expr_loc (input_location,
7679                               gfor_fndecl_si_kind, 1, arg);
7680   se->expr = fold_convert (type, se->expr);
7681 }
7682
7683
7684 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function.  */
7685
7686 static void
7687 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
7688 {
7689   gfc_actual_arglist *actual;
7690   tree type;
7691   gfc_se argse;
7692   vec<tree, va_gc> *args = NULL;
7693
7694   for (actual = expr->value.function.actual; actual; actual = actual->next)
7695     {
7696       gfc_init_se (&argse, se);
7697
7698       /* Pass a NULL pointer for an absent arg.  */
7699       if (actual->expr == NULL)
7700         argse.expr = null_pointer_node;
7701       else
7702         {
7703           gfc_typespec ts;
7704           gfc_clear_ts (&ts);
7705
7706           if (actual->expr->ts.kind != gfc_c_int_kind)
7707             {
7708               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
7709               ts.type = BT_INTEGER;
7710               ts.kind = gfc_c_int_kind;
7711               gfc_convert_type (actual->expr, &ts, 2);
7712             }
7713           gfc_conv_expr_reference (&argse, actual->expr);
7714         }
7715
7716       gfc_add_block_to_block (&se->pre, &argse.pre);
7717       gfc_add_block_to_block (&se->post, &argse.post);
7718       vec_safe_push (args, argse.expr);
7719     }
7720
7721   /* Convert it to the required type.  */
7722   type = gfc_typenode_for_spec (&expr->ts);
7723   se->expr = build_call_expr_loc_vec (input_location,
7724                                       gfor_fndecl_sr_kind, args);
7725   se->expr = fold_convert (type, se->expr);
7726 }
7727
7728
7729 /* Generate code for TRIM (A) intrinsic function.  */
7730
7731 static void
7732 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
7733 {
7734   tree var;
7735   tree len;
7736   tree addr;
7737   tree tmp;
7738   tree cond;
7739   tree fndecl;
7740   tree function;
7741   tree *args;
7742   unsigned int num_args;
7743
7744   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
7745   args = XALLOCAVEC (tree, num_args);
7746
7747   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
7748   addr = gfc_build_addr_expr (ppvoid_type_node, var);
7749   len = gfc_create_var (gfc_charlen_type_node, "len");
7750
7751   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
7752   args[0] = gfc_build_addr_expr (NULL_TREE, len);
7753   args[1] = addr;
7754
7755   if (expr->ts.kind == 1)
7756     function = gfor_fndecl_string_trim;
7757   else if (expr->ts.kind == 4)
7758     function = gfor_fndecl_string_trim_char4;
7759   else
7760     gcc_unreachable ();
7761
7762   fndecl = build_addr (function);
7763   tmp = build_call_array_loc (input_location,
7764                           TREE_TYPE (TREE_TYPE (function)), fndecl,
7765                           num_args, args);
7766   gfc_add_expr_to_block (&se->pre, tmp);
7767
7768   /* Free the temporary afterwards, if necessary.  */
7769   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7770                           len, build_int_cst (TREE_TYPE (len), 0));
7771   tmp = gfc_call_free (var);
7772   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
7773   gfc_add_expr_to_block (&se->post, tmp);
7774
7775   se->expr = var;
7776   se->string_length = len;
7777 }
7778
7779
7780 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
7781
7782 static void
7783 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
7784 {
7785   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
7786   tree type, cond, tmp, count, exit_label, n, max, largest;
7787   tree size;
7788   stmtblock_t block, body;
7789   int i;
7790
7791   /* We store in charsize the size of a character.  */
7792   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
7793   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
7794
7795   /* Get the arguments.  */
7796   gfc_conv_intrinsic_function_args (se, expr, args, 3);
7797   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
7798   src = args[1];
7799   ncopies = gfc_evaluate_now (args[2], &se->pre);
7800   ncopies_type = TREE_TYPE (ncopies);
7801
7802   /* Check that NCOPIES is not negative.  */
7803   cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
7804                           build_int_cst (ncopies_type, 0));
7805   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7806                            "Argument NCOPIES of REPEAT intrinsic is negative "
7807                            "(its value is %ld)",
7808                            fold_convert (long_integer_type_node, ncopies));
7809
7810   /* If the source length is zero, any non negative value of NCOPIES
7811      is valid, and nothing happens.  */
7812   n = gfc_create_var (ncopies_type, "ncopies");
7813   cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7814                           build_int_cst (size_type_node, 0));
7815   tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
7816                          build_int_cst (ncopies_type, 0), ncopies);
7817   gfc_add_modify (&se->pre, n, tmp);
7818   ncopies = n;
7819
7820   /* Check that ncopies is not too large: ncopies should be less than
7821      (or equal to) MAX / slen, where MAX is the maximal integer of
7822      the gfc_charlen_type_node type.  If slen == 0, we need a special
7823      case to avoid the division by zero.  */
7824   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
7825   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
7826   max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
7827                           fold_convert (size_type_node, max), slen);
7828   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
7829               ? size_type_node : ncopies_type;
7830   cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
7831                           fold_convert (largest, ncopies),
7832                           fold_convert (largest, max));
7833   tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
7834                          build_int_cst (size_type_node, 0));
7835   cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
7836                           boolean_false_node, cond);
7837   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
7838                            "Argument NCOPIES of REPEAT intrinsic is too large");
7839
7840   /* Compute the destination length.  */
7841   dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7842                           fold_convert (gfc_charlen_type_node, slen),
7843                           fold_convert (gfc_charlen_type_node, ncopies));
7844   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
7845   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
7846
7847   /* Generate the code to do the repeat operation:
7848        for (i = 0; i < ncopies; i++)
7849          memmove (dest + (i * slen * size), src, slen*size);  */
7850   gfc_start_block (&block);
7851   count = gfc_create_var (ncopies_type, "count");
7852   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
7853   exit_label = gfc_build_label_decl (NULL_TREE);
7854
7855   /* Start the loop body.  */
7856   gfc_start_block (&body);
7857
7858   /* Exit the loop if count >= ncopies.  */
7859   cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
7860                           ncopies);
7861   tmp = build1_v (GOTO_EXPR, exit_label);
7862   TREE_USED (exit_label) = 1;
7863   tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
7864                          build_empty_stmt (input_location));
7865   gfc_add_expr_to_block (&body, tmp);
7866
7867   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
7868   tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7869                          fold_convert (gfc_charlen_type_node, slen),
7870                          fold_convert (gfc_charlen_type_node, count));
7871   tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
7872                          tmp, fold_convert (gfc_charlen_type_node, size));
7873   tmp = fold_build_pointer_plus_loc (input_location,
7874                                      fold_convert (pvoid_type_node, dest), tmp);
7875   tmp = build_call_expr_loc (input_location,
7876                              builtin_decl_explicit (BUILT_IN_MEMMOVE),
7877                              3, tmp, src,
7878                              fold_build2_loc (input_location, MULT_EXPR,
7879                                               size_type_node, slen,
7880                                               fold_convert (size_type_node,
7881                                                             size)));
7882   gfc_add_expr_to_block (&body, tmp);
7883
7884   /* Increment count.  */
7885   tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
7886                          count, build_int_cst (TREE_TYPE (count), 1));
7887   gfc_add_modify (&body, count, tmp);
7888
7889   /* Build the loop.  */
7890   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
7891   gfc_add_expr_to_block (&block, tmp);
7892
7893   /* Add the exit label.  */
7894   tmp = build1_v (LABEL_EXPR, exit_label);
7895   gfc_add_expr_to_block (&block, tmp);
7896
7897   /* Finish the block.  */
7898   tmp = gfc_finish_block (&block);
7899   gfc_add_expr_to_block (&se->pre, tmp);
7900
7901   /* Set the result value.  */
7902   se->expr = dest;
7903   se->string_length = dlen;
7904 }
7905
7906
7907 /* Generate code for the IARGC intrinsic.  */
7908
7909 static void
7910 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
7911 {
7912   tree tmp;
7913   tree fndecl;
7914   tree type;
7915
7916   /* Call the library function.  This always returns an INTEGER(4).  */
7917   fndecl = gfor_fndecl_iargc;
7918   tmp = build_call_expr_loc (input_location,
7919                          fndecl, 0);
7920
7921   /* Convert it to the required type.  */
7922   type = gfc_typenode_for_spec (&expr->ts);
7923   tmp = fold_convert (type, tmp);
7924
7925   se->expr = tmp;
7926 }
7927
7928
7929 /* The loc intrinsic returns the address of its argument as
7930    gfc_index_integer_kind integer.  */
7931
7932 static void
7933 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
7934 {
7935   tree temp_var;
7936   gfc_expr *arg_expr;
7937
7938   gcc_assert (!se->ss);
7939
7940   arg_expr = expr->value.function.actual->expr;
7941   if (arg_expr->rank == 0)
7942     {
7943       if (arg_expr->ts.type == BT_CLASS)
7944         gfc_add_data_component (arg_expr);
7945       gfc_conv_expr_reference (se, arg_expr);
7946     }
7947   else
7948     gfc_conv_array_parameter (se, arg_expr, true, NULL, NULL, NULL);
7949   se->expr = convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
7950
7951   /* Create a temporary variable for loc return value.  Without this,
7952      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
7953   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
7954   gfc_add_modify (&se->pre, temp_var, se->expr);
7955   se->expr = temp_var;
7956 }
7957
7958
7959 /* The following routine generates code for the intrinsic
7960    functions from the ISO_C_BINDING module:
7961     * C_LOC
7962     * C_FUNLOC
7963     * C_ASSOCIATED  */
7964
7965 static void
7966 conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
7967 {
7968   gfc_actual_arglist *arg = expr->value.function.actual;
7969
7970   if (expr->value.function.isym->id == GFC_ISYM_C_LOC)
7971     {
7972       if (arg->expr->rank == 0)
7973         gfc_conv_expr_reference (se, arg->expr);
7974       else if (gfc_is_simply_contiguous (arg->expr, false, false))
7975         gfc_conv_array_parameter (se, arg->expr, true, NULL, NULL, NULL);
7976       else
7977         {
7978           gfc_conv_expr_descriptor (se, arg->expr);
7979           se->expr = gfc_conv_descriptor_data_get (se->expr);
7980         }
7981
7982       /* TODO -- the following two lines shouldn't be necessary, but if
7983          they're removed, a bug is exposed later in the code path.
7984          This workaround was thus introduced, but will have to be
7985          removed; please see PR 35150 for details about the issue.  */
7986       se->expr = convert (pvoid_type_node, se->expr);
7987       se->expr = gfc_evaluate_now (se->expr, &se->pre);
7988     }
7989   else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
7990     gfc_conv_expr_reference (se, arg->expr);
7991   else if (expr->value.function.isym->id == GFC_ISYM_C_ASSOCIATED)
7992     {
7993       gfc_se arg1se;
7994       gfc_se arg2se;
7995
7996       /* Build the addr_expr for the first argument.  The argument is
7997          already an *address* so we don't need to set want_pointer in
7998          the gfc_se.  */
7999       gfc_init_se (&arg1se, NULL);
8000       gfc_conv_expr (&arg1se, arg->expr);
8001       gfc_add_block_to_block (&se->pre, &arg1se.pre);
8002       gfc_add_block_to_block (&se->post, &arg1se.post);
8003
8004       /* See if we were given two arguments.  */
8005       if (arg->next->expr == NULL)
8006         /* Only given one arg so generate a null and do a
8007            not-equal comparison against the first arg.  */
8008         se->expr = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8009                                     arg1se.expr,
8010                                     fold_convert (TREE_TYPE (arg1se.expr),
8011                                                   null_pointer_node));
8012       else
8013         {
8014           tree eq_expr;
8015           tree not_null_expr;
8016
8017           /* Given two arguments so build the arg2se from second arg.  */
8018           gfc_init_se (&arg2se, NULL);
8019           gfc_conv_expr (&arg2se, arg->next->expr);
8020           gfc_add_block_to_block (&se->pre, &arg2se.pre);
8021           gfc_add_block_to_block (&se->post, &arg2se.post);
8022
8023           /* Generate test to compare that the two args are equal.  */
8024           eq_expr = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
8025                                      arg1se.expr, arg2se.expr);
8026           /* Generate test to ensure that the first arg is not null.  */
8027           not_null_expr = fold_build2_loc (input_location, NE_EXPR,
8028                                            boolean_type_node,
8029                                            arg1se.expr, null_pointer_node);
8030
8031           /* Finally, the generated test must check that both arg1 is not
8032              NULL and that it is equal to the second arg.  */
8033           se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8034                                       boolean_type_node,
8035                                       not_null_expr, eq_expr);
8036         }
8037     }
8038   else
8039     gcc_unreachable ();
8040 }
8041
8042
8043 /* The following routine generates code for the intrinsic
8044    subroutines from the ISO_C_BINDING module:
8045     * C_F_POINTER
8046     * C_F_PROCPOINTER.  */
8047
8048 static tree
8049 conv_isocbinding_subroutine (gfc_code *code)
8050 {
8051   gfc_se se;
8052   gfc_se cptrse;
8053   gfc_se fptrse;
8054   gfc_se shapese;
8055   gfc_ss *shape_ss;
8056   tree desc, dim, tmp, stride, offset;
8057   stmtblock_t body, block;
8058   gfc_loopinfo loop;
8059   gfc_actual_arglist *arg = code->ext.actual;
8060
8061   gfc_init_se (&se, NULL);
8062   gfc_init_se (&cptrse, NULL);
8063   gfc_conv_expr (&cptrse, arg->expr);
8064   gfc_add_block_to_block (&se.pre, &cptrse.pre);
8065   gfc_add_block_to_block (&se.post, &cptrse.post);
8066
8067   gfc_init_se (&fptrse, NULL);
8068   if (arg->next->expr->rank == 0)
8069     {
8070       fptrse.want_pointer = 1;
8071       gfc_conv_expr (&fptrse, arg->next->expr);
8072       gfc_add_block_to_block (&se.pre, &fptrse.pre);
8073       gfc_add_block_to_block (&se.post, &fptrse.post);
8074       if (arg->next->expr->symtree->n.sym->attr.proc_pointer
8075           && arg->next->expr->symtree->n.sym->attr.dummy)
8076         fptrse.expr = build_fold_indirect_ref_loc (input_location,
8077                                                        fptrse.expr);
8078       se.expr = fold_build2_loc (input_location, MODIFY_EXPR,
8079                                  TREE_TYPE (fptrse.expr),
8080                                  fptrse.expr,
8081                                  fold_convert (TREE_TYPE (fptrse.expr),
8082                                                cptrse.expr));
8083       gfc_add_expr_to_block (&se.pre, se.expr);
8084       gfc_add_block_to_block (&se.pre, &se.post);
8085       return gfc_finish_block (&se.pre);
8086     }
8087
8088   gfc_start_block (&block);
8089
8090   /* Get the descriptor of the Fortran pointer.  */
8091   fptrse.descriptor_only = 1;
8092   gfc_conv_expr_descriptor (&fptrse, arg->next->expr);
8093   gfc_add_block_to_block (&block, &fptrse.pre);
8094   desc = fptrse.expr;
8095
8096   /* Set data value, dtype, and offset.  */
8097   tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
8098   gfc_conv_descriptor_data_set (&block, desc, fold_convert (tmp, cptrse.expr));
8099   gfc_add_modify (&block, gfc_conv_descriptor_dtype (desc),
8100                   gfc_get_dtype (TREE_TYPE (desc)));
8101
8102   /* Start scalarization of the bounds, using the shape argument.  */
8103
8104   shape_ss = gfc_walk_expr (arg->next->next->expr);
8105   gcc_assert (shape_ss != gfc_ss_terminator);
8106   gfc_init_se (&shapese, NULL);
8107
8108   gfc_init_loopinfo (&loop);
8109   gfc_add_ss_to_loop (&loop, shape_ss);
8110   gfc_conv_ss_startstride (&loop);
8111   gfc_conv_loop_setup (&loop, &arg->next->expr->where);
8112   gfc_mark_ss_chain_used (shape_ss, 1);
8113
8114   gfc_copy_loopinfo_to_se (&shapese, &loop);
8115   shapese.ss = shape_ss;
8116
8117   stride = gfc_create_var (gfc_array_index_type, "stride");
8118   offset = gfc_create_var (gfc_array_index_type, "offset");
8119   gfc_add_modify (&block, stride, gfc_index_one_node);
8120   gfc_add_modify (&block, offset, gfc_index_zero_node);
8121
8122   /* Loop body.  */
8123   gfc_start_scalarized_body (&loop, &body);
8124
8125   dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
8126                              loop.loopvar[0], loop.from[0]);
8127
8128   /* Set bounds and stride.  */
8129   gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
8130   gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
8131
8132   gfc_conv_expr (&shapese, arg->next->next->expr);
8133   gfc_add_block_to_block (&body, &shapese.pre);
8134   gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
8135   gfc_add_block_to_block (&body, &shapese.post);
8136
8137   /* Calculate offset.  */
8138   gfc_add_modify (&body, offset,
8139                   fold_build2_loc (input_location, PLUS_EXPR,
8140                                    gfc_array_index_type, offset, stride));
8141   /* Update stride.  */
8142   gfc_add_modify (&body, stride,
8143                   fold_build2_loc (input_location, MULT_EXPR,
8144                                    gfc_array_index_type, stride,
8145                                    fold_convert (gfc_array_index_type,
8146                                                  shapese.expr)));
8147   /* Finish scalarization loop.  */
8148   gfc_trans_scalarizing_loops (&loop, &body);
8149   gfc_add_block_to_block (&block, &loop.pre);
8150   gfc_add_block_to_block (&block, &loop.post);
8151   gfc_add_block_to_block (&block, &fptrse.post);
8152   gfc_cleanup_loop (&loop);
8153
8154   gfc_add_modify (&block, offset,
8155                   fold_build1_loc (input_location, NEGATE_EXPR,
8156                                    gfc_array_index_type, offset));
8157   gfc_conv_descriptor_offset_set (&block, desc, offset);
8158
8159   gfc_add_expr_to_block (&se.pre, gfc_finish_block (&block));
8160   gfc_add_block_to_block (&se.pre, &se.post);
8161   return gfc_finish_block (&se.pre);
8162 }
8163
8164
8165 /* Save and restore floating-point state.  */
8166
8167 tree
8168 gfc_save_fp_state (stmtblock_t *block)
8169 {
8170   tree type, fpstate, tmp;
8171
8172   type = build_array_type (char_type_node,
8173                            build_range_type (size_type_node, size_zero_node,
8174                                              size_int (GFC_FPE_STATE_BUFFER_SIZE)));
8175   fpstate = gfc_create_var (type, "fpstate");
8176   fpstate = gfc_build_addr_expr (pvoid_type_node, fpstate);
8177
8178   tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_entry,
8179                              1, fpstate);
8180   gfc_add_expr_to_block (block, tmp);
8181
8182   return fpstate;
8183 }
8184
8185
8186 void
8187 gfc_restore_fp_state (stmtblock_t *block, tree fpstate)
8188 {
8189   tree tmp;
8190
8191   tmp = build_call_expr_loc (input_location, gfor_fndecl_ieee_procedure_exit,
8192                              1, fpstate);
8193   gfc_add_expr_to_block (block, tmp);
8194 }
8195
8196
8197 /* Generate code for arguments of IEEE functions.  */
8198
8199 static void
8200 conv_ieee_function_args (gfc_se *se, gfc_expr *expr, tree *argarray,
8201                          int nargs)
8202 {
8203   gfc_actual_arglist *actual;
8204   gfc_expr *e;
8205   gfc_se argse;
8206   int arg;
8207
8208   actual = expr->value.function.actual;
8209   for (arg = 0; arg < nargs; arg++, actual = actual->next)
8210     {
8211       gcc_assert (actual);
8212       e = actual->expr;
8213
8214       gfc_init_se (&argse, se);
8215       gfc_conv_expr_val (&argse, e);
8216
8217       gfc_add_block_to_block (&se->pre, &argse.pre);
8218       gfc_add_block_to_block (&se->post, &argse.post);
8219       argarray[arg] = argse.expr;
8220     }
8221 }
8222
8223
8224 /* Generate code for intrinsics IEEE_IS_NAN, IEEE_IS_FINITE,
8225    and IEEE_UNORDERED, which translate directly to GCC type-generic
8226    built-ins.  */
8227
8228 static void
8229 conv_intrinsic_ieee_builtin (gfc_se * se, gfc_expr * expr,
8230                              enum built_in_function code, int nargs)
8231 {
8232   tree args[2];
8233   gcc_assert ((unsigned) nargs <= sizeof(args)/sizeof(args[0]));
8234
8235   conv_ieee_function_args (se, expr, args, nargs);
8236   se->expr = build_call_expr_loc_array (input_location,
8237                                         builtin_decl_explicit (code),
8238                                         nargs, args);
8239   STRIP_TYPE_NOPS (se->expr);
8240   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8241 }
8242
8243
8244 /* Generate code for IEEE_IS_NORMAL intrinsic:
8245      IEEE_IS_NORMAL(x) --> (__builtin_isnormal(x) || x == 0)  */
8246
8247 static void
8248 conv_intrinsic_ieee_is_normal (gfc_se * se, gfc_expr * expr)
8249 {
8250   tree arg, isnormal, iszero;
8251
8252   /* Convert arg, evaluate it only once.  */
8253   conv_ieee_function_args (se, expr, &arg, 1);
8254   arg = gfc_evaluate_now (arg, &se->pre);
8255
8256   isnormal = build_call_expr_loc (input_location,
8257                                   builtin_decl_explicit (BUILT_IN_ISNORMAL),
8258                                   1, arg);
8259   iszero = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
8260                             build_real_from_int_cst (TREE_TYPE (arg),
8261                                                      integer_zero_node));
8262   se->expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
8263                               boolean_type_node, isnormal, iszero);
8264   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8265 }
8266
8267
8268 /* Generate code for IEEE_IS_NEGATIVE intrinsic:
8269      IEEE_IS_NEGATIVE(x) --> (__builtin_signbit(x) && !__builtin_isnan(x))  */
8270
8271 static void
8272 conv_intrinsic_ieee_is_negative (gfc_se * se, gfc_expr * expr)
8273 {
8274   tree arg, signbit, isnan;
8275
8276   /* Convert arg, evaluate it only once.  */
8277   conv_ieee_function_args (se, expr, &arg, 1);
8278   arg = gfc_evaluate_now (arg, &se->pre);
8279
8280   isnan = build_call_expr_loc (input_location,
8281                                builtin_decl_explicit (BUILT_IN_ISNAN),
8282                                1, arg);
8283   STRIP_TYPE_NOPS (isnan);
8284
8285   signbit = build_call_expr_loc (input_location,
8286                                  builtin_decl_explicit (BUILT_IN_SIGNBIT),
8287                                  1, arg);
8288   signbit = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8289                              signbit, integer_zero_node);
8290
8291   se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
8292                               boolean_type_node, signbit,
8293                               fold_build1_loc (input_location, TRUTH_NOT_EXPR,
8294                                                TREE_TYPE(isnan), isnan));
8295
8296   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
8297 }
8298
8299
8300 /* Generate code for IEEE_LOGB and IEEE_RINT.  */
8301
8302 static void
8303 conv_intrinsic_ieee_logb_rint (gfc_se * se, gfc_expr * expr,
8304                                enum built_in_function code)
8305 {
8306   tree arg, decl, call, fpstate;
8307   int argprec;
8308
8309   conv_ieee_function_args (se, expr, &arg, 1);
8310   argprec = TYPE_PRECISION (TREE_TYPE (arg));
8311   decl = builtin_decl_for_precision (code, argprec);
8312
8313   /* Save floating-point state.  */
8314   fpstate = gfc_save_fp_state (&se->pre);
8315
8316   /* Make the function call.  */
8317   call = build_call_expr_loc (input_location, decl, 1, arg);
8318   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), call);
8319
8320   /* Restore floating-point state.  */
8321   gfc_restore_fp_state (&se->post, fpstate);
8322 }
8323
8324
8325 /* Generate code for IEEE_REM.  */
8326
8327 static void
8328 conv_intrinsic_ieee_rem (gfc_se * se, gfc_expr * expr)
8329 {
8330   tree args[2], decl, call, fpstate;
8331   int argprec;
8332
8333   conv_ieee_function_args (se, expr, args, 2);
8334
8335   /* If arguments have unequal size, convert them to the larger.  */
8336   if (TYPE_PRECISION (TREE_TYPE (args[0]))
8337       > TYPE_PRECISION (TREE_TYPE (args[1])))
8338     args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8339   else if (TYPE_PRECISION (TREE_TYPE (args[1]))
8340            > TYPE_PRECISION (TREE_TYPE (args[0])))
8341     args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
8342
8343   argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8344   decl = builtin_decl_for_precision (BUILT_IN_REMAINDER, argprec);
8345
8346   /* Save floating-point state.  */
8347   fpstate = gfc_save_fp_state (&se->pre);
8348
8349   /* Make the function call.  */
8350   call = build_call_expr_loc_array (input_location, decl, 2, args);
8351   se->expr = fold_convert (TREE_TYPE (args[0]), call);
8352
8353   /* Restore floating-point state.  */
8354   gfc_restore_fp_state (&se->post, fpstate);
8355 }
8356
8357
8358 /* Generate code for IEEE_NEXT_AFTER.  */
8359
8360 static void
8361 conv_intrinsic_ieee_next_after (gfc_se * se, gfc_expr * expr)
8362 {
8363   tree args[2], decl, call, fpstate;
8364   int argprec;
8365
8366   conv_ieee_function_args (se, expr, args, 2);
8367
8368   /* Result has the characteristics of first argument.  */
8369   args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
8370   argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8371   decl = builtin_decl_for_precision (BUILT_IN_NEXTAFTER, argprec);
8372
8373   /* Save floating-point state.  */
8374   fpstate = gfc_save_fp_state (&se->pre);
8375
8376   /* Make the function call.  */
8377   call = build_call_expr_loc_array (input_location, decl, 2, args);
8378   se->expr = fold_convert (TREE_TYPE (args[0]), call);
8379
8380   /* Restore floating-point state.  */
8381   gfc_restore_fp_state (&se->post, fpstate);
8382 }
8383
8384
8385 /* Generate code for IEEE_SCALB.  */
8386
8387 static void
8388 conv_intrinsic_ieee_scalb (gfc_se * se, gfc_expr * expr)
8389 {
8390   tree args[2], decl, call, huge, type;
8391   int argprec, n;
8392
8393   conv_ieee_function_args (se, expr, args, 2);
8394
8395   /* Result has the characteristics of first argument.  */
8396   argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8397   decl = builtin_decl_for_precision (BUILT_IN_SCALBN, argprec);
8398
8399   if (TYPE_PRECISION (TREE_TYPE (args[1])) > TYPE_PRECISION (integer_type_node))
8400     {
8401       /* We need to fold the integer into the range of a C int.  */
8402       args[1] = gfc_evaluate_now (args[1], &se->pre);
8403       type = TREE_TYPE (args[1]);
8404
8405       n = gfc_validate_kind (BT_INTEGER, gfc_c_int_kind, false);
8406       huge = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
8407                                    gfc_c_int_kind);
8408       huge = fold_convert (type, huge);
8409       args[1] = fold_build2_loc (input_location, MIN_EXPR, type, args[1],
8410                                  huge);
8411       args[1] = fold_build2_loc (input_location, MAX_EXPR, type, args[1],
8412                                  fold_build1_loc (input_location, NEGATE_EXPR,
8413                                                   type, huge));
8414     }
8415
8416   args[1] = fold_convert (integer_type_node, args[1]);
8417
8418   /* Make the function call.  */
8419   call = build_call_expr_loc_array (input_location, decl, 2, args);
8420   se->expr = fold_convert (TREE_TYPE (args[0]), call);
8421 }
8422
8423
8424 /* Generate code for IEEE_COPY_SIGN.  */
8425
8426 static void
8427 conv_intrinsic_ieee_copy_sign (gfc_se * se, gfc_expr * expr)
8428 {
8429   tree args[2], decl, sign;
8430   int argprec;
8431
8432   conv_ieee_function_args (se, expr, args, 2);
8433
8434   /* Get the sign of the second argument.  */
8435   sign = build_call_expr_loc (input_location,
8436                               builtin_decl_explicit (BUILT_IN_SIGNBIT),
8437                               1, args[1]);
8438   sign = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
8439                           sign, integer_zero_node);
8440
8441   /* Create a value of one, with the right sign.  */
8442   sign = fold_build3_loc (input_location, COND_EXPR, integer_type_node,
8443                           sign,
8444                           fold_build1_loc (input_location, NEGATE_EXPR,
8445                                            integer_type_node,
8446                                            integer_one_node),
8447                           integer_one_node);
8448   args[1] = fold_convert (TREE_TYPE (args[0]), sign);
8449
8450   argprec = TYPE_PRECISION (TREE_TYPE (args[0]));
8451   decl = builtin_decl_for_precision (BUILT_IN_COPYSIGN, argprec);
8452
8453   se->expr = build_call_expr_loc_array (input_location, decl, 2, args);
8454 }
8455
8456
8457 /* Generate code for an intrinsic function from the IEEE_ARITHMETIC
8458    module.  */
8459
8460 bool
8461 gfc_conv_ieee_arithmetic_function (gfc_se * se, gfc_expr * expr)
8462 {
8463   const char *name = expr->value.function.name;
8464
8465 #define STARTS_WITH(A,B) (strncmp((A), (B), strlen(B)) == 0)
8466
8467   if (STARTS_WITH (name, "_gfortran_ieee_is_nan"))
8468     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISNAN, 1);
8469   else if (STARTS_WITH (name, "_gfortran_ieee_is_finite"))
8470     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISFINITE, 1);
8471   else if (STARTS_WITH (name, "_gfortran_ieee_unordered"))
8472     conv_intrinsic_ieee_builtin (se, expr, BUILT_IN_ISUNORDERED, 2);
8473   else if (STARTS_WITH (name, "_gfortran_ieee_is_normal"))
8474     conv_intrinsic_ieee_is_normal (se, expr);
8475   else if (STARTS_WITH (name, "_gfortran_ieee_is_negative"))
8476     conv_intrinsic_ieee_is_negative (se, expr);
8477   else if (STARTS_WITH (name, "_gfortran_ieee_copy_sign"))
8478     conv_intrinsic_ieee_copy_sign (se, expr);
8479   else if (STARTS_WITH (name, "_gfortran_ieee_scalb"))
8480     conv_intrinsic_ieee_scalb (se, expr);
8481   else if (STARTS_WITH (name, "_gfortran_ieee_next_after"))
8482     conv_intrinsic_ieee_next_after (se, expr);
8483   else if (STARTS_WITH (name, "_gfortran_ieee_rem"))
8484     conv_intrinsic_ieee_rem (se, expr);
8485   else if (STARTS_WITH (name, "_gfortran_ieee_logb"))
8486     conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_LOGB);
8487   else if (STARTS_WITH (name, "_gfortran_ieee_rint"))
8488     conv_intrinsic_ieee_logb_rint (se, expr, BUILT_IN_RINT);
8489   else
8490     /* It is not among the functions we translate directly.  We return
8491        false, so a library function call is emitted.  */
8492     return false;
8493
8494 #undef STARTS_WITH
8495
8496   return true;
8497 }
8498
8499
8500 /* Generate a direct call to malloc() for the MALLOC intrinsic.  */
8501
8502 static void
8503 gfc_conv_intrinsic_malloc (gfc_se * se, gfc_expr * expr)
8504 {
8505   tree arg, res, restype;
8506
8507   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
8508   arg = fold_convert (size_type_node, arg);
8509   res = build_call_expr_loc (input_location,
8510                              builtin_decl_explicit (BUILT_IN_MALLOC), 1, arg);
8511   restype = gfc_typenode_for_spec (&expr->ts);
8512   se->expr = fold_convert (restype, res);
8513 }
8514
8515
8516 /* Generate code for an intrinsic function.  Some map directly to library
8517    calls, others get special handling.  In some cases the name of the function
8518    used depends on the type specifiers.  */
8519
8520 void
8521 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
8522 {
8523   const char *name;
8524   int lib, kind;
8525   tree fndecl;
8526
8527   name = &expr->value.function.name[2];
8528
8529   if (expr->rank > 0)
8530     {
8531       lib = gfc_is_intrinsic_libcall (expr);
8532       if (lib != 0)
8533         {
8534           if (lib == 1)
8535             se->ignore_optional = 1;
8536
8537           switch (expr->value.function.isym->id)
8538             {
8539             case GFC_ISYM_EOSHIFT:
8540             case GFC_ISYM_PACK:
8541             case GFC_ISYM_RESHAPE:
8542               /* For all of those the first argument specifies the type and the
8543                  third is optional.  */
8544               conv_generic_with_optional_char_arg (se, expr, 1, 3);
8545               break;
8546
8547             default:
8548               gfc_conv_intrinsic_funcall (se, expr);
8549               break;
8550             }
8551
8552           return;
8553         }
8554     }
8555
8556   switch (expr->value.function.isym->id)
8557     {
8558     case GFC_ISYM_NONE:
8559       gcc_unreachable ();
8560
8561     case GFC_ISYM_REPEAT:
8562       gfc_conv_intrinsic_repeat (se, expr);
8563       break;
8564
8565     case GFC_ISYM_TRIM:
8566       gfc_conv_intrinsic_trim (se, expr);
8567       break;
8568
8569     case GFC_ISYM_SC_KIND:
8570       gfc_conv_intrinsic_sc_kind (se, expr);
8571       break;
8572
8573     case GFC_ISYM_SI_KIND:
8574       gfc_conv_intrinsic_si_kind (se, expr);
8575       break;
8576
8577     case GFC_ISYM_SR_KIND:
8578       gfc_conv_intrinsic_sr_kind (se, expr);
8579       break;
8580
8581     case GFC_ISYM_EXPONENT:
8582       gfc_conv_intrinsic_exponent (se, expr);
8583       break;
8584
8585     case GFC_ISYM_SCAN:
8586       kind = expr->value.function.actual->expr->ts.kind;
8587       if (kind == 1)
8588        fndecl = gfor_fndecl_string_scan;
8589       else if (kind == 4)
8590        fndecl = gfor_fndecl_string_scan_char4;
8591       else
8592        gcc_unreachable ();
8593
8594       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8595       break;
8596
8597     case GFC_ISYM_VERIFY:
8598       kind = expr->value.function.actual->expr->ts.kind;
8599       if (kind == 1)
8600        fndecl = gfor_fndecl_string_verify;
8601       else if (kind == 4)
8602        fndecl = gfor_fndecl_string_verify_char4;
8603       else
8604        gcc_unreachable ();
8605
8606       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8607       break;
8608
8609     case GFC_ISYM_ALLOCATED:
8610       gfc_conv_allocated (se, expr);
8611       break;
8612
8613     case GFC_ISYM_ASSOCIATED:
8614       gfc_conv_associated(se, expr);
8615       break;
8616
8617     case GFC_ISYM_SAME_TYPE_AS:
8618       gfc_conv_same_type_as (se, expr);
8619       break;
8620
8621     case GFC_ISYM_ABS:
8622       gfc_conv_intrinsic_abs (se, expr);
8623       break;
8624
8625     case GFC_ISYM_ADJUSTL:
8626       if (expr->ts.kind == 1)
8627        fndecl = gfor_fndecl_adjustl;
8628       else if (expr->ts.kind == 4)
8629        fndecl = gfor_fndecl_adjustl_char4;
8630       else
8631        gcc_unreachable ();
8632
8633       gfc_conv_intrinsic_adjust (se, expr, fndecl);
8634       break;
8635
8636     case GFC_ISYM_ADJUSTR:
8637       if (expr->ts.kind == 1)
8638        fndecl = gfor_fndecl_adjustr;
8639       else if (expr->ts.kind == 4)
8640        fndecl = gfor_fndecl_adjustr_char4;
8641       else
8642        gcc_unreachable ();
8643
8644       gfc_conv_intrinsic_adjust (se, expr, fndecl);
8645       break;
8646
8647     case GFC_ISYM_AIMAG:
8648       gfc_conv_intrinsic_imagpart (se, expr);
8649       break;
8650
8651     case GFC_ISYM_AINT:
8652       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
8653       break;
8654
8655     case GFC_ISYM_ALL:
8656       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
8657       break;
8658
8659     case GFC_ISYM_ANINT:
8660       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
8661       break;
8662
8663     case GFC_ISYM_AND:
8664       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
8665       break;
8666
8667     case GFC_ISYM_ANY:
8668       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
8669       break;
8670
8671     case GFC_ISYM_BTEST:
8672       gfc_conv_intrinsic_btest (se, expr);
8673       break;
8674
8675     case GFC_ISYM_BGE:
8676       gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
8677       break;
8678
8679     case GFC_ISYM_BGT:
8680       gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
8681       break;
8682
8683     case GFC_ISYM_BLE:
8684       gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
8685       break;
8686
8687     case GFC_ISYM_BLT:
8688       gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
8689       break;
8690
8691     case GFC_ISYM_C_ASSOCIATED:
8692     case GFC_ISYM_C_FUNLOC:
8693     case GFC_ISYM_C_LOC:
8694       conv_isocbinding_function (se, expr);
8695       break;
8696
8697     case GFC_ISYM_ACHAR:
8698     case GFC_ISYM_CHAR:
8699       gfc_conv_intrinsic_char (se, expr);
8700       break;
8701
8702     case GFC_ISYM_CONVERSION:
8703     case GFC_ISYM_REAL:
8704     case GFC_ISYM_LOGICAL:
8705     case GFC_ISYM_DBLE:
8706       gfc_conv_intrinsic_conversion (se, expr);
8707       break;
8708
8709       /* Integer conversions are handled separately to make sure we get the
8710          correct rounding mode.  */
8711     case GFC_ISYM_INT:
8712     case GFC_ISYM_INT2:
8713     case GFC_ISYM_INT8:
8714     case GFC_ISYM_LONG:
8715       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
8716       break;
8717
8718     case GFC_ISYM_NINT:
8719       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
8720       break;
8721
8722     case GFC_ISYM_CEILING:
8723       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
8724       break;
8725
8726     case GFC_ISYM_FLOOR:
8727       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
8728       break;
8729
8730     case GFC_ISYM_MOD:
8731       gfc_conv_intrinsic_mod (se, expr, 0);
8732       break;
8733
8734     case GFC_ISYM_MODULO:
8735       gfc_conv_intrinsic_mod (se, expr, 1);
8736       break;
8737
8738     case GFC_ISYM_CAF_GET:
8739       gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE,
8740                                   false, NULL);
8741       break;
8742
8743     case GFC_ISYM_CMPLX:
8744       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
8745       break;
8746
8747     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
8748       gfc_conv_intrinsic_iargc (se, expr);
8749       break;
8750
8751     case GFC_ISYM_COMPLEX:
8752       gfc_conv_intrinsic_cmplx (se, expr, 1);
8753       break;
8754
8755     case GFC_ISYM_CONJG:
8756       gfc_conv_intrinsic_conjg (se, expr);
8757       break;
8758
8759     case GFC_ISYM_COUNT:
8760       gfc_conv_intrinsic_count (se, expr);
8761       break;
8762
8763     case GFC_ISYM_CTIME:
8764       gfc_conv_intrinsic_ctime (se, expr);
8765       break;
8766
8767     case GFC_ISYM_DIM:
8768       gfc_conv_intrinsic_dim (se, expr);
8769       break;
8770
8771     case GFC_ISYM_DOT_PRODUCT:
8772       gfc_conv_intrinsic_dot_product (se, expr);
8773       break;
8774
8775     case GFC_ISYM_DPROD:
8776       gfc_conv_intrinsic_dprod (se, expr);
8777       break;
8778
8779     case GFC_ISYM_DSHIFTL:
8780       gfc_conv_intrinsic_dshift (se, expr, true);
8781       break;
8782
8783     case GFC_ISYM_DSHIFTR:
8784       gfc_conv_intrinsic_dshift (se, expr, false);
8785       break;
8786
8787     case GFC_ISYM_FDATE:
8788       gfc_conv_intrinsic_fdate (se, expr);
8789       break;
8790
8791     case GFC_ISYM_FRACTION:
8792       gfc_conv_intrinsic_fraction (se, expr);
8793       break;
8794
8795     case GFC_ISYM_IALL:
8796       gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
8797       break;
8798
8799     case GFC_ISYM_IAND:
8800       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
8801       break;
8802
8803     case GFC_ISYM_IANY:
8804       gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
8805       break;
8806
8807     case GFC_ISYM_IBCLR:
8808       gfc_conv_intrinsic_singlebitop (se, expr, 0);
8809       break;
8810
8811     case GFC_ISYM_IBITS:
8812       gfc_conv_intrinsic_ibits (se, expr);
8813       break;
8814
8815     case GFC_ISYM_IBSET:
8816       gfc_conv_intrinsic_singlebitop (se, expr, 1);
8817       break;
8818
8819     case GFC_ISYM_IACHAR:
8820     case GFC_ISYM_ICHAR:
8821       /* We assume ASCII character sequence.  */
8822       gfc_conv_intrinsic_ichar (se, expr);
8823       break;
8824
8825     case GFC_ISYM_IARGC:
8826       gfc_conv_intrinsic_iargc (se, expr);
8827       break;
8828
8829     case GFC_ISYM_IEOR:
8830       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
8831       break;
8832
8833     case GFC_ISYM_INDEX:
8834       kind = expr->value.function.actual->expr->ts.kind;
8835       if (kind == 1)
8836        fndecl = gfor_fndecl_string_index;
8837       else if (kind == 4)
8838        fndecl = gfor_fndecl_string_index_char4;
8839       else
8840        gcc_unreachable ();
8841
8842       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
8843       break;
8844
8845     case GFC_ISYM_IOR:
8846       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
8847       break;
8848
8849     case GFC_ISYM_IPARITY:
8850       gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
8851       break;
8852
8853     case GFC_ISYM_IS_IOSTAT_END:
8854       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
8855       break;
8856
8857     case GFC_ISYM_IS_IOSTAT_EOR:
8858       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
8859       break;
8860
8861     case GFC_ISYM_ISNAN:
8862       gfc_conv_intrinsic_isnan (se, expr);
8863       break;
8864
8865     case GFC_ISYM_LSHIFT:
8866       gfc_conv_intrinsic_shift (se, expr, false, false);
8867       break;
8868
8869     case GFC_ISYM_RSHIFT:
8870       gfc_conv_intrinsic_shift (se, expr, true, true);
8871       break;
8872
8873     case GFC_ISYM_SHIFTA:
8874       gfc_conv_intrinsic_shift (se, expr, true, true);
8875       break;
8876
8877     case GFC_ISYM_SHIFTL:
8878       gfc_conv_intrinsic_shift (se, expr, false, false);
8879       break;
8880
8881     case GFC_ISYM_SHIFTR:
8882       gfc_conv_intrinsic_shift (se, expr, true, false);
8883       break;
8884
8885     case GFC_ISYM_ISHFT:
8886       gfc_conv_intrinsic_ishft (se, expr);
8887       break;
8888
8889     case GFC_ISYM_ISHFTC:
8890       gfc_conv_intrinsic_ishftc (se, expr);
8891       break;
8892
8893     case GFC_ISYM_LEADZ:
8894       gfc_conv_intrinsic_leadz (se, expr);
8895       break;
8896
8897     case GFC_ISYM_TRAILZ:
8898       gfc_conv_intrinsic_trailz (se, expr);
8899       break;
8900
8901     case GFC_ISYM_POPCNT:
8902       gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
8903       break;
8904
8905     case GFC_ISYM_POPPAR:
8906       gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
8907       break;
8908
8909     case GFC_ISYM_LBOUND:
8910       gfc_conv_intrinsic_bound (se, expr, 0);
8911       break;
8912
8913     case GFC_ISYM_LCOBOUND:
8914       conv_intrinsic_cobound (se, expr);
8915       break;
8916
8917     case GFC_ISYM_TRANSPOSE:
8918       /* The scalarizer has already been set up for reversed dimension access
8919          order ; now we just get the argument value normally.  */
8920       gfc_conv_expr (se, expr->value.function.actual->expr);
8921       break;
8922
8923     case GFC_ISYM_LEN:
8924       gfc_conv_intrinsic_len (se, expr);
8925       break;
8926
8927     case GFC_ISYM_LEN_TRIM:
8928       gfc_conv_intrinsic_len_trim (se, expr);
8929       break;
8930
8931     case GFC_ISYM_LGE:
8932       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
8933       break;
8934
8935     case GFC_ISYM_LGT:
8936       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
8937       break;
8938
8939     case GFC_ISYM_LLE:
8940       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
8941       break;
8942
8943     case GFC_ISYM_LLT:
8944       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
8945       break;
8946
8947     case GFC_ISYM_MALLOC:
8948       gfc_conv_intrinsic_malloc (se, expr);
8949       break;
8950
8951     case GFC_ISYM_MASKL:
8952       gfc_conv_intrinsic_mask (se, expr, 1);
8953       break;
8954
8955     case GFC_ISYM_MASKR:
8956       gfc_conv_intrinsic_mask (se, expr, 0);
8957       break;
8958
8959     case GFC_ISYM_MAX:
8960       if (expr->ts.type == BT_CHARACTER)
8961         gfc_conv_intrinsic_minmax_char (se, expr, 1);
8962       else
8963         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
8964       break;
8965
8966     case GFC_ISYM_MAXLOC:
8967       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
8968       break;
8969
8970     case GFC_ISYM_MAXVAL:
8971       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
8972       break;
8973
8974     case GFC_ISYM_MERGE:
8975       gfc_conv_intrinsic_merge (se, expr);
8976       break;
8977
8978     case GFC_ISYM_MERGE_BITS:
8979       gfc_conv_intrinsic_merge_bits (se, expr);
8980       break;
8981
8982     case GFC_ISYM_MIN:
8983       if (expr->ts.type == BT_CHARACTER)
8984         gfc_conv_intrinsic_minmax_char (se, expr, -1);
8985       else
8986         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
8987       break;
8988
8989     case GFC_ISYM_MINLOC:
8990       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
8991       break;
8992
8993     case GFC_ISYM_MINVAL:
8994       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
8995       break;
8996
8997     case GFC_ISYM_NEAREST:
8998       gfc_conv_intrinsic_nearest (se, expr);
8999       break;
9000
9001     case GFC_ISYM_NORM2:
9002       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
9003       break;
9004
9005     case GFC_ISYM_NOT:
9006       gfc_conv_intrinsic_not (se, expr);
9007       break;
9008
9009     case GFC_ISYM_OR:
9010       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
9011       break;
9012
9013     case GFC_ISYM_PARITY:
9014       gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
9015       break;
9016
9017     case GFC_ISYM_PRESENT:
9018       gfc_conv_intrinsic_present (se, expr);
9019       break;
9020
9021     case GFC_ISYM_PRODUCT:
9022       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
9023       break;
9024
9025     case GFC_ISYM_RANK:
9026       gfc_conv_intrinsic_rank (se, expr);
9027       break;
9028
9029     case GFC_ISYM_RRSPACING:
9030       gfc_conv_intrinsic_rrspacing (se, expr);
9031       break;
9032
9033     case GFC_ISYM_SET_EXPONENT:
9034       gfc_conv_intrinsic_set_exponent (se, expr);
9035       break;
9036
9037     case GFC_ISYM_SCALE:
9038       gfc_conv_intrinsic_scale (se, expr);
9039       break;
9040
9041     case GFC_ISYM_SIGN:
9042       gfc_conv_intrinsic_sign (se, expr);
9043       break;
9044
9045     case GFC_ISYM_SIZE:
9046       gfc_conv_intrinsic_size (se, expr);
9047       break;
9048
9049     case GFC_ISYM_SIZEOF:
9050     case GFC_ISYM_C_SIZEOF:
9051       gfc_conv_intrinsic_sizeof (se, expr);
9052       break;
9053
9054     case GFC_ISYM_STORAGE_SIZE:
9055       gfc_conv_intrinsic_storage_size (se, expr);
9056       break;
9057
9058     case GFC_ISYM_SPACING:
9059       gfc_conv_intrinsic_spacing (se, expr);
9060       break;
9061
9062     case GFC_ISYM_STRIDE:
9063       conv_intrinsic_stride (se, expr);
9064       break;
9065
9066     case GFC_ISYM_SUM:
9067       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
9068       break;
9069
9070     case GFC_ISYM_TRANSFER:
9071       if (se->ss && se->ss->info->useflags)
9072         /* Access the previously obtained result.  */
9073         gfc_conv_tmp_array_ref (se);
9074       else
9075         gfc_conv_intrinsic_transfer (se, expr);
9076       break;
9077
9078     case GFC_ISYM_TTYNAM:
9079       gfc_conv_intrinsic_ttynam (se, expr);
9080       break;
9081
9082     case GFC_ISYM_UBOUND:
9083       gfc_conv_intrinsic_bound (se, expr, 1);
9084       break;
9085
9086     case GFC_ISYM_UCOBOUND:
9087       conv_intrinsic_cobound (se, expr);
9088       break;
9089
9090     case GFC_ISYM_XOR:
9091       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
9092       break;
9093
9094     case GFC_ISYM_LOC:
9095       gfc_conv_intrinsic_loc (se, expr);
9096       break;
9097
9098     case GFC_ISYM_THIS_IMAGE:
9099       /* For num_images() == 1, handle as LCOBOUND.  */
9100       if (expr->value.function.actual->expr
9101           && flag_coarray == GFC_FCOARRAY_SINGLE)
9102         conv_intrinsic_cobound (se, expr);
9103       else
9104         trans_this_image (se, expr);
9105       break;
9106
9107     case GFC_ISYM_IMAGE_INDEX:
9108       trans_image_index (se, expr);
9109       break;
9110
9111     case GFC_ISYM_NUM_IMAGES:
9112       trans_num_images (se, expr);
9113       break;
9114
9115     case GFC_ISYM_ACCESS:
9116     case GFC_ISYM_CHDIR:
9117     case GFC_ISYM_CHMOD:
9118     case GFC_ISYM_DTIME:
9119     case GFC_ISYM_ETIME:
9120     case GFC_ISYM_EXTENDS_TYPE_OF:
9121     case GFC_ISYM_FGET:
9122     case GFC_ISYM_FGETC:
9123     case GFC_ISYM_FNUM:
9124     case GFC_ISYM_FPUT:
9125     case GFC_ISYM_FPUTC:
9126     case GFC_ISYM_FSTAT:
9127     case GFC_ISYM_FTELL:
9128     case GFC_ISYM_GETCWD:
9129     case GFC_ISYM_GETGID:
9130     case GFC_ISYM_GETPID:
9131     case GFC_ISYM_GETUID:
9132     case GFC_ISYM_HOSTNM:
9133     case GFC_ISYM_KILL:
9134     case GFC_ISYM_IERRNO:
9135     case GFC_ISYM_IRAND:
9136     case GFC_ISYM_ISATTY:
9137     case GFC_ISYM_JN2:
9138     case GFC_ISYM_LINK:
9139     case GFC_ISYM_LSTAT:
9140     case GFC_ISYM_MATMUL:
9141     case GFC_ISYM_MCLOCK:
9142     case GFC_ISYM_MCLOCK8:
9143     case GFC_ISYM_RAND:
9144     case GFC_ISYM_RENAME:
9145     case GFC_ISYM_SECOND:
9146     case GFC_ISYM_SECNDS:
9147     case GFC_ISYM_SIGNAL:
9148     case GFC_ISYM_STAT:
9149     case GFC_ISYM_SYMLNK:
9150     case GFC_ISYM_SYSTEM:
9151     case GFC_ISYM_TIME:
9152     case GFC_ISYM_TIME8:
9153     case GFC_ISYM_UMASK:
9154     case GFC_ISYM_UNLINK:
9155     case GFC_ISYM_YN2:
9156       gfc_conv_intrinsic_funcall (se, expr);
9157       break;
9158
9159     case GFC_ISYM_EOSHIFT:
9160     case GFC_ISYM_PACK:
9161     case GFC_ISYM_RESHAPE:
9162       /* For those, expr->rank should always be >0 and thus the if above the
9163          switch should have matched.  */
9164       gcc_unreachable ();
9165       break;
9166
9167     default:
9168       gfc_conv_intrinsic_lib_function (se, expr);
9169       break;
9170     }
9171 }
9172
9173
9174 static gfc_ss *
9175 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
9176 {
9177   gfc_ss *arg_ss, *tmp_ss;
9178   gfc_actual_arglist *arg;
9179
9180   arg = expr->value.function.actual;
9181
9182   gcc_assert (arg->expr);
9183
9184   arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
9185   gcc_assert (arg_ss != gfc_ss_terminator);
9186
9187   for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
9188     {
9189       if (tmp_ss->info->type != GFC_SS_SCALAR
9190           && tmp_ss->info->type != GFC_SS_REFERENCE)
9191         {
9192           gcc_assert (tmp_ss->dimen == 2);
9193
9194           /* We just invert dimensions.  */
9195           std::swap (tmp_ss->dim[0], tmp_ss->dim[1]);
9196         }
9197
9198       /* Stop when tmp_ss points to the last valid element of the chain...  */
9199       if (tmp_ss->next == gfc_ss_terminator)
9200         break;
9201     }
9202
9203   /* ... so that we can attach the rest of the chain to it.  */
9204   tmp_ss->next = ss;
9205
9206   return arg_ss;
9207 }
9208
9209
9210 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
9211    This has the side effect of reversing the nested list, so there is no
9212    need to call gfc_reverse_ss on it (the given list is assumed not to be
9213    reversed yet).   */
9214
9215 static gfc_ss *
9216 nest_loop_dimension (gfc_ss *ss, int dim)
9217 {
9218   int ss_dim, i;
9219   gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
9220   gfc_loopinfo *new_loop;
9221
9222   gcc_assert (ss != gfc_ss_terminator);
9223
9224   for (; ss != gfc_ss_terminator; ss = ss->next)
9225     {
9226       new_ss = gfc_get_ss ();
9227       new_ss->next = prev_ss;
9228       new_ss->parent = ss;
9229       new_ss->info = ss->info;
9230       new_ss->info->refcount++;
9231       if (ss->dimen != 0)
9232         {
9233           gcc_assert (ss->info->type != GFC_SS_SCALAR
9234                       && ss->info->type != GFC_SS_REFERENCE);
9235
9236           new_ss->dimen = 1;
9237           new_ss->dim[0] = ss->dim[dim];
9238
9239           gcc_assert (dim < ss->dimen);
9240
9241           ss_dim = --ss->dimen;
9242           for (i = dim; i < ss_dim; i++)
9243             ss->dim[i] = ss->dim[i + 1];
9244
9245           ss->dim[ss_dim] = 0;
9246         }
9247       prev_ss = new_ss;
9248
9249       if (ss->nested_ss)
9250         {
9251           ss->nested_ss->parent = new_ss;
9252           new_ss->nested_ss = ss->nested_ss;
9253         }
9254       ss->nested_ss = new_ss;
9255     }
9256
9257   new_loop = gfc_get_loopinfo ();
9258   gfc_init_loopinfo (new_loop);
9259
9260   gcc_assert (prev_ss != NULL);
9261   gcc_assert (prev_ss != gfc_ss_terminator);
9262   gfc_add_ss_to_loop (new_loop, prev_ss);
9263   return new_ss->parent;
9264 }
9265
9266
9267 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
9268    is to be inlined.  */
9269
9270 static gfc_ss *
9271 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
9272 {
9273   gfc_ss *tmp_ss, *tail, *array_ss;
9274   gfc_actual_arglist *arg1, *arg2, *arg3;
9275   int sum_dim;
9276   bool scalar_mask = false;
9277
9278   /* The rank of the result will be determined later.  */
9279   arg1 = expr->value.function.actual;
9280   arg2 = arg1->next;
9281   arg3 = arg2->next;
9282   gcc_assert (arg3 != NULL);
9283
9284   if (expr->rank == 0)
9285     return ss;
9286
9287   tmp_ss = gfc_ss_terminator;
9288
9289   if (arg3->expr)
9290     {
9291       gfc_ss *mask_ss;
9292
9293       mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
9294       if (mask_ss == tmp_ss)
9295         scalar_mask = 1;
9296
9297       tmp_ss = mask_ss;
9298     }
9299
9300   array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
9301   gcc_assert (array_ss != tmp_ss);
9302
9303   /* Odd thing: If the mask is scalar, it is used by the frontend after
9304      the array (to make an if around the nested loop). Thus it shall
9305      be after array_ss once the gfc_ss list is reversed.  */
9306   if (scalar_mask)
9307     tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
9308   else
9309     tmp_ss = array_ss;
9310
9311   /* "Hide" the dimension on which we will sum in the first arg's scalarization
9312      chain.  */
9313   sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
9314   tail = nest_loop_dimension (tmp_ss, sum_dim);
9315   tail->next = ss;
9316
9317   return tmp_ss;
9318 }
9319
9320
9321 static gfc_ss *
9322 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
9323 {
9324
9325   switch (expr->value.function.isym->id)
9326     {
9327       case GFC_ISYM_PRODUCT:
9328       case GFC_ISYM_SUM:
9329         return walk_inline_intrinsic_arith (ss, expr);
9330
9331       case GFC_ISYM_TRANSPOSE:
9332         return walk_inline_intrinsic_transpose (ss, expr);
9333
9334       default:
9335         gcc_unreachable ();
9336     }
9337   gcc_unreachable ();
9338 }
9339
9340
9341 /* This generates code to execute before entering the scalarization loop.
9342    Currently does nothing.  */
9343
9344 void
9345 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
9346 {
9347   switch (ss->info->expr->value.function.isym->id)
9348     {
9349     case GFC_ISYM_UBOUND:
9350     case GFC_ISYM_LBOUND:
9351     case GFC_ISYM_UCOBOUND:
9352     case GFC_ISYM_LCOBOUND:
9353     case GFC_ISYM_THIS_IMAGE:
9354       break;
9355
9356     default:
9357       gcc_unreachable ();
9358     }
9359 }
9360
9361
9362 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
9363    are expanded into code inside the scalarization loop.  */
9364
9365 static gfc_ss *
9366 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
9367 {
9368   if (expr->value.function.actual->expr->ts.type == BT_CLASS)
9369     gfc_add_class_array_ref (expr->value.function.actual->expr);
9370
9371   /* The two argument version returns a scalar.  */
9372   if (expr->value.function.actual->next->expr)
9373     return ss;
9374
9375   return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
9376 }
9377
9378
9379 /* Walk an intrinsic array libcall.  */
9380
9381 static gfc_ss *
9382 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
9383 {
9384   gcc_assert (expr->rank > 0);
9385   return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
9386 }
9387
9388
9389 /* Return whether the function call expression EXPR will be expanded
9390    inline by gfc_conv_intrinsic_function.  */
9391
9392 bool
9393 gfc_inline_intrinsic_function_p (gfc_expr *expr)
9394 {
9395   gfc_actual_arglist *args;
9396
9397   if (!expr->value.function.isym)
9398     return false;
9399
9400   switch (expr->value.function.isym->id)
9401     {
9402     case GFC_ISYM_PRODUCT:
9403     case GFC_ISYM_SUM:
9404       /* Disable inline expansion if code size matters.  */
9405       if (optimize_size)
9406         return false;
9407
9408       args = expr->value.function.actual;
9409       /* We need to be able to subset the SUM argument at compile-time.  */
9410       if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
9411         return false;
9412
9413       return true;
9414
9415     case GFC_ISYM_TRANSPOSE:
9416       return true;
9417
9418     default:
9419       return false;
9420     }
9421 }
9422
9423
9424 /* Returns nonzero if the specified intrinsic function call maps directly to
9425    an external library call.  Should only be used for functions that return
9426    arrays.  */
9427
9428 int
9429 gfc_is_intrinsic_libcall (gfc_expr * expr)
9430 {
9431   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
9432   gcc_assert (expr->rank > 0);
9433
9434   if (gfc_inline_intrinsic_function_p (expr))
9435     return 0;
9436
9437   switch (expr->value.function.isym->id)
9438     {
9439     case GFC_ISYM_ALL:
9440     case GFC_ISYM_ANY:
9441     case GFC_ISYM_COUNT:
9442     case GFC_ISYM_JN2:
9443     case GFC_ISYM_IANY:
9444     case GFC_ISYM_IALL:
9445     case GFC_ISYM_IPARITY:
9446     case GFC_ISYM_MATMUL:
9447     case GFC_ISYM_MAXLOC:
9448     case GFC_ISYM_MAXVAL:
9449     case GFC_ISYM_MINLOC:
9450     case GFC_ISYM_MINVAL:
9451     case GFC_ISYM_NORM2:
9452     case GFC_ISYM_PARITY:
9453     case GFC_ISYM_PRODUCT:
9454     case GFC_ISYM_SUM:
9455     case GFC_ISYM_SHAPE:
9456     case GFC_ISYM_SPREAD:
9457     case GFC_ISYM_YN2:
9458       /* Ignore absent optional parameters.  */
9459       return 1;
9460
9461     case GFC_ISYM_RESHAPE:
9462     case GFC_ISYM_CSHIFT:
9463     case GFC_ISYM_EOSHIFT:
9464     case GFC_ISYM_PACK:
9465     case GFC_ISYM_UNPACK:
9466       /* Pass absent optional parameters.  */
9467       return 2;
9468
9469     default:
9470       return 0;
9471     }
9472 }
9473
9474 /* Walk an intrinsic function.  */
9475 gfc_ss *
9476 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
9477                              gfc_intrinsic_sym * isym)
9478 {
9479   gcc_assert (isym);
9480
9481   if (isym->elemental)
9482     return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
9483                                              NULL, GFC_SS_SCALAR);
9484
9485   if (expr->rank == 0)
9486     return ss;
9487
9488   if (gfc_inline_intrinsic_function_p (expr))
9489     return walk_inline_intrinsic_function (ss, expr);
9490
9491   if (gfc_is_intrinsic_libcall (expr))
9492     return gfc_walk_intrinsic_libfunc (ss, expr);
9493
9494   /* Special cases.  */
9495   switch (isym->id)
9496     {
9497     case GFC_ISYM_LBOUND:
9498     case GFC_ISYM_LCOBOUND:
9499     case GFC_ISYM_UBOUND:
9500     case GFC_ISYM_UCOBOUND:
9501     case GFC_ISYM_THIS_IMAGE:
9502       return gfc_walk_intrinsic_bound (ss, expr);
9503
9504     case GFC_ISYM_TRANSFER:
9505     case GFC_ISYM_CAF_GET:
9506       return gfc_walk_intrinsic_libfunc (ss, expr);
9507
9508     default:
9509       /* This probably meant someone forgot to add an intrinsic to the above
9510          list(s) when they implemented it, or something's gone horribly
9511          wrong.  */
9512       gcc_unreachable ();
9513     }
9514 }
9515
9516
9517 static tree
9518 conv_co_collective (gfc_code *code)
9519 {
9520   gfc_se argse;
9521   stmtblock_t block, post_block;
9522   tree fndecl, array, strlen, image_index, stat, errmsg, errmsg_len;
9523   gfc_expr *image_idx_expr, *stat_expr, *errmsg_expr, *opr_expr;
9524
9525   gfc_start_block (&block);
9526   gfc_init_block (&post_block);
9527
9528   if (code->resolved_isym->id == GFC_ISYM_CO_REDUCE)
9529     {
9530       opr_expr = code->ext.actual->next->expr;
9531       image_idx_expr = code->ext.actual->next->next->expr;
9532       stat_expr = code->ext.actual->next->next->next->expr;
9533       errmsg_expr = code->ext.actual->next->next->next->next->expr;
9534     }
9535   else
9536     {
9537       opr_expr = NULL;
9538       image_idx_expr = code->ext.actual->next->expr;
9539       stat_expr = code->ext.actual->next->next->expr;
9540       errmsg_expr = code->ext.actual->next->next->next->expr;
9541     }
9542
9543   /* stat.  */
9544   if (stat_expr)
9545     {
9546       gfc_init_se (&argse, NULL);
9547       gfc_conv_expr (&argse, stat_expr);
9548       gfc_add_block_to_block (&block, &argse.pre);
9549       gfc_add_block_to_block (&post_block, &argse.post);
9550       stat = argse.expr;
9551       if (flag_coarray != GFC_FCOARRAY_SINGLE)
9552         stat = gfc_build_addr_expr (NULL_TREE, stat);
9553     }
9554   else if (flag_coarray == GFC_FCOARRAY_SINGLE)
9555     stat = NULL_TREE;
9556   else
9557     stat = null_pointer_node;
9558
9559   /* Early exit for GFC_FCOARRAY_SINGLE.  */
9560   if (flag_coarray == GFC_FCOARRAY_SINGLE)
9561     {
9562       if (stat != NULL_TREE)
9563         gfc_add_modify (&block, stat,
9564                         fold_convert (TREE_TYPE (stat), integer_zero_node));
9565       return gfc_finish_block (&block);
9566     }
9567
9568   /* Handle the array.  */
9569   gfc_init_se (&argse, NULL);
9570   if (code->ext.actual->expr->rank == 0)
9571     {
9572       symbol_attribute attr;
9573       gfc_clear_attr (&attr);
9574       gfc_init_se (&argse, NULL);
9575       gfc_conv_expr (&argse, code->ext.actual->expr);
9576       gfc_add_block_to_block (&block, &argse.pre);
9577       gfc_add_block_to_block (&post_block, &argse.post);
9578       array = gfc_conv_scalar_to_descriptor (&argse, argse.expr, attr);
9579       array = gfc_build_addr_expr (NULL_TREE, array);
9580     }
9581   else
9582     {
9583       argse.want_pointer = 1;
9584       gfc_conv_expr_descriptor (&argse, code->ext.actual->expr);
9585       array = argse.expr;
9586     }
9587   gfc_add_block_to_block (&block, &argse.pre);
9588   gfc_add_block_to_block (&post_block, &argse.post);
9589
9590   if (code->ext.actual->expr->ts.type == BT_CHARACTER)
9591     strlen = argse.string_length;
9592   else
9593     strlen = integer_zero_node;
9594
9595   /* image_index.  */
9596   if (image_idx_expr)
9597     {
9598       gfc_init_se (&argse, NULL);
9599       gfc_conv_expr (&argse, image_idx_expr);
9600       gfc_add_block_to_block (&block, &argse.pre);
9601       gfc_add_block_to_block (&post_block, &argse.post);
9602       image_index = fold_convert (integer_type_node, argse.expr);
9603     }
9604   else
9605     image_index = integer_zero_node;
9606
9607   /* errmsg.  */
9608   if (errmsg_expr)
9609     {
9610       gfc_init_se (&argse, NULL);
9611       gfc_conv_expr (&argse, errmsg_expr);
9612       gfc_add_block_to_block (&block, &argse.pre);
9613       gfc_add_block_to_block (&post_block, &argse.post);
9614       errmsg = argse.expr;
9615       errmsg_len = fold_convert (integer_type_node, argse.string_length);
9616     }
9617   else
9618     {
9619       errmsg = null_pointer_node;
9620       errmsg_len = integer_zero_node;
9621     }
9622
9623   /* Generate the function call.  */
9624   switch (code->resolved_isym->id)
9625     {
9626     case GFC_ISYM_CO_BROADCAST:
9627       fndecl = gfor_fndecl_co_broadcast;
9628       break;
9629     case GFC_ISYM_CO_MAX:
9630       fndecl = gfor_fndecl_co_max;
9631       break;
9632     case GFC_ISYM_CO_MIN:
9633       fndecl = gfor_fndecl_co_min;
9634       break;
9635     case GFC_ISYM_CO_REDUCE:
9636       fndecl = gfor_fndecl_co_reduce;
9637       break;
9638     case GFC_ISYM_CO_SUM:
9639       fndecl = gfor_fndecl_co_sum;
9640       break;
9641     default:
9642       gcc_unreachable ();
9643     }
9644
9645   if (code->resolved_isym->id == GFC_ISYM_CO_SUM
9646       || code->resolved_isym->id == GFC_ISYM_CO_BROADCAST)
9647     fndecl = build_call_expr_loc (input_location, fndecl, 5, array,
9648                                   image_index, stat, errmsg, errmsg_len);
9649   else if (code->resolved_isym->id != GFC_ISYM_CO_REDUCE)
9650     fndecl = build_call_expr_loc (input_location, fndecl, 6, array, image_index,
9651                                   stat, errmsg, strlen, errmsg_len);
9652   else
9653     {
9654       tree opr, opr_flags;
9655
9656       // FIXME: Handle TS29113's bind(C) strings with descriptor.
9657       int opr_flag_int;
9658       if (gfc_is_proc_ptr_comp (opr_expr))
9659         {
9660           gfc_symbol *sym = gfc_get_proc_ptr_comp (opr_expr)->ts.interface;
9661           opr_flag_int = sym->attr.dimension
9662                          || (sym->ts.type == BT_CHARACTER
9663                              && !sym->attr.is_bind_c)
9664                          ? GFC_CAF_BYREF : 0;
9665           opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
9666                           && !sym->attr.is_bind_c
9667                           ? GFC_CAF_HIDDENLEN : 0;
9668           opr_flag_int |= sym->formal->sym->attr.value ? GFC_CAF_ARG_VALUE : 0;
9669         }
9670       else
9671         {
9672           opr_flag_int = gfc_return_by_reference (opr_expr->symtree->n.sym)
9673                          ? GFC_CAF_BYREF : 0;
9674           opr_flag_int |= opr_expr->ts.type == BT_CHARACTER
9675                           && !opr_expr->symtree->n.sym->attr.is_bind_c
9676                           ? GFC_CAF_HIDDENLEN : 0;
9677           opr_flag_int |= opr_expr->symtree->n.sym->formal->sym->attr.value
9678                           ? GFC_CAF_ARG_VALUE : 0;
9679         }
9680       opr_flags = build_int_cst (integer_type_node, opr_flag_int);
9681       gfc_conv_expr (&argse, opr_expr);
9682       opr = argse.expr;
9683       fndecl = build_call_expr_loc (input_location, fndecl, 8, array, opr, opr_flags,
9684                                     image_index, stat, errmsg, strlen, errmsg_len);
9685     }
9686
9687   gfc_add_expr_to_block (&block, fndecl);
9688   gfc_add_block_to_block (&block, &post_block);
9689
9690   return gfc_finish_block (&block);
9691 }
9692
9693
9694 static tree
9695 conv_intrinsic_atomic_op (gfc_code *code)
9696 {
9697   gfc_se argse;
9698   tree tmp, atom, value, old = NULL_TREE, stat = NULL_TREE;
9699   stmtblock_t block, post_block;
9700   gfc_expr *atom_expr = code->ext.actual->expr;
9701   gfc_expr *stat_expr;
9702   built_in_function fn;
9703
9704   if (atom_expr->expr_type == EXPR_FUNCTION
9705       && atom_expr->value.function.isym
9706       && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9707     atom_expr = atom_expr->value.function.actual->expr;
9708
9709   gfc_start_block (&block);
9710   gfc_init_block (&post_block);
9711
9712   gfc_init_se (&argse, NULL);
9713   argse.want_pointer = 1;
9714   gfc_conv_expr (&argse, atom_expr);
9715   gfc_add_block_to_block (&block, &argse.pre);
9716   gfc_add_block_to_block (&post_block, &argse.post);
9717   atom = argse.expr;
9718
9719   gfc_init_se (&argse, NULL);
9720   if (flag_coarray == GFC_FCOARRAY_LIB
9721       && code->ext.actual->next->expr->ts.kind == atom_expr->ts.kind)
9722     argse.want_pointer = 1;
9723   gfc_conv_expr (&argse, code->ext.actual->next->expr);
9724   gfc_add_block_to_block (&block, &argse.pre);
9725   gfc_add_block_to_block (&post_block, &argse.post);
9726   value = argse.expr;
9727
9728   switch (code->resolved_isym->id)
9729     {
9730     case GFC_ISYM_ATOMIC_ADD:
9731     case GFC_ISYM_ATOMIC_AND:
9732     case GFC_ISYM_ATOMIC_DEF:
9733     case GFC_ISYM_ATOMIC_OR:
9734     case GFC_ISYM_ATOMIC_XOR:
9735       stat_expr = code->ext.actual->next->next->expr;
9736       if (flag_coarray == GFC_FCOARRAY_LIB)
9737         old = null_pointer_node;
9738       break;
9739     default:
9740       gfc_init_se (&argse, NULL);
9741       if (flag_coarray == GFC_FCOARRAY_LIB)
9742         argse.want_pointer = 1;
9743       gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
9744       gfc_add_block_to_block (&block, &argse.pre);
9745       gfc_add_block_to_block (&post_block, &argse.post);
9746       old = argse.expr;
9747       stat_expr = code->ext.actual->next->next->next->expr;
9748     }
9749
9750   /* STAT=  */
9751   if (stat_expr != NULL)
9752     {
9753       gcc_assert (stat_expr->expr_type == EXPR_VARIABLE);
9754       gfc_init_se (&argse, NULL);
9755       if (flag_coarray == GFC_FCOARRAY_LIB)
9756         argse.want_pointer = 1;
9757       gfc_conv_expr_val (&argse, stat_expr);
9758       gfc_add_block_to_block (&block, &argse.pre);
9759       gfc_add_block_to_block (&post_block, &argse.post);
9760       stat = argse.expr;
9761     }
9762   else if (flag_coarray == GFC_FCOARRAY_LIB)
9763     stat = null_pointer_node;
9764
9765   if (flag_coarray == GFC_FCOARRAY_LIB)
9766     {
9767       tree image_index, caf_decl, offset, token;
9768       int op;
9769
9770       switch (code->resolved_isym->id)
9771         {
9772         case GFC_ISYM_ATOMIC_ADD:
9773         case GFC_ISYM_ATOMIC_FETCH_ADD:
9774           op = (int) GFC_CAF_ATOMIC_ADD;
9775           break;
9776         case GFC_ISYM_ATOMIC_AND:
9777         case GFC_ISYM_ATOMIC_FETCH_AND:
9778           op = (int) GFC_CAF_ATOMIC_AND;
9779           break;
9780         case GFC_ISYM_ATOMIC_OR:
9781         case GFC_ISYM_ATOMIC_FETCH_OR:
9782           op = (int) GFC_CAF_ATOMIC_OR;
9783           break;
9784         case GFC_ISYM_ATOMIC_XOR:
9785         case GFC_ISYM_ATOMIC_FETCH_XOR:
9786           op = (int) GFC_CAF_ATOMIC_XOR;
9787           break;
9788         case GFC_ISYM_ATOMIC_DEF:
9789           op = 0;  /* Unused.  */
9790           break;
9791         default:
9792           gcc_unreachable ();
9793         }
9794
9795       caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9796       if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9797         caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9798
9799       if (gfc_is_coindexed (atom_expr))
9800         image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9801       else
9802         image_index = integer_zero_node;
9803
9804       if (!POINTER_TYPE_P (TREE_TYPE (value)))
9805         {
9806           tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
9807           gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), value));
9808           value = gfc_build_addr_expr (NULL_TREE, tmp);
9809         }
9810
9811       gfc_init_se (&argse, NULL);
9812       gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
9813                                 atom_expr);
9814
9815       gfc_add_block_to_block (&block, &argse.pre);
9816       if (code->resolved_isym->id == GFC_ISYM_ATOMIC_DEF)
9817         tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_def, 7,
9818                                    token, offset, image_index, value, stat,
9819                                    build_int_cst (integer_type_node,
9820                                                   (int) atom_expr->ts.type),
9821                                    build_int_cst (integer_type_node,
9822                                                   (int) atom_expr->ts.kind));
9823       else
9824         tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_op, 9,
9825                                    build_int_cst (integer_type_node, op),
9826                                    token, offset, image_index, value, old, stat,
9827                                    build_int_cst (integer_type_node,
9828                                                   (int) atom_expr->ts.type),
9829                                    build_int_cst (integer_type_node,
9830                                                   (int) atom_expr->ts.kind));
9831
9832       gfc_add_expr_to_block (&block, tmp);
9833       gfc_add_block_to_block (&block, &argse.post);
9834       gfc_add_block_to_block (&block, &post_block);
9835       return gfc_finish_block (&block);
9836     }
9837
9838
9839   switch (code->resolved_isym->id)
9840     {
9841     case GFC_ISYM_ATOMIC_ADD:
9842     case GFC_ISYM_ATOMIC_FETCH_ADD:
9843       fn = BUILT_IN_ATOMIC_FETCH_ADD_N;
9844       break;
9845     case GFC_ISYM_ATOMIC_AND:
9846     case GFC_ISYM_ATOMIC_FETCH_AND:
9847       fn = BUILT_IN_ATOMIC_FETCH_AND_N;
9848       break;
9849     case GFC_ISYM_ATOMIC_DEF:
9850       fn = BUILT_IN_ATOMIC_STORE_N;
9851       break;
9852     case GFC_ISYM_ATOMIC_OR:
9853     case GFC_ISYM_ATOMIC_FETCH_OR:
9854       fn = BUILT_IN_ATOMIC_FETCH_OR_N;
9855       break;
9856     case GFC_ISYM_ATOMIC_XOR:
9857     case GFC_ISYM_ATOMIC_FETCH_XOR:
9858       fn = BUILT_IN_ATOMIC_FETCH_XOR_N;
9859       break;
9860     default:
9861       gcc_unreachable ();
9862     }
9863
9864   tmp = TREE_TYPE (TREE_TYPE (atom));
9865   fn = (built_in_function) ((int) fn
9866                             + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9867                             + 1);
9868   tmp = builtin_decl_explicit (fn);
9869   tree itype = TREE_TYPE (TREE_TYPE (atom));
9870   tmp = builtin_decl_explicit (fn);
9871
9872   switch (code->resolved_isym->id)
9873     {
9874     case GFC_ISYM_ATOMIC_ADD:
9875     case GFC_ISYM_ATOMIC_AND:
9876     case GFC_ISYM_ATOMIC_DEF:
9877     case GFC_ISYM_ATOMIC_OR:
9878     case GFC_ISYM_ATOMIC_XOR:
9879       tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9880                                  fold_convert (itype, value),
9881                                  build_int_cst (NULL, MEMMODEL_RELAXED));
9882       gfc_add_expr_to_block (&block, tmp);
9883       break;
9884     default:
9885       tmp = build_call_expr_loc (input_location, tmp, 3, atom,
9886                                  fold_convert (itype, value),
9887                                  build_int_cst (NULL, MEMMODEL_RELAXED));
9888       gfc_add_modify (&block, old, fold_convert (TREE_TYPE (old), tmp));
9889       break;
9890     }
9891
9892   if (stat != NULL_TREE)
9893     gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
9894   gfc_add_block_to_block (&block, &post_block);
9895   return gfc_finish_block (&block);
9896 }
9897
9898
9899 static tree
9900 conv_intrinsic_atomic_ref (gfc_code *code)
9901 {
9902   gfc_se argse;
9903   tree tmp, atom, value, stat = NULL_TREE;
9904   stmtblock_t block, post_block;
9905   built_in_function fn;
9906   gfc_expr *atom_expr = code->ext.actual->next->expr;
9907
9908   if (atom_expr->expr_type == EXPR_FUNCTION
9909       && atom_expr->value.function.isym
9910       && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
9911     atom_expr = atom_expr->value.function.actual->expr;
9912
9913   gfc_start_block (&block);
9914   gfc_init_block (&post_block);
9915   gfc_init_se (&argse, NULL);
9916   argse.want_pointer = 1;
9917   gfc_conv_expr (&argse, atom_expr);
9918   gfc_add_block_to_block (&block, &argse.pre);
9919   gfc_add_block_to_block (&post_block, &argse.post);
9920   atom = argse.expr;
9921
9922   gfc_init_se (&argse, NULL);
9923   if (flag_coarray == GFC_FCOARRAY_LIB
9924       && code->ext.actual->expr->ts.kind == atom_expr->ts.kind)
9925     argse.want_pointer = 1;
9926   gfc_conv_expr (&argse, code->ext.actual->expr);
9927   gfc_add_block_to_block (&block, &argse.pre);
9928   gfc_add_block_to_block (&post_block, &argse.post);
9929   value = argse.expr;
9930
9931   /* STAT=  */
9932   if (code->ext.actual->next->next->expr != NULL)
9933     {
9934       gcc_assert (code->ext.actual->next->next->expr->expr_type
9935                   == EXPR_VARIABLE);
9936       gfc_init_se (&argse, NULL);
9937       if (flag_coarray == GFC_FCOARRAY_LIB)
9938         argse.want_pointer = 1;
9939       gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
9940       gfc_add_block_to_block (&block, &argse.pre);
9941       gfc_add_block_to_block (&post_block, &argse.post);
9942       stat = argse.expr;
9943     }
9944   else if (flag_coarray == GFC_FCOARRAY_LIB)
9945     stat = null_pointer_node;
9946
9947   if (flag_coarray == GFC_FCOARRAY_LIB)
9948     {
9949       tree image_index, caf_decl, offset, token;
9950       tree orig_value = NULL_TREE, vardecl = NULL_TREE;
9951
9952       caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
9953       if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
9954         caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
9955
9956       if (gfc_is_coindexed (atom_expr))
9957         image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
9958       else
9959         image_index = integer_zero_node;
9960
9961       gfc_init_se (&argse, NULL);
9962       gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
9963                                 atom_expr);
9964       gfc_add_block_to_block (&block, &argse.pre);
9965
9966       /* Different type, need type conversion.  */
9967       if (!POINTER_TYPE_P (TREE_TYPE (value)))
9968         {
9969           vardecl = gfc_create_var (TREE_TYPE (TREE_TYPE (atom)), "value");
9970           orig_value = value;
9971           value = gfc_build_addr_expr (NULL_TREE, vardecl);
9972         }
9973
9974       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_ref, 7,
9975                                  token, offset, image_index, value, stat,
9976                                  build_int_cst (integer_type_node,
9977                                                 (int) atom_expr->ts.type),
9978                                  build_int_cst (integer_type_node,
9979                                                 (int) atom_expr->ts.kind));
9980       gfc_add_expr_to_block (&block, tmp);
9981       if (vardecl != NULL_TREE)
9982         gfc_add_modify (&block, orig_value,
9983                         fold_convert (TREE_TYPE (orig_value), vardecl));
9984       gfc_add_block_to_block (&block, &argse.post);
9985       gfc_add_block_to_block (&block, &post_block);
9986       return gfc_finish_block (&block);
9987     }
9988
9989   tmp = TREE_TYPE (TREE_TYPE (atom));
9990   fn = (built_in_function) ((int) BUILT_IN_ATOMIC_LOAD_N
9991                             + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
9992                             + 1);
9993   tmp = builtin_decl_explicit (fn);
9994   tmp = build_call_expr_loc (input_location, tmp, 2, atom,
9995                              build_int_cst (integer_type_node,
9996                                             MEMMODEL_RELAXED));
9997   gfc_add_modify (&block, value, fold_convert (TREE_TYPE (value), tmp));
9998
9999   if (stat != NULL_TREE)
10000     gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10001   gfc_add_block_to_block (&block, &post_block);
10002   return gfc_finish_block (&block);
10003 }
10004
10005
10006 static tree
10007 conv_intrinsic_atomic_cas (gfc_code *code)
10008 {
10009   gfc_se argse;
10010   tree tmp, atom, old, new_val, comp, stat = NULL_TREE;
10011   stmtblock_t block, post_block;
10012   built_in_function fn;
10013   gfc_expr *atom_expr = code->ext.actual->expr;
10014
10015   if (atom_expr->expr_type == EXPR_FUNCTION
10016       && atom_expr->value.function.isym
10017       && atom_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10018     atom_expr = atom_expr->value.function.actual->expr;
10019
10020   gfc_init_block (&block);
10021   gfc_init_block (&post_block);
10022   gfc_init_se (&argse, NULL);
10023   argse.want_pointer = 1;
10024   gfc_conv_expr (&argse, atom_expr);
10025   atom = argse.expr;
10026
10027   gfc_init_se (&argse, NULL);
10028   if (flag_coarray == GFC_FCOARRAY_LIB)
10029     argse.want_pointer = 1;
10030   gfc_conv_expr (&argse, code->ext.actual->next->expr);
10031   gfc_add_block_to_block (&block, &argse.pre);
10032   gfc_add_block_to_block (&post_block, &argse.post);
10033   old = argse.expr;
10034
10035   gfc_init_se (&argse, NULL);
10036   if (flag_coarray == GFC_FCOARRAY_LIB)
10037     argse.want_pointer = 1;
10038   gfc_conv_expr (&argse, code->ext.actual->next->next->expr);
10039   gfc_add_block_to_block (&block, &argse.pre);
10040   gfc_add_block_to_block (&post_block, &argse.post);
10041   comp = argse.expr;
10042
10043   gfc_init_se (&argse, NULL);
10044   if (flag_coarray == GFC_FCOARRAY_LIB
10045       && code->ext.actual->next->next->next->expr->ts.kind
10046          == atom_expr->ts.kind)
10047     argse.want_pointer = 1;
10048   gfc_conv_expr (&argse, code->ext.actual->next->next->next->expr);
10049   gfc_add_block_to_block (&block, &argse.pre);
10050   gfc_add_block_to_block (&post_block, &argse.post);
10051   new_val = argse.expr;
10052
10053   /* STAT=  */
10054   if (code->ext.actual->next->next->next->next->expr != NULL)
10055     {
10056       gcc_assert (code->ext.actual->next->next->next->next->expr->expr_type
10057                   == EXPR_VARIABLE);
10058       gfc_init_se (&argse, NULL);
10059       if (flag_coarray == GFC_FCOARRAY_LIB)
10060         argse.want_pointer = 1;
10061       gfc_conv_expr_val (&argse,
10062                          code->ext.actual->next->next->next->next->expr);
10063       gfc_add_block_to_block (&block, &argse.pre);
10064       gfc_add_block_to_block (&post_block, &argse.post);
10065       stat = argse.expr;
10066     }
10067   else if (flag_coarray == GFC_FCOARRAY_LIB)
10068     stat = null_pointer_node;
10069
10070   if (flag_coarray == GFC_FCOARRAY_LIB)
10071     {
10072       tree image_index, caf_decl, offset, token;
10073
10074       caf_decl = gfc_get_tree_for_caf_expr (atom_expr);
10075       if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
10076         caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
10077
10078       if (gfc_is_coindexed (atom_expr))
10079         image_index = gfc_caf_get_image_index (&block, atom_expr, caf_decl);
10080       else
10081         image_index = integer_zero_node;
10082
10083       if (TREE_TYPE (TREE_TYPE (new_val)) != TREE_TYPE (TREE_TYPE (old)))
10084         {
10085           tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "new");
10086           gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), new_val));
10087           new_val = gfc_build_addr_expr (NULL_TREE, tmp);
10088         }
10089
10090       /* Convert a constant to a pointer.  */
10091       if (!POINTER_TYPE_P (TREE_TYPE (comp)))
10092         {
10093           tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (old)), "comp");
10094           gfc_add_modify (&block, tmp, fold_convert (TREE_TYPE (tmp), comp));
10095           comp = gfc_build_addr_expr (NULL_TREE, tmp);
10096         }
10097
10098       gfc_init_se (&argse, NULL);
10099       gfc_get_caf_token_offset (&argse, &token, &offset, caf_decl, atom,
10100                                 atom_expr);
10101       gfc_add_block_to_block (&block, &argse.pre);
10102
10103       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_atomic_cas, 9,
10104                                  token, offset, image_index, old, comp, new_val,
10105                                  stat, build_int_cst (integer_type_node,
10106                                                       (int) atom_expr->ts.type),
10107                                  build_int_cst (integer_type_node,
10108                                                 (int) atom_expr->ts.kind));
10109       gfc_add_expr_to_block (&block, tmp);
10110       gfc_add_block_to_block (&block, &argse.post);
10111       gfc_add_block_to_block (&block, &post_block);
10112       return gfc_finish_block (&block);
10113     }
10114
10115   tmp = TREE_TYPE (TREE_TYPE (atom));
10116   fn = (built_in_function) ((int) BUILT_IN_ATOMIC_COMPARE_EXCHANGE_N
10117                             + exact_log2 (tree_to_uhwi (TYPE_SIZE_UNIT (tmp)))
10118                             + 1);
10119   tmp = builtin_decl_explicit (fn);
10120
10121   gfc_add_modify (&block, old, comp);
10122   tmp = build_call_expr_loc (input_location, tmp, 6, atom,
10123                              gfc_build_addr_expr (NULL, old),
10124                              fold_convert (TREE_TYPE (old), new_val),
10125                              boolean_false_node,
10126                              build_int_cst (NULL, MEMMODEL_RELAXED),
10127                              build_int_cst (NULL, MEMMODEL_RELAXED));
10128   gfc_add_expr_to_block (&block, tmp);
10129
10130   if (stat != NULL_TREE)
10131     gfc_add_modify (&block, stat, build_int_cst (TREE_TYPE (stat), 0));
10132   gfc_add_block_to_block (&block, &post_block);
10133   return gfc_finish_block (&block);
10134 }
10135
10136 static tree
10137 conv_intrinsic_event_query (gfc_code *code)
10138 {
10139   gfc_se se, argse;
10140   tree stat = NULL_TREE, stat2 = NULL_TREE;
10141   tree count = NULL_TREE, count2 = NULL_TREE;
10142
10143   gfc_expr *event_expr = code->ext.actual->expr;
10144
10145   if (code->ext.actual->next->next->expr)
10146     {
10147       gcc_assert (code->ext.actual->next->next->expr->expr_type
10148                   == EXPR_VARIABLE);
10149       gfc_init_se (&argse, NULL);
10150       gfc_conv_expr_val (&argse, code->ext.actual->next->next->expr);
10151       stat = argse.expr;
10152     }
10153   else if (flag_coarray == GFC_FCOARRAY_LIB)
10154     stat = null_pointer_node;
10155
10156   if (code->ext.actual->next->expr)
10157     {
10158       gcc_assert (code->ext.actual->next->expr->expr_type == EXPR_VARIABLE);
10159       gfc_init_se (&argse, NULL);
10160       gfc_conv_expr_val (&argse, code->ext.actual->next->expr);
10161       count = argse.expr;
10162     }
10163
10164   gfc_start_block (&se.pre);
10165   if (flag_coarray == GFC_FCOARRAY_LIB)
10166     {
10167       tree tmp, token, image_index;
10168       tree index = size_zero_node;
10169
10170       if (event_expr->expr_type == EXPR_FUNCTION
10171           && event_expr->value.function.isym
10172           && event_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
10173         event_expr = event_expr->value.function.actual->expr;
10174
10175       tree caf_decl = gfc_get_tree_for_caf_expr (event_expr);
10176
10177       if (event_expr->symtree->n.sym->ts.type != BT_DERIVED
10178           || event_expr->symtree->n.sym->ts.u.derived->from_intmod
10179              != INTMOD_ISO_FORTRAN_ENV
10180           || event_expr->symtree->n.sym->ts.u.derived->intmod_sym_id
10181              != ISOFORTRAN_EVENT_TYPE)
10182         {
10183           gfc_error ("Sorry, the event component of derived type at %L is not "
10184                      "yet supported", &event_expr->where);
10185           return NULL_TREE;
10186         }
10187
10188       if (gfc_is_coindexed (event_expr))
10189         {
10190           gfc_error ("The event variable at %L shall not be coindexed ",
10191                      &event_expr->where);
10192           return NULL_TREE;
10193         }
10194
10195       image_index = integer_zero_node;
10196
10197       gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE,
10198                                 event_expr);
10199
10200       /* For arrays, obtain the array index.  */
10201       if (gfc_expr_attr (event_expr).dimension)
10202         {
10203           tree desc, tmp, extent, lbound, ubound;
10204           gfc_array_ref *ar, ar2;
10205           int i;
10206
10207           /* TODO: Extend this, once DT components are supported.  */
10208           ar = &event_expr->ref->u.ar;
10209           ar2 = *ar;
10210           memset (ar, '\0', sizeof (*ar));
10211           ar->as = ar2.as;
10212           ar->type = AR_FULL;
10213
10214           gfc_init_se (&argse, NULL);
10215           argse.descriptor_only = 1;
10216           gfc_conv_expr_descriptor (&argse, event_expr);
10217           gfc_add_block_to_block (&se.pre, &argse.pre);
10218           desc = argse.expr;
10219           *ar = ar2;
10220
10221           extent = integer_one_node;
10222           for (i = 0; i < ar->dimen; i++)
10223             {
10224               gfc_init_se (&argse, NULL);
10225               gfc_conv_expr_type (&argse, ar->start[i], integer_type_node);
10226               gfc_add_block_to_block (&argse.pre, &argse.pre);
10227               lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
10228               tmp = fold_build2_loc (input_location, MINUS_EXPR,
10229                                      integer_type_node, argse.expr,
10230                                      fold_convert(integer_type_node, lbound));
10231               tmp = fold_build2_loc (input_location, MULT_EXPR,
10232                                      integer_type_node, extent, tmp);
10233               index = fold_build2_loc (input_location, PLUS_EXPR,
10234                                        integer_type_node, index, tmp);
10235               if (i < ar->dimen - 1)
10236                 {
10237                   ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
10238                   tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
10239                   tmp = fold_convert (integer_type_node, tmp);
10240                   extent = fold_build2_loc (input_location, MULT_EXPR,
10241                                             integer_type_node, extent, tmp);
10242                 }
10243             }
10244         }
10245
10246       if (count != null_pointer_node && TREE_TYPE (count) != integer_type_node)
10247         {
10248           count2 = count;
10249           count = gfc_create_var (integer_type_node, "count");
10250         }
10251
10252       if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node)
10253         {
10254           stat2 = stat;
10255           stat = gfc_create_var (integer_type_node, "stat");
10256         }
10257
10258       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_query, 5,
10259                                    token, index, image_index, count
10260                                    ? gfc_build_addr_expr (NULL, count) : count,
10261                                    stat != null_pointer_node
10262                                    ? gfc_build_addr_expr (NULL, stat) : stat);
10263       gfc_add_expr_to_block (&se.pre, tmp);
10264
10265       if (count2 != NULL_TREE)
10266         gfc_add_modify (&se.pre, count2,
10267                         fold_convert (TREE_TYPE (count2), count));
10268
10269       if (stat2 != NULL_TREE)
10270         gfc_add_modify (&se.pre, stat2,
10271                         fold_convert (TREE_TYPE (stat2), stat));
10272
10273       return gfc_finish_block (&se.pre);
10274     }
10275
10276   gfc_init_se (&argse, NULL);
10277   gfc_conv_expr_val (&argse, code->ext.actual->expr);
10278   gfc_add_modify (&se.pre, count, fold_convert (TREE_TYPE (count), argse.expr));
10279
10280   if (stat != NULL_TREE)
10281     gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0));
10282
10283   return gfc_finish_block (&se.pre);
10284 }
10285
10286 static tree
10287 conv_intrinsic_move_alloc (gfc_code *code)
10288 {
10289   stmtblock_t block;
10290   gfc_expr *from_expr, *to_expr;
10291   gfc_expr *to_expr2, *from_expr2 = NULL;
10292   gfc_se from_se, to_se;
10293   tree tmp;
10294   bool coarray;
10295
10296   gfc_start_block (&block);
10297
10298   from_expr = code->ext.actual->expr;
10299   to_expr = code->ext.actual->next->expr;
10300
10301   gfc_init_se (&from_se, NULL);
10302   gfc_init_se (&to_se, NULL);
10303
10304   gcc_assert (from_expr->ts.type != BT_CLASS
10305               || to_expr->ts.type == BT_CLASS);
10306   coarray = gfc_get_corank (from_expr) != 0;
10307
10308   if (from_expr->rank == 0 && !coarray)
10309     {
10310       if (from_expr->ts.type != BT_CLASS)
10311         from_expr2 = from_expr;
10312       else
10313         {
10314           from_expr2 = gfc_copy_expr (from_expr);
10315           gfc_add_data_component (from_expr2);
10316         }
10317
10318       if (to_expr->ts.type != BT_CLASS)
10319         to_expr2 = to_expr;
10320       else
10321         {
10322           to_expr2 = gfc_copy_expr (to_expr);
10323           gfc_add_data_component (to_expr2);
10324         }
10325
10326       from_se.want_pointer = 1;
10327       to_se.want_pointer = 1;
10328       gfc_conv_expr (&from_se, from_expr2);
10329       gfc_conv_expr (&to_se, to_expr2);
10330       gfc_add_block_to_block (&block, &from_se.pre);
10331       gfc_add_block_to_block (&block, &to_se.pre);
10332
10333       /* Deallocate "to".  */
10334       tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10335                                                true, to_expr, to_expr->ts);
10336       gfc_add_expr_to_block (&block, tmp);
10337
10338       /* Assign (_data) pointers.  */
10339       gfc_add_modify_loc (input_location, &block, to_se.expr,
10340                           fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
10341
10342       /* Set "from" to NULL.  */
10343       gfc_add_modify_loc (input_location, &block, from_se.expr,
10344                           fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
10345
10346       gfc_add_block_to_block (&block, &from_se.post);
10347       gfc_add_block_to_block (&block, &to_se.post);
10348
10349       /* Set _vptr.  */
10350       if (to_expr->ts.type == BT_CLASS)
10351         {
10352           gfc_symbol *vtab;
10353
10354           gfc_free_expr (to_expr2);
10355           gfc_init_se (&to_se, NULL);
10356           to_se.want_pointer = 1;
10357           gfc_add_vptr_component (to_expr);
10358           gfc_conv_expr (&to_se, to_expr);
10359
10360           if (from_expr->ts.type == BT_CLASS)
10361             {
10362               if (UNLIMITED_POLY (from_expr))
10363                 vtab = NULL;
10364               else
10365                 {
10366                   vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10367                   gcc_assert (vtab);
10368                 }
10369
10370               gfc_free_expr (from_expr2);
10371               gfc_init_se (&from_se, NULL);
10372               from_se.want_pointer = 1;
10373               gfc_add_vptr_component (from_expr);
10374               gfc_conv_expr (&from_se, from_expr);
10375               gfc_add_modify_loc (input_location, &block, to_se.expr,
10376                                   fold_convert (TREE_TYPE (to_se.expr),
10377                                   from_se.expr));
10378
10379               /* Reset _vptr component to declared type.  */
10380               if (vtab == NULL)
10381                 /* Unlimited polymorphic.  */
10382                 gfc_add_modify_loc (input_location, &block, from_se.expr,
10383                                     fold_convert (TREE_TYPE (from_se.expr),
10384                                                   null_pointer_node));
10385               else
10386                 {
10387                   tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10388                   gfc_add_modify_loc (input_location, &block, from_se.expr,
10389                                       fold_convert (TREE_TYPE (from_se.expr), tmp));
10390                 }
10391             }
10392           else
10393             {
10394               vtab = gfc_find_vtab (&from_expr->ts);
10395               gcc_assert (vtab);
10396               tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10397               gfc_add_modify_loc (input_location, &block, to_se.expr,
10398                                   fold_convert (TREE_TYPE (to_se.expr), tmp));
10399             }
10400         }
10401
10402       if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10403         {
10404           gfc_add_modify_loc (input_location, &block, to_se.string_length,
10405                               fold_convert (TREE_TYPE (to_se.string_length),
10406                                             from_se.string_length));
10407           if (from_expr->ts.deferred)
10408             gfc_add_modify_loc (input_location, &block, from_se.string_length,
10409                         build_int_cst (TREE_TYPE (from_se.string_length), 0));
10410         }
10411
10412       return gfc_finish_block (&block);
10413     }
10414
10415   /* Update _vptr component.  */
10416   if (to_expr->ts.type == BT_CLASS)
10417     {
10418       gfc_symbol *vtab;
10419
10420       to_se.want_pointer = 1;
10421       to_expr2 = gfc_copy_expr (to_expr);
10422       gfc_add_vptr_component (to_expr2);
10423       gfc_conv_expr (&to_se, to_expr2);
10424
10425       if (from_expr->ts.type == BT_CLASS)
10426         {
10427           if (UNLIMITED_POLY (from_expr))
10428             vtab = NULL;
10429           else
10430             {
10431               vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
10432               gcc_assert (vtab);
10433             }
10434
10435           from_se.want_pointer = 1;
10436           from_expr2 = gfc_copy_expr (from_expr);
10437           gfc_add_vptr_component (from_expr2);
10438           gfc_conv_expr (&from_se, from_expr2);
10439           gfc_add_modify_loc (input_location, &block, to_se.expr,
10440                               fold_convert (TREE_TYPE (to_se.expr),
10441                               from_se.expr));
10442
10443           /* Reset _vptr component to declared type.  */
10444           if (vtab == NULL)
10445             /* Unlimited polymorphic.  */
10446             gfc_add_modify_loc (input_location, &block, from_se.expr,
10447                                 fold_convert (TREE_TYPE (from_se.expr),
10448                                               null_pointer_node));
10449           else
10450             {
10451               tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10452               gfc_add_modify_loc (input_location, &block, from_se.expr,
10453                                   fold_convert (TREE_TYPE (from_se.expr), tmp));
10454             }
10455         }
10456       else
10457         {
10458           vtab = gfc_find_vtab (&from_expr->ts);
10459           gcc_assert (vtab);
10460           tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
10461           gfc_add_modify_loc (input_location, &block, to_se.expr,
10462                               fold_convert (TREE_TYPE (to_se.expr), tmp));
10463         }
10464
10465       gfc_free_expr (to_expr2);
10466       gfc_init_se (&to_se, NULL);
10467
10468       if (from_expr->ts.type == BT_CLASS)
10469         {
10470           gfc_free_expr (from_expr2);
10471           gfc_init_se (&from_se, NULL);
10472         }
10473     }
10474
10475
10476   /* Deallocate "to".  */
10477   if (from_expr->rank == 0)
10478     {
10479       to_se.want_coarray = 1;
10480       from_se.want_coarray = 1;
10481     }
10482   gfc_conv_expr_descriptor (&to_se, to_expr);
10483   gfc_conv_expr_descriptor (&from_se, from_expr);
10484
10485   /* For coarrays, call SYNC ALL if TO is already deallocated as MOVE_ALLOC
10486      is an image control "statement", cf. IR F08/0040 in 12-006A.  */
10487   if (coarray && flag_coarray == GFC_FCOARRAY_LIB)
10488     {
10489       tree cond;
10490
10491       tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE,
10492                                         NULL_TREE, NULL_TREE, true, to_expr,
10493                                         GFC_CAF_COARRAY_DEALLOCATE_ONLY);
10494       gfc_add_expr_to_block (&block, tmp);
10495
10496       tmp = gfc_conv_descriptor_data_get (to_se.expr);
10497       cond = fold_build2_loc (input_location, EQ_EXPR,
10498                               boolean_type_node, tmp,
10499                               fold_convert (TREE_TYPE (tmp),
10500                                             null_pointer_node));
10501       tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all,
10502                                  3, null_pointer_node, null_pointer_node,
10503                                  build_int_cst (integer_type_node, 0));
10504
10505       tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
10506                              tmp, build_empty_stmt (input_location));
10507       gfc_add_expr_to_block (&block, tmp);
10508     }
10509   else
10510     {
10511       if (to_expr->ts.type == BT_DERIVED
10512           && to_expr->ts.u.derived->attr.alloc_comp)
10513         {
10514           tmp = gfc_deallocate_alloc_comp (to_expr->ts.u.derived,
10515                                            to_se.expr, to_expr->rank);
10516           gfc_add_expr_to_block (&block, tmp);
10517         }
10518
10519       tmp = gfc_conv_descriptor_data_get (to_se.expr);
10520       tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
10521                                         NULL_TREE, true, to_expr,
10522                                         GFC_CAF_COARRAY_NOCOARRAY);
10523       gfc_add_expr_to_block (&block, tmp);
10524     }
10525
10526   /* Move the pointer and update the array descriptor data.  */
10527   gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
10528
10529   /* Set "from" to NULL.  */
10530   tmp = gfc_conv_descriptor_data_get (from_se.expr);
10531   gfc_add_modify_loc (input_location, &block, tmp,
10532                       fold_convert (TREE_TYPE (tmp), null_pointer_node));
10533
10534
10535   if (to_expr->ts.type == BT_CHARACTER && to_expr->ts.deferred)
10536     {
10537       gfc_add_modify_loc (input_location, &block, to_se.string_length,
10538                           fold_convert (TREE_TYPE (to_se.string_length),
10539                                         from_se.string_length));
10540       if (from_expr->ts.deferred)
10541         gfc_add_modify_loc (input_location, &block, from_se.string_length,
10542                         build_int_cst (TREE_TYPE (from_se.string_length), 0));
10543     }
10544
10545   return gfc_finish_block (&block);
10546 }
10547
10548
10549 tree
10550 gfc_conv_intrinsic_subroutine (gfc_code *code)
10551 {
10552   tree res;
10553
10554   gcc_assert (code->resolved_isym);
10555
10556   switch (code->resolved_isym->id)
10557     {
10558     case GFC_ISYM_MOVE_ALLOC:
10559       res = conv_intrinsic_move_alloc (code);
10560       break;
10561
10562     case GFC_ISYM_ATOMIC_CAS:
10563       res = conv_intrinsic_atomic_cas (code);
10564       break;
10565
10566     case GFC_ISYM_ATOMIC_ADD:
10567     case GFC_ISYM_ATOMIC_AND:
10568     case GFC_ISYM_ATOMIC_DEF:
10569     case GFC_ISYM_ATOMIC_OR:
10570     case GFC_ISYM_ATOMIC_XOR:
10571     case GFC_ISYM_ATOMIC_FETCH_ADD:
10572     case GFC_ISYM_ATOMIC_FETCH_AND:
10573     case GFC_ISYM_ATOMIC_FETCH_OR:
10574     case GFC_ISYM_ATOMIC_FETCH_XOR:
10575       res = conv_intrinsic_atomic_op (code);
10576       break;
10577
10578     case GFC_ISYM_ATOMIC_REF:
10579       res = conv_intrinsic_atomic_ref (code);
10580       break;
10581
10582     case GFC_ISYM_EVENT_QUERY:
10583       res = conv_intrinsic_event_query (code);
10584       break;
10585
10586     case GFC_ISYM_C_F_POINTER:
10587     case GFC_ISYM_C_F_PROCPOINTER:
10588       res = conv_isocbinding_subroutine (code);
10589       break;
10590
10591     case GFC_ISYM_CAF_SEND:
10592       res = conv_caf_send (code);
10593       break;
10594
10595     case GFC_ISYM_CO_BROADCAST:
10596     case GFC_ISYM_CO_MIN:
10597     case GFC_ISYM_CO_MAX:
10598     case GFC_ISYM_CO_REDUCE:
10599     case GFC_ISYM_CO_SUM:
10600       res = conv_co_collective (code);
10601       break;
10602
10603     case GFC_ISYM_FREE:
10604       res = conv_intrinsic_free (code);
10605       break;
10606
10607     case GFC_ISYM_SYSTEM_CLOCK:
10608       res = conv_intrinsic_system_clock (code);
10609       break;
10610
10611     default:
10612       res = NULL_TREE;
10613       break;
10614     }
10615
10616   return res;
10617 }
10618
10619 #include "gt-fortran-trans-intrinsic.h"