gcc/fortran/trans-intrinsic.c

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