gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"         /* For UNITS_PER_WORD.  */
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"     /* For rest_of_decl_compilation/internal_error.  */
  32 #include "flags.h"
  33 #include "gfortran.h"
  34 #include "arith.h"
  35 #include "intrinsic.h"
  36 #include "trans.h"
  37 #include "trans-const.h"
  38 #include "trans-types.h"
  39 #include "trans-array.h"
  40 #include "defaults.h"
  41 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  42 #include "trans-stmt.h"
  43
  44 /* This maps fortran intrinsic math functions to external library or GCC
  45    builtin functions.  */
  46 typedef struct GTY(()) gfc_intrinsic_map_t {
  47   /* The explicit enum is required to work around inadequacies in the
  48      garbage collection/gengtype parsing mechanism.  */
  49   enum gfc_isym_id id;
  50
  51   /* Enum value from the "language-independent", aka C-centric, part
  52      of gcc, or END_BUILTINS of no such value set.  */
  53   enum built_in_function float_built_in;
  54   enum built_in_function double_built_in;
  55   enum built_in_function long_double_built_in;
  56   enum built_in_function complex_float_built_in;
  57   enum built_in_function complex_double_built_in;
  58   enum built_in_function complex_long_double_built_in;
  59
  60   /* True if the naming pattern is to prepend "c" for complex and
  61      append "f" for kind=4.  False if the naming pattern is to
  62      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  63   bool libm_name;
  64
  65   /* True if a complex version of the function exists.  */
  66   bool complex_available;
  67
  68   /* True if the function should be marked const.  */
  69   bool is_constant;
  70
  71   /* The base library name of this function.  */
  72   const char *name;
  73
  74   /* Cache decls created for the various operand types.  */
  75   tree real4_decl;
  76   tree real8_decl;
  77   tree real10_decl;
  78   tree real16_decl;
  79   tree complex4_decl;
  80   tree complex8_decl;
  81   tree complex10_decl;
  82   tree complex16_decl;
  83 }
  84 gfc_intrinsic_map_t;
  85
  86 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  87    defines complex variants of all of the entries in mathbuiltins.def
  88    except for atan2.  */
  89 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  90   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  91     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
  92     true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  93     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  94
  95 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
  96   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  97     BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
  98     BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
  99     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 100
 101 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 102   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 103     END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 104     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 106
 107 #define OTHER_BUILTIN(ID, NAME, TYPE) \
 108   { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 109     BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, false, true, NAME, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 112
 113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 114 {
 115   /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
 116      DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
 117      to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro.  */
 118 #include "mathbuiltins.def"
 119
 120   /* Functions in libgfortran.  */
 121   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
 122
 123   /* End the list.  */
 124   LIB_FUNCTION (NONE, NULL, false)
 125
 126 };
 127 #undef OTHER_BUILTIN
 128 #undef LIB_FUNCTION
 129 #undef DEFINE_MATH_BUILTIN
 130 #undef DEFINE_MATH_BUILTIN_C
 131
 132
 133 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 134
 135
 136 /* Find the correct variant of a given builtin from its argument.  */
 137 static tree
 138 builtin_decl_for_precision (enum built_in_function base_built_in,
 139                             int precision)
 140 {
 141   int i = END_BUILTINS;
 142
 143   gfc_intrinsic_map_t *m;
 144   for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
 145     ;
 146
 147   if (precision == TYPE_PRECISION (float_type_node))
 148     i = m->float_built_in;
 149   else if (precision == TYPE_PRECISION (double_type_node))
 150     i = m->double_built_in;
 151   else if (precision == TYPE_PRECISION (long_double_type_node))
 152     i = m->long_double_built_in;
 153
 154   return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]);
 155 }
 156
 157
 158 static tree
 159 builtin_decl_for_float_kind (enum built_in_function double_built_in, int kind)
 160 {
 161   int i = gfc_validate_kind (BT_REAL, kind, false);
 162   return builtin_decl_for_precision (double_built_in,
 163                                      gfc_real_kinds[i].mode_precision);
 164 }
 165
 166
 167 /* Evaluate the arguments to an intrinsic function.  The value
 168    of NARGS may be less than the actual number of arguments in EXPR
 169    to allow optional "KIND" arguments that are not included in the
 170    generated code to be ignored.  */
 171
 172 static void
 173 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 174                                   tree *argarray, int nargs)
 175 {
 176   gfc_actual_arglist *actual;
 177   gfc_expr *e;
 178   gfc_intrinsic_arg  *formal;
 179   gfc_se argse;
 180   int curr_arg;
 181
 182   formal = expr->value.function.isym->formal;
 183   actual = expr->value.function.actual;
 184
 185    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 186         actual = actual->next,
 187         formal = formal ? formal->next : NULL)
 188     {
 189       gcc_assert (actual);
 190       e = actual->expr;
 191       /* Skip omitted optional arguments.  */
 192       if (!e)
 193         {
 194           --curr_arg;
 195           continue;
 196         }
 197
 198       /* Evaluate the parameter.  This will substitute scalarized
 199          references automatically.  */
 200       gfc_init_se (&argse, se);
 201
 202       if (e->ts.type == BT_CHARACTER)
 203         {
 204           gfc_conv_expr (&argse, e);
 205           gfc_conv_string_parameter (&argse);
 206           argarray[curr_arg++] = argse.string_length;
 207           gcc_assert (curr_arg < nargs);
 208         }
 209       else
 210         gfc_conv_expr_val (&argse, e);
 211
 212       /* If an optional argument is itself an optional dummy argument,
 213          check its presence and substitute a null if absent.  */
 214       if (e->expr_type == EXPR_VARIABLE
 215             && e->symtree->n.sym->attr.optional
 216             && formal
 217             && formal->optional)
 218         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
 219
 220       gfc_add_block_to_block (&se->pre, &argse.pre);
 221       gfc_add_block_to_block (&se->post, &argse.post);
 222       argarray[curr_arg] = argse.expr;
 223     }
 224 }
 225
 226 /* Count the number of actual arguments to the intrinsic function EXPR
 227    including any "hidden" string length arguments.  */
 228
 229 static unsigned int
 230 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 231 {
 232   int n = 0;
 233   gfc_actual_arglist *actual;
 234
 235   for (actual = expr->value.function.actual; actual; actual = actual->next)
 236     {
 237       if (!actual->expr)
 238         continue;
 239
 240       if (actual->expr->ts.type == BT_CHARACTER)
 241         n += 2;
 242       else
 243         n++;
 244     }
 245
 246   return n;
 247 }
 248
 249
 250 /* Conversions between different types are output by the frontend as
 251    intrinsic functions.  We implement these directly with inline code.  */
 252
 253 static void
 254 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 255 {
 256   tree type;
 257   tree *args;
 258   int nargs;
 259
 260   nargs = gfc_intrinsic_argument_list_length (expr);
 261   args = (tree *) alloca (sizeof (tree) * nargs);
 262
 263   /* Evaluate all the arguments passed. Whilst we're only interested in the
 264      first one here, there are other parts of the front-end that assume this
 265      and will trigger an ICE if it's not the case.  */
 266   type = gfc_typenode_for_spec (&expr->ts);
 267   gcc_assert (expr->value.function.actual->expr);
 268   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 269
 270   /* Conversion between character kinds involves a call to a library
 271      function.  */
 272   if (expr->ts.type == BT_CHARACTER)
 273     {
 274       tree fndecl, var, addr, tmp;
 275
 276       if (expr->ts.kind == 1
 277           && expr->value.function.actual->expr->ts.kind == 4)
 278         fndecl = gfor_fndecl_convert_char4_to_char1;
 279       else if (expr->ts.kind == 4
 280                && expr->value.function.actual->expr->ts.kind == 1)
 281         fndecl = gfor_fndecl_convert_char1_to_char4;
 282       else
 283         gcc_unreachable ();
 284
 285       /* Create the variable storing the converted value.  */
 286       type = gfc_get_pchar_type (expr->ts.kind);
 287       var = gfc_create_var (type, "str");
 288       addr = gfc_build_addr_expr (build_pointer_type (type), var);
 289
 290       /* Call the library function that will perform the conversion.  */
 291       gcc_assert (nargs >= 2);
 292       tmp = build_call_expr_loc (input_location,
 293                              fndecl, 3, addr, args[0], args[1]);
 294       gfc_add_expr_to_block (&se->pre, tmp);
 295
 296       /* Free the temporary afterwards.  */
 297       tmp = gfc_call_free (var);
 298       gfc_add_expr_to_block (&se->post, tmp);
 299
 300       se->expr = var;
 301       se->string_length = args[0];
 302
 303       return;
 304     }
 305
 306   /* Conversion from complex to non-complex involves taking the real
 307      component of the value.  */
 308   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 309       && expr->ts.type != BT_COMPLEX)
 310     {
 311       tree artype;
 312
 313       artype = TREE_TYPE (TREE_TYPE (args[0]));
 314       args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 315     }
 316
 317   se->expr = convert (type, args[0]);
 318 }
 319
 320 /* This is needed because the gcc backend only implements
 321    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 322    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 323    Similarly for CEILING.  */
 324
 325 static tree
 326 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 327 {
 328   tree tmp;
 329   tree cond;
 330   tree argtype;
 331   tree intval;
 332
 333   argtype = TREE_TYPE (arg);
 334   arg = gfc_evaluate_now (arg, pblock);
 335
 336   intval = convert (type, arg);
 337   intval = gfc_evaluate_now (intval, pblock);
 338
 339   tmp = convert (argtype, intval);
 340   cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 341
 342   tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 343                      build_int_cst (type, 1));
 344   tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
 345   return tmp;
 346 }
 347
 348
 349 /* Round to nearest integer, away from zero.  */
 350
 351 static tree
 352 build_round_expr (tree arg, tree restype)
 353 {
 354   tree argtype;
 355   tree fn;
 356   bool longlong;
 357   int argprec, resprec;
 358
 359   argtype = TREE_TYPE (arg);
 360   argprec = TYPE_PRECISION (argtype);
 361   resprec = TYPE_PRECISION (restype);
 362
 363   /* Depending on the type of the result, choose the long int intrinsic
 364      (lround family) or long long intrinsic (llround).  We might also
 365      need to convert the result afterwards.  */
 366   if (resprec <= LONG_TYPE_SIZE)
 367     longlong = false;
 368   else if (resprec <= LONG_LONG_TYPE_SIZE)
 369     longlong = true;
 370   else
 371     gcc_unreachable ();
 372
 373   /* Now, depending on the argument type, we choose between intrinsics.  */
 374   if (longlong)
 375     fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
 376   else
 377     fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
 378
 379   return fold_convert (restype, build_call_expr_loc (input_location,
 380                                                  fn, 1, arg));
 381 }
 382
 383
 384 /* Convert a real to an integer using a specific rounding mode.
 385    Ideally we would just build the corresponding GENERIC node,
 386    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 387
 388 static tree
 389 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 390                enum rounding_mode op)
 391 {
 392   switch (op)
 393     {
 394     case RND_FLOOR:
 395       return build_fixbound_expr (pblock, arg, type, 0);
 396       break;
 397
 398     case RND_CEIL:
 399       return build_fixbound_expr (pblock, arg, type, 1);
 400       break;
 401
 402     case RND_ROUND:
 403       return build_round_expr (arg, type);
 404       break;
 405
 406     case RND_TRUNC:
 407       return fold_build1 (FIX_TRUNC_EXPR, type, arg);
 408       break;
 409
 410     default:
 411       gcc_unreachable ();
 412     }
 413 }
 414
 415
 416 /* Round a real value using the specified rounding mode.
 417    We use a temporary integer of that same kind size as the result.
 418    Values larger than those that can be represented by this kind are
 419    unchanged, as they will not be accurate enough to represent the
 420    rounding.
 421     huge = HUGE (KIND (a))
 422     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 423    */
 424
 425 static void
 426 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 427 {
 428   tree type;
 429   tree itype;
 430   tree arg[2];
 431   tree tmp;
 432   tree cond;
 433   tree decl;
 434   mpfr_t huge;
 435   int n, nargs;
 436   int kind;
 437
 438   kind = expr->ts.kind;
 439   nargs =  gfc_intrinsic_argument_list_length (expr);
 440
 441   decl = NULL_TREE;
 442   /* We have builtin functions for some cases.  */
 443   switch (op)
 444     {
 445     case RND_ROUND:
 446       decl = builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
 447       break;
 448
 449     case RND_TRUNC:
 450       decl = builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
 451       break;
 452
 453     default:
 454       gcc_unreachable ();
 455     }
 456
 457   /* Evaluate the argument.  */
 458   gcc_assert (expr->value.function.actual->expr);
 459   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
 460
 461   /* Use a builtin function if one exists.  */
 462   if (decl != NULL_TREE)
 463     {
 464       se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
 465       return;
 466     }
 467
 468   /* This code is probably redundant, but we'll keep it lying around just
 469      in case.  */
 470   type = gfc_typenode_for_spec (&expr->ts);
 471   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
 472
 473   /* Test if the value is too large to handle sensibly.  */
 474   gfc_set_model_kind (kind);
 475   mpfr_init (huge);
 476   n = gfc_validate_kind (BT_INTEGER, kind, false);
 477   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 478   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 479   cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
 480
 481   mpfr_neg (huge, huge, GFC_RND_MODE);
 482   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 483   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
 484   cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 485   itype = gfc_get_int_type (kind);
 486
 487   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
 488   tmp = convert (type, tmp);
 489   se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
 490   mpfr_clear (huge);
 491 }
 492
 493
 494 /* Convert to an integer using the specified rounding mode.  */
 495
 496 static void
 497 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 498 {
 499   tree type;
 500   tree *args;
 501   int nargs;
 502
 503   nargs = gfc_intrinsic_argument_list_length (expr);
 504   args = (tree *) alloca (sizeof (tree) * nargs);
 505
 506   /* Evaluate the argument, we process all arguments even though we only
 507      use the first one for code generation purposes.  */
 508   type = gfc_typenode_for_spec (&expr->ts);
 509   gcc_assert (expr->value.function.actual->expr);
 510   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 511
 512   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 513     {
 514       /* Conversion to a different integer kind.  */
 515       se->expr = convert (type, args[0]);
 516     }
 517   else
 518     {
 519       /* Conversion from complex to non-complex involves taking the real
 520          component of the value.  */
 521       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 522           && expr->ts.type != BT_COMPLEX)
 523         {
 524           tree artype;
 525
 526           artype = TREE_TYPE (TREE_TYPE (args[0]));
 527           args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 528         }
 529
 530       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 531     }
 532 }
 533
 534
 535 /* Get the imaginary component of a value.  */
 536
 537 static void
 538 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 539 {
 540   tree arg;
 541
 542   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 543   se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 544 }
 545
 546
 547 /* Get the complex conjugate of a value.  */
 548
 549 static void
 550 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 551 {
 552   tree arg;
 553
 554   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 555   se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 556 }
 557
 558
 559 /* Initialize function decls for library functions.  The external functions
 560    are created as required.  Builtin functions are added here.  */
 561
 562 void
 563 gfc_build_intrinsic_lib_fndecls (void)
 564 {
 565   gfc_intrinsic_map_t *m;
 566
 567   /* Add GCC builtin functions.  */
 568   for (m = gfc_intrinsic_map;
 569        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
 570     {
 571       if (m->float_built_in != END_BUILTINS)
 572         m->real4_decl = built_in_decls[m->float_built_in];
 573       if (m->complex_float_built_in != END_BUILTINS)
 574         m->complex4_decl = built_in_decls[m->complex_float_built_in];
 575       if (m->double_built_in != END_BUILTINS)
 576         m->real8_decl = built_in_decls[m->double_built_in];
 577       if (m->complex_double_built_in != END_BUILTINS)
 578         m->complex8_decl = built_in_decls[m->complex_double_built_in];
 579
 580       /* If real(kind=10) exists, it is always long double.  */
 581       if (m->long_double_built_in != END_BUILTINS)
 582         m->real10_decl = built_in_decls[m->long_double_built_in];
 583       if (m->complex_long_double_built_in != END_BUILTINS)
 584         m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
 585
 586       /* For now, we assume that if real(kind=16) exists, it is long double.
 587          Later, we will deal with __float128 and break this assumption.  */
 588       if (m->long_double_built_in != END_BUILTINS)
 589         m->real16_decl = built_in_decls[m->long_double_built_in];
 590       if (m->complex_long_double_built_in != END_BUILTINS)
 591         m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
 592     }
 593 }
 594
 595
 596 /* Create a fndecl for a simple intrinsic library function.  */
 597
 598 static tree
 599 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 600 {
 601   tree type;
 602   tree argtypes;
 603   tree fndecl;
 604   gfc_actual_arglist *actual;
 605   tree *pdecl;
 606   gfc_typespec *ts;
 607   char name[GFC_MAX_SYMBOL_LEN + 3];
 608
 609   ts = &expr->ts;
 610   if (ts->type == BT_REAL)
 611     {
 612       switch (ts->kind)
 613         {
 614         case 4:
 615           pdecl = &m->real4_decl;
 616           break;
 617         case 8:
 618           pdecl = &m->real8_decl;
 619           break;
 620         case 10:
 621           pdecl = &m->real10_decl;
 622           break;
 623         case 16:
 624           pdecl = &m->real16_decl;
 625           break;
 626         default:
 627           gcc_unreachable ();
 628         }
 629     }
 630   else if (ts->type == BT_COMPLEX)
 631     {
 632       gcc_assert (m->complex_available);
 633
 634       switch (ts->kind)
 635         {
 636         case 4:
 637           pdecl = &m->complex4_decl;
 638           break;
 639         case 8:
 640           pdecl = &m->complex8_decl;
 641           break;
 642         case 10:
 643           pdecl = &m->complex10_decl;
 644           break;
 645         case 16:
 646           pdecl = &m->complex16_decl;
 647           break;
 648         default:
 649           gcc_unreachable ();
 650         }
 651     }
 652   else
 653     gcc_unreachable ();
 654
 655   if (*pdecl)
 656     return *pdecl;
 657
 658   if (m->libm_name)
 659     {
 660       int n = gfc_validate_kind (BT_REAL, ts->kind, false);
 661       if (gfc_real_kinds[n].c_float)
 662         snprintf (name, sizeof (name), "%s%s%s",
 663                   ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 664       else if (gfc_real_kinds[n].c_double)
 665         snprintf (name, sizeof (name), "%s%s",
 666                   ts->type == BT_COMPLEX ? "c" : "", m->name);
 667       else if (gfc_real_kinds[n].c_long_double)
 668         snprintf (name, sizeof (name), "%s%s%s",
 669                   ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 670       else
 671         gcc_unreachable ();
 672     }
 673   else
 674     {
 675       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 676                 ts->type == BT_COMPLEX ? 'c' : 'r',
 677                 ts->kind);
 678     }
 679
 680   argtypes = NULL_TREE;
 681   for (actual = expr->value.function.actual; actual; actual = actual->next)
 682     {
 683       type = gfc_typenode_for_spec (&actual->expr->ts);
 684       argtypes = gfc_chainon_list (argtypes, type);
 685     }
 686   argtypes = gfc_chainon_list (argtypes, void_type_node);
 687   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 688   fndecl = build_decl (input_location,
 689                        FUNCTION_DECL, get_identifier (name), type);
 690
 691   /* Mark the decl as external.  */
 692   DECL_EXTERNAL (fndecl) = 1;
 693   TREE_PUBLIC (fndecl) = 1;
 694
 695   /* Mark it __attribute__((const)), if possible.  */
 696   TREE_READONLY (fndecl) = m->is_constant;
 697
 698   rest_of_decl_compilation (fndecl, 1, 0);
 699
 700   (*pdecl) = fndecl;
 701   return fndecl;
 702 }
 703
 704
 705 /* Convert an intrinsic function into an external or builtin call.  */
 706
 707 static void
 708 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 709 {
 710   gfc_intrinsic_map_t *m;
 711   tree fndecl;
 712   tree rettype;
 713   tree *args;
 714   unsigned int num_args;
 715   gfc_isym_id id;
 716
 717   id = expr->value.function.isym->id;
 718   /* Find the entry for this function.  */
 719   for (m = gfc_intrinsic_map;
 720        m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
 721     {
 722       if (id == m->id)
 723         break;
 724     }
 725
 726   if (m->id == GFC_ISYM_NONE)
 727     {
 728       internal_error ("Intrinsic function %s(%d) not recognized",
 729                       expr->value.function.name, id);
 730     }
 731
 732   /* Get the decl and generate the call.  */
 733   num_args = gfc_intrinsic_argument_list_length (expr);
 734   args = (tree *) alloca (sizeof (tree) * num_args);
 735
 736   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 737   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 738   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 739
 740   fndecl = build_addr (fndecl, current_function_decl);
 741   se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
 742 }
 743
 744
 745 /* If bounds-checking is enabled, create code to verify at runtime that the
 746    string lengths for both expressions are the same (needed for e.g. MERGE).
 747    If bounds-checking is not enabled, does nothing.  */
 748
 749 void
 750 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
 751                              tree a, tree b, stmtblock_t* target)
 752 {
 753   tree cond;
 754   tree name;
 755
 756   /* If bounds-checking is disabled, do nothing.  */
 757   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
 758     return;
 759
 760   /* Compare the two string lengths.  */
 761   cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
 762
 763   /* Output the runtime-check.  */
 764   name = gfc_build_cstring_const (intr_name);
 765   name = gfc_build_addr_expr (pchar_type_node, name);
 766   gfc_trans_runtime_check (true, false, cond, target, where,
 767                            "Unequal character lengths (%ld/%ld) in %s",
 768                            fold_convert (long_integer_type_node, a),
 769                            fold_convert (long_integer_type_node, b), name);
 770 }
 771
 772
 773 /* The EXPONENT(s) intrinsic function is translated into
 774        int ret;
 775        frexp (s, &ret);
 776        return ret;
 777  */
 778
 779 static void
 780 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 781 {
 782   tree arg, type, res, tmp, frexp;
 783
 784   frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP,
 785                                        expr->value.function.actual->expr->ts.kind);
 786
 787   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 788
 789   res = gfc_create_var (integer_type_node, NULL);
 790   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
 791                              gfc_build_addr_expr (NULL_TREE, res));
 792   gfc_add_expr_to_block (&se->pre, tmp);
 793
 794   type = gfc_typenode_for_spec (&expr->ts);
 795   se->expr = fold_convert (type, res);
 796 }
 797
 798 /* Evaluate a single upper or lower bound.  */
 799 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 800
 801 static void
 802 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 803 {
 804   gfc_actual_arglist *arg;
 805   gfc_actual_arglist *arg2;
 806   tree desc;
 807   tree type;
 808   tree bound;
 809   tree tmp;
 810   tree cond, cond1, cond3, cond4, size;
 811   tree ubound;
 812   tree lbound;
 813   gfc_se argse;
 814   gfc_ss *ss;
 815   gfc_array_spec * as;
 816
 817   arg = expr->value.function.actual;
 818   arg2 = arg->next;
 819
 820   if (se->ss)
 821     {
 822       /* Create an implicit second parameter from the loop variable.  */
 823       gcc_assert (!arg2->expr);
 824       gcc_assert (se->loop->dimen == 1);
 825       gcc_assert (se->ss->expr == expr);
 826       gfc_advance_se_ss_chain (se);
 827       bound = se->loop->loopvar[0];
 828       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 829                            se->loop->from[0]);
 830     }
 831   else
 832     {
 833       /* use the passed argument.  */
 834       gcc_assert (arg->next->expr);
 835       gfc_init_se (&argse, NULL);
 836       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 837       gfc_add_block_to_block (&se->pre, &argse.pre);
 838       bound = argse.expr;
 839       /* Convert from one based to zero based.  */
 840       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 841                            gfc_index_one_node);
 842     }
 843
 844   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 845   /* Get a descriptor for the first parameter.  */
 846   ss = gfc_walk_expr (arg->expr);
 847   gcc_assert (ss != gfc_ss_terminator);
 848   gfc_init_se (&argse, NULL);
 849   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 850   gfc_add_block_to_block (&se->pre, &argse.pre);
 851   gfc_add_block_to_block (&se->post, &argse.post);
 852
 853   desc = argse.expr;
 854
 855   if (INTEGER_CST_P (bound))
 856     {
 857       int hi, low;
 858
 859       hi = TREE_INT_CST_HIGH (bound);
 860       low = TREE_INT_CST_LOW (bound);
 861       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 862         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 863                    "dimension index", upper ? "UBOUND" : "LBOUND",
 864                    &expr->where);
 865     }
 866   else
 867     {
 868       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 869         {
 870           bound = gfc_evaluate_now (bound, &se->pre);
 871           cond = fold_build2 (LT_EXPR, boolean_type_node,
 872                               bound, build_int_cst (TREE_TYPE (bound), 0));
 873           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 874           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 875           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 876           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
 877                                    gfc_msg_fault);
 878         }
 879     }
 880
 881   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
 882   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
 883
 884   as = gfc_get_full_arrayspec_from_expr (arg->expr);
 885
 886   /* 13.14.53: Result value for LBOUND
 887
 888      Case (i): For an array section or for an array expression other than a
 889                whole array or array structure component, LBOUND(ARRAY, DIM)
 890                has the value 1.  For a whole array or array structure
 891                component, LBOUND(ARRAY, DIM) has the value:
 892                  (a) equal to the lower bound for subscript DIM of ARRAY if
 893                      dimension DIM of ARRAY does not have extent zero
 894                      or if ARRAY is an assumed-size array of rank DIM,
 895               or (b) 1 otherwise.
 896
 897      13.14.113: Result value for UBOUND
 898
 899      Case (i): For an array section or for an array expression other than a
 900                whole array or array structure component, UBOUND(ARRAY, DIM)
 901                has the value equal to the number of elements in the given
 902                dimension; otherwise, it has a value equal to the upper bound
 903                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 904                not have size zero and has value zero if dimension DIM has
 905                size zero.  */
 906
 907   if (as)
 908     {
 909       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
 910
 911       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 912
 913       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 914                            gfc_index_zero_node);
 915       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 916
 917       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 918                            gfc_index_zero_node);
 919
 920       if (upper)
 921         {
 922           tree cond5;
 923           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 924
 925           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
 926           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
 927
 928           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
 929
 930           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 931                                   ubound, gfc_index_zero_node);
 932         }
 933       else
 934         {
 935           if (as->type == AS_ASSUMED_SIZE)
 936             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 937                                 build_int_cst (TREE_TYPE (bound),
 938                                                arg->expr->rank - 1));
 939           else
 940             cond = boolean_false_node;
 941
 942           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 943           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 944
 945           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 946                                   lbound, gfc_index_one_node);
 947         }
 948     }
 949   else
 950     {
 951       if (upper)
 952         {
 953           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
 954           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 955                                   gfc_index_one_node);
 956           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
 957                                   gfc_index_zero_node);
 958         }
 959       else
 960         se->expr = gfc_index_one_node;
 961     }
 962
 963   type = gfc_typenode_for_spec (&expr->ts);
 964   se->expr = convert (type, se->expr);
 965 }
 966
 967
 968 static void
 969 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 970 {
 971   tree arg, cabs;
 972
 973   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 974
 975   switch (expr->value.function.actual->expr->ts.type)
 976     {
 977     case BT_INTEGER:
 978     case BT_REAL:
 979       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
 980       break;
 981
 982     case BT_COMPLEX:
 983       cabs = builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
 984       se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
 985       break;
 986
 987     default:
 988       gcc_unreachable ();
 989     }
 990 }
 991
 992
 993 /* Create a complex value from one or two real components.  */
 994
 995 static void
 996 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 997 {
 998   tree real;
 999   tree imag;
1000   tree type;
1001   tree *args;
1002   unsigned int num_args;
1003
1004   num_args = gfc_intrinsic_argument_list_length (expr);
1005   args = (tree *) alloca (sizeof (tree) * num_args);
1006
1007   type = gfc_typenode_for_spec (&expr->ts);
1008   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1009   real = convert (TREE_TYPE (type), args[0]);
1010   if (both)
1011     imag = convert (TREE_TYPE (type), args[1]);
1012   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1013     {
1014       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1015                           args[0]);
1016       imag = convert (TREE_TYPE (type), imag);
1017     }
1018   else
1019     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1020
1021   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1022 }
1023
1024 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1025                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1026 /* TODO: MOD(x, 0)  */
1027
1028 static void
1029 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1030 {
1031   tree type;
1032   tree itype;
1033   tree tmp;
1034   tree test;
1035   tree test2;
1036   tree fmod;
1037   mpfr_t huge;
1038   int n, ikind;
1039   tree args[2];
1040
1041   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1042
1043   switch (expr->ts.type)
1044     {
1045     case BT_INTEGER:
1046       /* Integer case is easy, we've got a builtin op.  */
1047       type = TREE_TYPE (args[0]);
1048
1049       if (modulo)
1050        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1051       else
1052        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1053       break;
1054
1055     case BT_REAL:
1056       fmod = NULL_TREE;
1057       /* Check if we have a builtin fmod.  */
1058       fmod = builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1059
1060       /* Use it if it exists.  */
1061       if (fmod != NULL_TREE)
1062         {
1063           tmp = build_addr (fmod, current_function_decl);
1064           se->expr = build_call_array_loc (input_location,
1065                                        TREE_TYPE (TREE_TYPE (fmod)),
1066                                        tmp, 2, args);
1067           if (modulo == 0)
1068             return;
1069         }
1070
1071       type = TREE_TYPE (args[0]);
1072
1073       args[0] = gfc_evaluate_now (args[0], &se->pre);
1074       args[1] = gfc_evaluate_now (args[1], &se->pre);
1075
1076       /* Definition:
1077          modulo = arg - floor (arg/arg2) * arg2, so
1078                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1079          where
1080           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1081          thereby avoiding another division and retaining the accuracy
1082          of the builtin function.  */
1083       if (fmod != NULL_TREE && modulo)
1084         {
1085           tree zero = gfc_build_const (type, integer_zero_node);
1086           tmp = gfc_evaluate_now (se->expr, &se->pre);
1087           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1088           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1089           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1090           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1091           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1092           test = gfc_evaluate_now (test, &se->pre);
1093           se->expr = fold_build3 (COND_EXPR, type, test,
1094                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1095                                   tmp);
1096           return;
1097         }
1098
1099       /* If we do not have a built_in fmod, the calculation is going to
1100          have to be done longhand.  */
1101       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1102
1103       /* Test if the value is too large to handle sensibly.  */
1104       gfc_set_model_kind (expr->ts.kind);
1105       mpfr_init (huge);
1106       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1107       ikind = expr->ts.kind;
1108       if (n < 0)
1109         {
1110           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1111           ikind = gfc_max_integer_kind;
1112         }
1113       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1114       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1115       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1116
1117       mpfr_neg (huge, huge, GFC_RND_MODE);
1118       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1119       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1120       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1121
1122       itype = gfc_get_int_type (ikind);
1123       if (modulo)
1124        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1125       else
1126        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1127       tmp = convert (type, tmp);
1128       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1129       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1130       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1131       mpfr_clear (huge);
1132       break;
1133
1134     default:
1135       gcc_unreachable ();
1136     }
1137 }
1138
1139 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1140
1141 static void
1142 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1143 {
1144   tree val;
1145   tree tmp;
1146   tree type;
1147   tree zero;
1148   tree args[2];
1149
1150   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1151   type = TREE_TYPE (args[0]);
1152
1153   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1154   val = gfc_evaluate_now (val, &se->pre);
1155
1156   zero = gfc_build_const (type, integer_zero_node);
1157   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1158   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1159 }
1160
1161
1162 /* SIGN(A, B) is absolute value of A times sign of B.
1163    The real value versions use library functions to ensure the correct
1164    handling of negative zero.  Integer case implemented as:
1165    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1166   */
1167
1168 static void
1169 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1170 {
1171   tree tmp;
1172   tree type;
1173   tree args[2];
1174
1175   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1176   if (expr->ts.type == BT_REAL)
1177     {
1178       tree abs;
1179
1180       tmp = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1181       abs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1182
1183       /* We explicitly have to ignore the minus sign. We do so by using
1184          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
1185       if (!gfc_option.flag_sign_zero
1186           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1187         {
1188           tree cond, zero;
1189           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1190           cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1191           se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1192                                   build_call_expr (abs, 1, args[0]),
1193                                   build_call_expr (tmp, 2, args[0], args[1]));
1194         }
1195       else
1196         se->expr = build_call_expr_loc (input_location, tmp, 2,
1197                                         args[0], args[1]);
1198       return;
1199     }
1200
1201   /* Having excluded floating point types, we know we are now dealing
1202      with signed integer types.  */
1203   type = TREE_TYPE (args[0]);
1204
1205   /* Args[0] is used multiple times below.  */
1206   args[0] = gfc_evaluate_now (args[0], &se->pre);
1207
1208   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1209      the signs of A and B are the same, and of all ones if they differ.  */
1210   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1211   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1212                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1213   tmp = gfc_evaluate_now (tmp, &se->pre);
1214
1215   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1216      is all ones (i.e. -1).  */
1217   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1218                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1219                           tmp);
1220 }
1221
1222
1223 /* Test for the presence of an optional argument.  */
1224
1225 static void
1226 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1227 {
1228   gfc_expr *arg;
1229
1230   arg = expr->value.function.actual->expr;
1231   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1232   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1233   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1234 }
1235
1236
1237 /* Calculate the double precision product of two single precision values.  */
1238
1239 static void
1240 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1241 {
1242   tree type;
1243   tree args[2];
1244
1245   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1246
1247   /* Convert the args to double precision before multiplying.  */
1248   type = gfc_typenode_for_spec (&expr->ts);
1249   args[0] = convert (type, args[0]);
1250   args[1] = convert (type, args[1]);
1251   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1252 }
1253
1254
1255 /* Return a length one character string containing an ascii character.  */
1256
1257 static void
1258 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1259 {
1260   tree arg[2];
1261   tree var;
1262   tree type;
1263   unsigned int num_args;
1264
1265   num_args = gfc_intrinsic_argument_list_length (expr);
1266   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1267
1268   type = gfc_get_char_type (expr->ts.kind);
1269   var = gfc_create_var (type, "char");
1270
1271   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1272   gfc_add_modify (&se->pre, var, arg[0]);
1273   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1274   se->string_length = integer_one_node;
1275 }
1276
1277
1278 static void
1279 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1280 {
1281   tree var;
1282   tree len;
1283   tree tmp;
1284   tree cond;
1285   tree fndecl;
1286   tree *args;
1287   unsigned int num_args;
1288
1289   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1290   args = (tree *) alloca (sizeof (tree) * num_args);
1291
1292   var = gfc_create_var (pchar_type_node, "pstr");
1293   len = gfc_create_var (gfc_get_int_type (8), "len");
1294
1295   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1296   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1297   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1298
1299   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1300   tmp = build_call_array_loc (input_location,
1301                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1302                           fndecl, num_args, args);
1303   gfc_add_expr_to_block (&se->pre, tmp);
1304
1305   /* Free the temporary afterwards, if necessary.  */
1306   cond = fold_build2 (GT_EXPR, boolean_type_node,
1307                       len, build_int_cst (TREE_TYPE (len), 0));
1308   tmp = gfc_call_free (var);
1309   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1310   gfc_add_expr_to_block (&se->post, tmp);
1311
1312   se->expr = var;
1313   se->string_length = len;
1314 }
1315
1316
1317 static void
1318 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1319 {
1320   tree var;
1321   tree len;
1322   tree tmp;
1323   tree cond;
1324   tree fndecl;
1325   tree *args;
1326   unsigned int num_args;
1327
1328   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1329   args = (tree *) alloca (sizeof (tree) * num_args);
1330
1331   var = gfc_create_var (pchar_type_node, "pstr");
1332   len = gfc_create_var (gfc_charlen_type_node, "len");
1333
1334   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1335   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1336   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1337
1338   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1339   tmp = build_call_array_loc (input_location,
1340                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1341                           fndecl, num_args, args);
1342   gfc_add_expr_to_block (&se->pre, tmp);
1343
1344   /* Free the temporary afterwards, if necessary.  */
1345   cond = fold_build2 (GT_EXPR, boolean_type_node,
1346                       len, build_int_cst (TREE_TYPE (len), 0));
1347   tmp = gfc_call_free (var);
1348   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1349   gfc_add_expr_to_block (&se->post, tmp);
1350
1351   se->expr = var;
1352   se->string_length = len;
1353 }
1354
1355
1356 /* Return a character string containing the tty name.  */
1357
1358 static void
1359 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1360 {
1361   tree var;
1362   tree len;
1363   tree tmp;
1364   tree cond;
1365   tree fndecl;
1366   tree *args;
1367   unsigned int num_args;
1368
1369   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1370   args = (tree *) alloca (sizeof (tree) * num_args);
1371
1372   var = gfc_create_var (pchar_type_node, "pstr");
1373   len = gfc_create_var (gfc_charlen_type_node, "len");
1374
1375   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1376   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1377   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1378
1379   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1380   tmp = build_call_array_loc (input_location,
1381                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1382                           fndecl, num_args, args);
1383   gfc_add_expr_to_block (&se->pre, tmp);
1384
1385   /* Free the temporary afterwards, if necessary.  */
1386   cond = fold_build2 (GT_EXPR, boolean_type_node,
1387                       len, build_int_cst (TREE_TYPE (len), 0));
1388   tmp = gfc_call_free (var);
1389   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1390   gfc_add_expr_to_block (&se->post, tmp);
1391
1392   se->expr = var;
1393   se->string_length = len;
1394 }
1395
1396
1397 /* Get the minimum/maximum value of all the parameters.
1398     minmax (a1, a2, a3, ...)
1399     {
1400       mvar = a1;
1401       if (a2 .op. mvar || isnan(mvar))
1402         mvar = a2;
1403       if (a3 .op. mvar || isnan(mvar))
1404         mvar = a3;
1405       ...
1406       return mvar
1407     }
1408  */
1409
1410 /* TODO: Mismatching types can occur when specific names are used.
1411    These should be handled during resolution.  */
1412 static void
1413 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1414 {
1415   tree tmp;
1416   tree mvar;
1417   tree val;
1418   tree thencase;
1419   tree *args;
1420   tree type;
1421   gfc_actual_arglist *argexpr;
1422   unsigned int i, nargs;
1423
1424   nargs = gfc_intrinsic_argument_list_length (expr);
1425   args = (tree *) alloca (sizeof (tree) * nargs);
1426
1427   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1428   type = gfc_typenode_for_spec (&expr->ts);
1429
1430   argexpr = expr->value.function.actual;
1431   if (TREE_TYPE (args[0]) != type)
1432     args[0] = convert (type, args[0]);
1433   /* Only evaluate the argument once.  */
1434   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1435     args[0] = gfc_evaluate_now (args[0], &se->pre);
1436
1437   mvar = gfc_create_var (type, "M");
1438   gfc_add_modify (&se->pre, mvar, args[0]);
1439   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1440     {
1441       tree cond, isnan;
1442
1443       val = args[i];
1444
1445       /* Handle absent optional arguments by ignoring the comparison.  */
1446       if (argexpr->expr->expr_type == EXPR_VARIABLE
1447           && argexpr->expr->symtree->n.sym->attr.optional
1448           && TREE_CODE (val) == INDIRECT_REF)
1449         cond = fold_build2_loc (input_location,
1450                                 NE_EXPR, boolean_type_node,
1451                                 TREE_OPERAND (val, 0),
1452                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1453       else
1454       {
1455         cond = NULL_TREE;
1456
1457         /* Only evaluate the argument once.  */
1458         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1459           val = gfc_evaluate_now (val, &se->pre);
1460       }
1461
1462       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1463
1464       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1465
1466       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1467          __builtin_isnan might be made dependent on that module being loaded,
1468          to help performance of programs that don't rely on IEEE semantics.  */
1469       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1470         {
1471           isnan = build_call_expr_loc (input_location,
1472                                    built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1473           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1474                              fold_convert (boolean_type_node, isnan));
1475         }
1476       tmp = build3_v (COND_EXPR, tmp, thencase,
1477                       build_empty_stmt (input_location));
1478
1479       if (cond != NULL_TREE)
1480         tmp = build3_v (COND_EXPR, cond, tmp,
1481                         build_empty_stmt (input_location));
1482
1483       gfc_add_expr_to_block (&se->pre, tmp);
1484       argexpr = argexpr->next;
1485     }
1486   se->expr = mvar;
1487 }
1488
1489
1490 /* Generate library calls for MIN and MAX intrinsics for character
1491    variables.  */
1492 static void
1493 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1494 {
1495   tree *args;
1496   tree var, len, fndecl, tmp, cond, function;
1497   unsigned int nargs;
1498
1499   nargs = gfc_intrinsic_argument_list_length (expr);
1500   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1501   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1502
1503   /* Create the result variables.  */
1504   len = gfc_create_var (gfc_charlen_type_node, "len");
1505   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1506   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1507   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1508   args[2] = build_int_cst (NULL_TREE, op);
1509   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1510
1511   if (expr->ts.kind == 1)
1512     function = gfor_fndecl_string_minmax;
1513   else if (expr->ts.kind == 4)
1514     function = gfor_fndecl_string_minmax_char4;
1515   else
1516     gcc_unreachable ();
1517
1518   /* Make the function call.  */
1519   fndecl = build_addr (function, current_function_decl);
1520   tmp = build_call_array_loc (input_location,
1521                           TREE_TYPE (TREE_TYPE (function)), fndecl,
1522                           nargs + 4, args);
1523   gfc_add_expr_to_block (&se->pre, tmp);
1524
1525   /* Free the temporary afterwards, if necessary.  */
1526   cond = fold_build2 (GT_EXPR, boolean_type_node,
1527                       len, build_int_cst (TREE_TYPE (len), 0));
1528   tmp = gfc_call_free (var);
1529   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1530   gfc_add_expr_to_block (&se->post, tmp);
1531
1532   se->expr = var;
1533   se->string_length = len;
1534 }
1535
1536
1537 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1538    has the generic name.  */
1539
1540 static gfc_symbol *
1541 gfc_get_symbol_for_expr (gfc_expr * expr)
1542 {
1543   gfc_symbol *sym;
1544
1545   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1546   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1547   sym = gfc_new_symbol (expr->value.function.name, NULL);
1548
1549   sym->ts = expr->ts;
1550   sym->attr.external = 1;
1551   sym->attr.function = 1;
1552   sym->attr.always_explicit = 1;
1553   sym->attr.proc = PROC_INTRINSIC;
1554   sym->attr.flavor = FL_PROCEDURE;
1555   sym->result = sym;
1556   if (expr->rank > 0)
1557     {
1558       sym->attr.dimension = 1;
1559       sym->as = gfc_get_array_spec ();
1560       sym->as->type = AS_ASSUMED_SHAPE;
1561       sym->as->rank = expr->rank;
1562     }
1563
1564   /* TODO: proper argument lists for external intrinsics.  */
1565   return sym;
1566 }
1567
1568 /* Generate a call to an external intrinsic function.  */
1569 static void
1570 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1571 {
1572   gfc_symbol *sym;
1573   tree append_args;
1574
1575   gcc_assert (!se->ss || se->ss->expr == expr);
1576
1577   if (se->ss)
1578     gcc_assert (expr->rank > 0);
1579   else
1580     gcc_assert (expr->rank == 0);
1581
1582   sym = gfc_get_symbol_for_expr (expr);
1583
1584   /* Calls to libgfortran_matmul need to be appended special arguments,
1585      to be able to call the BLAS ?gemm functions if required and possible.  */
1586   append_args = NULL_TREE;
1587   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1588       && sym->ts.type != BT_LOGICAL)
1589     {
1590       tree cint = gfc_get_int_type (gfc_c_int_kind);
1591
1592       if (gfc_option.flag_external_blas
1593           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1594           && (sym->ts.kind == gfc_default_real_kind
1595               || sym->ts.kind == gfc_default_double_kind))
1596         {
1597           tree gemm_fndecl;
1598
1599           if (sym->ts.type == BT_REAL)
1600             {
1601               if (sym->ts.kind == gfc_default_real_kind)
1602                 gemm_fndecl = gfor_fndecl_sgemm;
1603               else
1604                 gemm_fndecl = gfor_fndecl_dgemm;
1605             }
1606           else
1607             {
1608               if (sym->ts.kind == gfc_default_real_kind)
1609                 gemm_fndecl = gfor_fndecl_cgemm;
1610               else
1611                 gemm_fndecl = gfor_fndecl_zgemm;
1612             }
1613
1614           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1615           append_args = gfc_chainon_list
1616                           (append_args, build_int_cst
1617                                           (cint, gfc_option.blas_matmul_limit));
1618           append_args = gfc_chainon_list (append_args,
1619                                           gfc_build_addr_expr (NULL_TREE,
1620                                                                gemm_fndecl));
1621         }
1622       else
1623         {
1624           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1625           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1626           append_args = gfc_chainon_list (append_args, null_pointer_node);
1627         }
1628     }
1629
1630   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1631                           append_args);
1632   gfc_free (sym);
1633 }
1634
1635 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1636    Implemented as
1637     any(a)
1638     {
1639       forall (i=...)
1640         if (a[i] != 0)
1641           return 1
1642       end forall
1643       return 0
1644     }
1645     all(a)
1646     {
1647       forall (i=...)
1648         if (a[i] == 0)
1649           return 0
1650       end forall
1651       return 1
1652     }
1653  */
1654 static void
1655 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1656 {
1657   tree resvar;
1658   stmtblock_t block;
1659   stmtblock_t body;
1660   tree type;
1661   tree tmp;
1662   tree found;
1663   gfc_loopinfo loop;
1664   gfc_actual_arglist *actual;
1665   gfc_ss *arrayss;
1666   gfc_se arrayse;
1667   tree exit_label;
1668
1669   if (se->ss)
1670     {
1671       gfc_conv_intrinsic_funcall (se, expr);
1672       return;
1673     }
1674
1675   actual = expr->value.function.actual;
1676   type = gfc_typenode_for_spec (&expr->ts);
1677   /* Initialize the result.  */
1678   resvar = gfc_create_var (type, "test");
1679   if (op == EQ_EXPR)
1680     tmp = convert (type, boolean_true_node);
1681   else
1682     tmp = convert (type, boolean_false_node);
1683   gfc_add_modify (&se->pre, resvar, tmp);
1684
1685   /* Walk the arguments.  */
1686   arrayss = gfc_walk_expr (actual->expr);
1687   gcc_assert (arrayss != gfc_ss_terminator);
1688
1689   /* Initialize the scalarizer.  */
1690   gfc_init_loopinfo (&loop);
1691   exit_label = gfc_build_label_decl (NULL_TREE);
1692   TREE_USED (exit_label) = 1;
1693   gfc_add_ss_to_loop (&loop, arrayss);
1694
1695   /* Initialize the loop.  */
1696   gfc_conv_ss_startstride (&loop);
1697   gfc_conv_loop_setup (&loop, &expr->where);
1698
1699   gfc_mark_ss_chain_used (arrayss, 1);
1700   /* Generate the loop body.  */
1701   gfc_start_scalarized_body (&loop, &body);
1702
1703   /* If the condition matches then set the return value.  */
1704   gfc_start_block (&block);
1705   if (op == EQ_EXPR)
1706     tmp = convert (type, boolean_false_node);
1707   else
1708     tmp = convert (type, boolean_true_node);
1709   gfc_add_modify (&block, resvar, tmp);
1710
1711   /* And break out of the loop.  */
1712   tmp = build1_v (GOTO_EXPR, exit_label);
1713   gfc_add_expr_to_block (&block, tmp);
1714
1715   found = gfc_finish_block (&block);
1716
1717   /* Check this element.  */
1718   gfc_init_se (&arrayse, NULL);
1719   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1720   arrayse.ss = arrayss;
1721   gfc_conv_expr_val (&arrayse, actual->expr);
1722
1723   gfc_add_block_to_block (&body, &arrayse.pre);
1724   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1725                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1726   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1727   gfc_add_expr_to_block (&body, tmp);
1728   gfc_add_block_to_block (&body, &arrayse.post);
1729
1730   gfc_trans_scalarizing_loops (&loop, &body);
1731
1732   /* Add the exit label.  */
1733   tmp = build1_v (LABEL_EXPR, exit_label);
1734   gfc_add_expr_to_block (&loop.pre, tmp);
1735
1736   gfc_add_block_to_block (&se->pre, &loop.pre);
1737   gfc_add_block_to_block (&se->pre, &loop.post);
1738   gfc_cleanup_loop (&loop);
1739
1740   se->expr = resvar;
1741 }
1742
1743 /* COUNT(A) = Number of true elements in A.  */
1744 static void
1745 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1746 {
1747   tree resvar;
1748   tree type;
1749   stmtblock_t body;
1750   tree tmp;
1751   gfc_loopinfo loop;
1752   gfc_actual_arglist *actual;
1753   gfc_ss *arrayss;
1754   gfc_se arrayse;
1755
1756   if (se->ss)
1757     {
1758       gfc_conv_intrinsic_funcall (se, expr);
1759       return;
1760     }
1761
1762   actual = expr->value.function.actual;
1763
1764   type = gfc_typenode_for_spec (&expr->ts);
1765   /* Initialize the result.  */
1766   resvar = gfc_create_var (type, "count");
1767   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1768
1769   /* Walk the arguments.  */
1770   arrayss = gfc_walk_expr (actual->expr);
1771   gcc_assert (arrayss != gfc_ss_terminator);
1772
1773   /* Initialize the scalarizer.  */
1774   gfc_init_loopinfo (&loop);
1775   gfc_add_ss_to_loop (&loop, arrayss);
1776
1777   /* Initialize the loop.  */
1778   gfc_conv_ss_startstride (&loop);
1779   gfc_conv_loop_setup (&loop, &expr->where);
1780
1781   gfc_mark_ss_chain_used (arrayss, 1);
1782   /* Generate the loop body.  */
1783   gfc_start_scalarized_body (&loop, &body);
1784
1785   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1786                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1787   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1788
1789   gfc_init_se (&arrayse, NULL);
1790   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1791   arrayse.ss = arrayss;
1792   gfc_conv_expr_val (&arrayse, actual->expr);
1793   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1794                   build_empty_stmt (input_location));
1795
1796   gfc_add_block_to_block (&body, &arrayse.pre);
1797   gfc_add_expr_to_block (&body, tmp);
1798   gfc_add_block_to_block (&body, &arrayse.post);
1799
1800   gfc_trans_scalarizing_loops (&loop, &body);
1801
1802   gfc_add_block_to_block (&se->pre, &loop.pre);
1803   gfc_add_block_to_block (&se->pre, &loop.post);
1804   gfc_cleanup_loop (&loop);
1805
1806   se->expr = resvar;
1807 }
1808
1809 /* Inline implementation of the sum and product intrinsics.  */
1810 static void
1811 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1812 {
1813   tree resvar;
1814   tree type;
1815   stmtblock_t body;
1816   stmtblock_t block;
1817   tree tmp;
1818   gfc_loopinfo loop;
1819   gfc_actual_arglist *actual;
1820   gfc_ss *arrayss;
1821   gfc_ss *maskss;
1822   gfc_se arrayse;
1823   gfc_se maskse;
1824   gfc_expr *arrayexpr;
1825   gfc_expr *maskexpr;
1826
1827   if (se->ss)
1828     {
1829       gfc_conv_intrinsic_funcall (se, expr);
1830       return;
1831     }
1832
1833   type = gfc_typenode_for_spec (&expr->ts);
1834   /* Initialize the result.  */
1835   resvar = gfc_create_var (type, "val");
1836   if (op == PLUS_EXPR)
1837     tmp = gfc_build_const (type, integer_zero_node);
1838   else
1839     tmp = gfc_build_const (type, integer_one_node);
1840
1841   gfc_add_modify (&se->pre, resvar, tmp);
1842
1843   /* Walk the arguments.  */
1844   actual = expr->value.function.actual;
1845   arrayexpr = actual->expr;
1846   arrayss = gfc_walk_expr (arrayexpr);
1847   gcc_assert (arrayss != gfc_ss_terminator);
1848
1849   actual = actual->next->next;
1850   gcc_assert (actual);
1851   maskexpr = actual->expr;
1852   if (maskexpr && maskexpr->rank != 0)
1853     {
1854       maskss = gfc_walk_expr (maskexpr);
1855       gcc_assert (maskss != gfc_ss_terminator);
1856     }
1857   else
1858     maskss = NULL;
1859
1860   /* Initialize the scalarizer.  */
1861   gfc_init_loopinfo (&loop);
1862   gfc_add_ss_to_loop (&loop, arrayss);
1863   if (maskss)
1864     gfc_add_ss_to_loop (&loop, maskss);
1865
1866   /* Initialize the loop.  */
1867   gfc_conv_ss_startstride (&loop);
1868   gfc_conv_loop_setup (&loop, &expr->where);
1869
1870   gfc_mark_ss_chain_used (arrayss, 1);
1871   if (maskss)
1872     gfc_mark_ss_chain_used (maskss, 1);
1873   /* Generate the loop body.  */
1874   gfc_start_scalarized_body (&loop, &body);
1875
1876   /* If we have a mask, only add this element if the mask is set.  */
1877   if (maskss)
1878     {
1879       gfc_init_se (&maskse, NULL);
1880       gfc_copy_loopinfo_to_se (&maskse, &loop);
1881       maskse.ss = maskss;
1882       gfc_conv_expr_val (&maskse, maskexpr);
1883       gfc_add_block_to_block (&body, &maskse.pre);
1884
1885       gfc_start_block (&block);
1886     }
1887   else
1888     gfc_init_block (&block);
1889
1890   /* Do the actual summation/product.  */
1891   gfc_init_se (&arrayse, NULL);
1892   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1893   arrayse.ss = arrayss;
1894   gfc_conv_expr_val (&arrayse, arrayexpr);
1895   gfc_add_block_to_block (&block, &arrayse.pre);
1896
1897   tmp = fold_build2 (op, type, resvar, arrayse.expr);
1898   gfc_add_modify (&block, resvar, tmp);
1899   gfc_add_block_to_block (&block, &arrayse.post);
1900
1901   if (maskss)
1902     {
1903       /* We enclose the above in if (mask) {...} .  */
1904       tmp = gfc_finish_block (&block);
1905
1906       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1907                       build_empty_stmt (input_location));
1908     }
1909   else
1910     tmp = gfc_finish_block (&block);
1911   gfc_add_expr_to_block (&body, tmp);
1912
1913   gfc_trans_scalarizing_loops (&loop, &body);
1914
1915   /* For a scalar mask, enclose the loop in an if statement.  */
1916   if (maskexpr && maskss == NULL)
1917     {
1918       gfc_init_se (&maskse, NULL);
1919       gfc_conv_expr_val (&maskse, maskexpr);
1920       gfc_init_block (&block);
1921       gfc_add_block_to_block (&block, &loop.pre);
1922       gfc_add_block_to_block (&block, &loop.post);
1923       tmp = gfc_finish_block (&block);
1924
1925       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1926                       build_empty_stmt (input_location));
1927       gfc_add_expr_to_block (&block, tmp);
1928       gfc_add_block_to_block (&se->pre, &block);
1929     }
1930   else
1931     {
1932       gfc_add_block_to_block (&se->pre, &loop.pre);
1933       gfc_add_block_to_block (&se->pre, &loop.post);
1934     }
1935
1936   gfc_cleanup_loop (&loop);
1937
1938   se->expr = resvar;
1939 }
1940
1941
1942 /* Inline implementation of the dot_product intrinsic. This function
1943    is based on gfc_conv_intrinsic_arith (the previous function).  */
1944 static void
1945 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1946 {
1947   tree resvar;
1948   tree type;
1949   stmtblock_t body;
1950   stmtblock_t block;
1951   tree tmp;
1952   gfc_loopinfo loop;
1953   gfc_actual_arglist *actual;
1954   gfc_ss *arrayss1, *arrayss2;
1955   gfc_se arrayse1, arrayse2;
1956   gfc_expr *arrayexpr1, *arrayexpr2;
1957
1958   type = gfc_typenode_for_spec (&expr->ts);
1959
1960   /* Initialize the result.  */
1961   resvar = gfc_create_var (type, "val");
1962   if (expr->ts.type == BT_LOGICAL)
1963     tmp = build_int_cst (type, 0);
1964   else
1965     tmp = gfc_build_const (type, integer_zero_node);
1966
1967   gfc_add_modify (&se->pre, resvar, tmp);
1968
1969   /* Walk argument #1.  */
1970   actual = expr->value.function.actual;
1971   arrayexpr1 = actual->expr;
1972   arrayss1 = gfc_walk_expr (arrayexpr1);
1973   gcc_assert (arrayss1 != gfc_ss_terminator);
1974
1975   /* Walk argument #2.  */
1976   actual = actual->next;
1977   arrayexpr2 = actual->expr;
1978   arrayss2 = gfc_walk_expr (arrayexpr2);
1979   gcc_assert (arrayss2 != gfc_ss_terminator);
1980
1981   /* Initialize the scalarizer.  */
1982   gfc_init_loopinfo (&loop);
1983   gfc_add_ss_to_loop (&loop, arrayss1);
1984   gfc_add_ss_to_loop (&loop, arrayss2);
1985
1986   /* Initialize the loop.  */
1987   gfc_conv_ss_startstride (&loop);
1988   gfc_conv_loop_setup (&loop, &expr->where);
1989
1990   gfc_mark_ss_chain_used (arrayss1, 1);
1991   gfc_mark_ss_chain_used (arrayss2, 1);
1992
1993   /* Generate the loop body.  */
1994   gfc_start_scalarized_body (&loop, &body);
1995   gfc_init_block (&block);
1996
1997   /* Make the tree expression for [conjg(]array1[)].  */
1998   gfc_init_se (&arrayse1, NULL);
1999   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2000   arrayse1.ss = arrayss1;
2001   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2002   if (expr->ts.type == BT_COMPLEX)
2003     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2004   gfc_add_block_to_block (&block, &arrayse1.pre);
2005
2006   /* Make the tree expression for array2.  */
2007   gfc_init_se (&arrayse2, NULL);
2008   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2009   arrayse2.ss = arrayss2;
2010   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2011   gfc_add_block_to_block (&block, &arrayse2.pre);
2012
2013   /* Do the actual product and sum.  */
2014   if (expr->ts.type == BT_LOGICAL)
2015     {
2016       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2017       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2018     }
2019   else
2020     {
2021       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2022       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2023     }
2024   gfc_add_modify (&block, resvar, tmp);
2025
2026   /* Finish up the loop block and the loop.  */
2027   tmp = gfc_finish_block (&block);
2028   gfc_add_expr_to_block (&body, tmp);
2029
2030   gfc_trans_scalarizing_loops (&loop, &body);
2031   gfc_add_block_to_block (&se->pre, &loop.pre);
2032   gfc_add_block_to_block (&se->pre, &loop.post);
2033   gfc_cleanup_loop (&loop);
2034
2035   se->expr = resvar;
2036 }
2037
2038
2039 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
2040    we need to handle.  For performance reasons we sometimes create two
2041    loops instead of one, where the second one is much simpler.
2042    Examples for minloc intrinsic:
2043    1) Result is an array, a call is generated
2044    2) Array mask is used and NaNs need to be supported:
2045       limit = Infinity;
2046       pos = 0;
2047       S = from;
2048       while (S <= to) {
2049         if (mask[S]) {
2050           if (pos == 0) pos = S + (1 - from);
2051           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2052         }
2053         S++;
2054       }
2055       goto lab2;
2056       lab1:;
2057       while (S <= to) {
2058         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2059         S++;
2060       }
2061       lab2:;
2062    3) NaNs need to be supported, but it is known at compile time or cheaply
2063       at runtime whether array is nonempty or not:
2064       limit = Infinity;
2065       pos = 0;
2066       S = from;
2067       while (S <= to) {
2068         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2069         S++;
2070       }
2071       if (from <= to) pos = 1;
2072       goto lab2;
2073       lab1:;
2074       while (S <= to) {
2075         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2076         S++;
2077       }
2078       lab2:;
2079    4) NaNs aren't supported, array mask is used:
2080       limit = infinities_supported ? Infinity : huge (limit);
2081       pos = 0;
2082       S = from;
2083       while (S <= to) {
2084         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2085         S++;
2086       }
2087       goto lab2;
2088       lab1:;
2089       while (S <= to) {
2090         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2091         S++;
2092       }
2093       lab2:;
2094    5) Same without array mask:
2095       limit = infinities_supported ? Infinity : huge (limit);
2096       pos = (from <= to) ? 1 : 0;
2097       S = from;
2098       while (S <= to) {
2099         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2100         S++;
2101       }
2102    For 3) and 5), if mask is scalar, this all goes into a conditional,
2103    setting pos = 0; in the else branch.  */
2104
2105 static void
2106 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2107 {
2108   stmtblock_t body;
2109   stmtblock_t block;
2110   stmtblock_t ifblock;
2111   stmtblock_t elseblock;
2112   tree limit;
2113   tree type;
2114   tree tmp;
2115   tree cond;
2116   tree elsetmp;
2117   tree ifbody;
2118   tree offset;
2119   tree nonempty;
2120   tree lab1, lab2;
2121   gfc_loopinfo loop;
2122   gfc_actual_arglist *actual;
2123   gfc_ss *arrayss;
2124   gfc_ss *maskss;
2125   gfc_se arrayse;
2126   gfc_se maskse;
2127   gfc_expr *arrayexpr;
2128   gfc_expr *maskexpr;
2129   tree pos;
2130   int n;
2131
2132   if (se->ss)
2133     {
2134       gfc_conv_intrinsic_funcall (se, expr);
2135       return;
2136     }
2137
2138   /* Initialize the result.  */
2139   pos = gfc_create_var (gfc_array_index_type, "pos");
2140   offset = gfc_create_var (gfc_array_index_type, "offset");
2141   type = gfc_typenode_for_spec (&expr->ts);
2142
2143   /* Walk the arguments.  */
2144   actual = expr->value.function.actual;
2145   arrayexpr = actual->expr;
2146   arrayss = gfc_walk_expr (arrayexpr);
2147   gcc_assert (arrayss != gfc_ss_terminator);
2148
2149   actual = actual->next->next;
2150   gcc_assert (actual);
2151   maskexpr = actual->expr;
2152   nonempty = NULL;
2153   if (maskexpr && maskexpr->rank != 0)
2154     {
2155       maskss = gfc_walk_expr (maskexpr);
2156       gcc_assert (maskss != gfc_ss_terminator);
2157     }
2158   else
2159     {
2160       mpz_t asize;
2161       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2162         {
2163           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2164           mpz_clear (asize);
2165           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2166                                   gfc_index_zero_node);
2167         }
2168       maskss = NULL;
2169     }
2170
2171   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2172   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2173   switch (arrayexpr->ts.type)
2174     {
2175     case BT_REAL:
2176       if (HONOR_INFINITIES (DECL_MODE (limit)))
2177         {
2178           REAL_VALUE_TYPE real;
2179           real_inf (&real);
2180           tmp = build_real (TREE_TYPE (limit), real);
2181         }
2182       else
2183         tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2184                                      arrayexpr->ts.kind, 0);
2185       break;
2186
2187     case BT_INTEGER:
2188       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2189                                   arrayexpr->ts.kind);
2190       break;
2191
2192     default:
2193       gcc_unreachable ();
2194     }
2195
2196   /* We start with the most negative possible value for MAXLOC, and the most
2197      positive possible value for MINLOC. The most negative possible value is
2198      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2199      possible value is HUGE in both cases.  */
2200   if (op == GT_EXPR)
2201     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2202   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2203     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2204                        build_int_cst (type, 1));
2205
2206   gfc_add_modify (&se->pre, limit, tmp);
2207
2208   /* Initialize the scalarizer.  */
2209   gfc_init_loopinfo (&loop);
2210   gfc_add_ss_to_loop (&loop, arrayss);
2211   if (maskss)
2212     gfc_add_ss_to_loop (&loop, maskss);
2213
2214   /* Initialize the loop.  */
2215   gfc_conv_ss_startstride (&loop);
2216   gfc_conv_loop_setup (&loop, &expr->where);
2217
2218   gcc_assert (loop.dimen == 1);
2219   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2220     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2221                             loop.to[0]);
2222
2223   lab1 = NULL;
2224   lab2 = NULL;
2225   /* Initialize the position to zero, following Fortran 2003.  We are free
2226      to do this because Fortran 95 allows the result of an entirely false
2227      mask to be processor dependent.  If we know at compile time the array
2228      is non-empty and no MASK is used, we can initialize to 1 to simplify
2229      the inner loop.  */
2230   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2231     gfc_add_modify (&loop.pre, pos,
2232                     fold_build3 (COND_EXPR, gfc_array_index_type,
2233                                  nonempty, gfc_index_one_node,
2234                                  gfc_index_zero_node));
2235   else
2236     {
2237       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2238       lab1 = gfc_build_label_decl (NULL_TREE);
2239       TREE_USED (lab1) = 1;
2240       lab2 = gfc_build_label_decl (NULL_TREE);
2241       TREE_USED (lab2) = 1;
2242     }
2243
2244   gfc_mark_ss_chain_used (arrayss, 1);
2245   if (maskss)
2246     gfc_mark_ss_chain_used (maskss, 1);
2247   /* Generate the loop body.  */
2248   gfc_start_scalarized_body (&loop, &body);
2249
2250   /* If we have a mask, only check this element if the mask is set.  */
2251   if (maskss)
2252     {
2253       gfc_init_se (&maskse, NULL);
2254       gfc_copy_loopinfo_to_se (&maskse, &loop);
2255       maskse.ss = maskss;
2256       gfc_conv_expr_val (&maskse, maskexpr);
2257       gfc_add_block_to_block (&body, &maskse.pre);
2258
2259       gfc_start_block (&block);
2260     }
2261   else
2262     gfc_init_block (&block);
2263
2264   /* Compare with the current limit.  */
2265   gfc_init_se (&arrayse, NULL);
2266   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2267   arrayse.ss = arrayss;
2268   gfc_conv_expr_val (&arrayse, arrayexpr);
2269   gfc_add_block_to_block (&block, &arrayse.pre);
2270
2271   /* We do the following if this is a more extreme value.  */
2272   gfc_start_block (&ifblock);
2273
2274   /* Assign the value to the limit...  */
2275   gfc_add_modify (&ifblock, limit, arrayse.expr);
2276
2277   /* Remember where we are.  An offset must be added to the loop
2278      counter to obtain the required position.  */
2279   if (loop.from[0])
2280     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2281                        gfc_index_one_node, loop.from[0]);
2282   else
2283     tmp = gfc_index_one_node;
2284
2285   gfc_add_modify (&block, offset, tmp);
2286
2287   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2288     {
2289       stmtblock_t ifblock2;
2290       tree ifbody2;
2291
2292       gfc_start_block (&ifblock2);
2293       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2294                          loop.loopvar[0], offset);
2295       gfc_add_modify (&ifblock2, pos, tmp);
2296       ifbody2 = gfc_finish_block (&ifblock2);
2297       cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2298                           gfc_index_zero_node);
2299       tmp = build3_v (COND_EXPR, cond, ifbody2,
2300                       build_empty_stmt (input_location));
2301       gfc_add_expr_to_block (&block, tmp);
2302     }
2303
2304   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2305                      loop.loopvar[0], offset);
2306   gfc_add_modify (&ifblock, pos, tmp);
2307
2308   if (lab1)
2309     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2310
2311   ifbody = gfc_finish_block (&ifblock);
2312
2313   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2314     {
2315       if (lab1)
2316         cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2317                             boolean_type_node, arrayse.expr, limit);
2318       else
2319         cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2320
2321       ifbody = build3_v (COND_EXPR, cond, ifbody,
2322                          build_empty_stmt (input_location));
2323     }
2324   gfc_add_expr_to_block (&block, ifbody);
2325
2326   if (maskss)
2327     {
2328       /* We enclose the above in if (mask) {...}.  */
2329       tmp = gfc_finish_block (&block);
2330
2331       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2332                       build_empty_stmt (input_location));
2333     }
2334   else
2335     tmp = gfc_finish_block (&block);
2336   gfc_add_expr_to_block (&body, tmp);
2337
2338   if (lab1)
2339     {
2340       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2341
2342       if (HONOR_NANS (DECL_MODE (limit)))
2343         {
2344           if (nonempty != NULL)
2345             {
2346               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2347               tmp = build3_v (COND_EXPR, nonempty, ifbody,
2348                               build_empty_stmt (input_location));
2349               gfc_add_expr_to_block (&loop.code[0], tmp);
2350             }
2351         }
2352
2353       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2354       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2355       gfc_start_block (&body);
2356
2357       /* If we have a mask, only check this element if the mask is set.  */
2358       if (maskss)
2359         {
2360           gfc_init_se (&maskse, NULL);
2361           gfc_copy_loopinfo_to_se (&maskse, &loop);
2362           maskse.ss = maskss;
2363           gfc_conv_expr_val (&maskse, maskexpr);
2364           gfc_add_block_to_block (&body, &maskse.pre);
2365
2366           gfc_start_block (&block);
2367         }
2368       else
2369         gfc_init_block (&block);
2370
2371       /* Compare with the current limit.  */
2372       gfc_init_se (&arrayse, NULL);
2373       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2374       arrayse.ss = arrayss;
2375       gfc_conv_expr_val (&arrayse, arrayexpr);
2376       gfc_add_block_to_block (&block, &arrayse.pre);
2377
2378       /* We do the following if this is a more extreme value.  */
2379       gfc_start_block (&ifblock);
2380
2381       /* Assign the value to the limit...  */
2382       gfc_add_modify (&ifblock, limit, arrayse.expr);
2383
2384       /* Remember where we are.  An offset must be added to the loop
2385          counter to obtain the required position.  */
2386       if (loop.from[0])
2387         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2388                            gfc_index_one_node, loop.from[0]);
2389       else
2390         tmp = gfc_index_one_node;
2391
2392       gfc_add_modify (&block, offset, tmp);
2393
2394       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2395                          loop.loopvar[0], offset);
2396       gfc_add_modify (&ifblock, pos, tmp);
2397
2398       ifbody = gfc_finish_block (&ifblock);
2399
2400       cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2401
2402       tmp = build3_v (COND_EXPR, cond, ifbody,
2403                       build_empty_stmt (input_location));
2404       gfc_add_expr_to_block (&block, tmp);
2405
2406       if (maskss)
2407         {
2408           /* We enclose the above in if (mask) {...}.  */
2409           tmp = gfc_finish_block (&block);
2410
2411           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2412                           build_empty_stmt (input_location));
2413         }
2414       else
2415         tmp = gfc_finish_block (&block);
2416       gfc_add_expr_to_block (&body, tmp);
2417       /* Avoid initializing loopvar[0] again, it should be left where
2418          it finished by the first loop.  */
2419       loop.from[0] = loop.loopvar[0];
2420     }
2421
2422   gfc_trans_scalarizing_loops (&loop, &body);
2423
2424   if (lab2)
2425     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2426
2427   /* For a scalar mask, enclose the loop in an if statement.  */
2428   if (maskexpr && maskss == NULL)
2429     {
2430       gfc_init_se (&maskse, NULL);
2431       gfc_conv_expr_val (&maskse, maskexpr);
2432       gfc_init_block (&block);
2433       gfc_add_block_to_block (&block, &loop.pre);
2434       gfc_add_block_to_block (&block, &loop.post);
2435       tmp = gfc_finish_block (&block);
2436
2437       /* For the else part of the scalar mask, just initialize
2438          the pos variable the same way as above.  */
2439
2440       gfc_init_block (&elseblock);
2441       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2442       elsetmp = gfc_finish_block (&elseblock);
2443
2444       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2445       gfc_add_expr_to_block (&block, tmp);
2446       gfc_add_block_to_block (&se->pre, &block);
2447     }
2448   else
2449     {
2450       gfc_add_block_to_block (&se->pre, &loop.pre);
2451       gfc_add_block_to_block (&se->pre, &loop.post);
2452     }
2453   gfc_cleanup_loop (&loop);
2454
2455   se->expr = convert (type, pos);
2456 }
2457
2458 /* Emit code for minval or maxval intrinsic.  There are many different cases
2459    we need to handle.  For performance reasons we sometimes create two
2460    loops instead of one, where the second one is much simpler.
2461    Examples for minval intrinsic:
2462    1) Result is an array, a call is generated
2463    2) Array mask is used and NaNs need to be supported, rank 1:
2464       limit = Infinity;
2465       nonempty = false;
2466       S = from;
2467       while (S <= to) {
2468         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2469         S++;
2470       }
2471       limit = nonempty ? NaN : huge (limit);
2472       lab:
2473       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2474    3) NaNs need to be supported, but it is known at compile time or cheaply
2475       at runtime whether array is nonempty or not, rank 1:
2476       limit = Infinity;
2477       S = from;
2478       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2479       limit = (from <= to) ? NaN : huge (limit);
2480       lab:
2481       while (S <= to) { limit = min (a[S], limit); S++; }
2482    4) Array mask is used and NaNs need to be supported, rank > 1:
2483       limit = Infinity;
2484       nonempty = false;
2485       fast = false;
2486       S1 = from1;
2487       while (S1 <= to1) {
2488         S2 = from2;
2489         while (S2 <= to2) {
2490           if (mask[S1][S2]) {
2491             if (fast) limit = min (a[S1][S2], limit);
2492             else {
2493               nonempty = true;
2494               if (a[S1][S2] <= limit) {
2495                 limit = a[S1][S2];
2496                 fast = true;
2497               }
2498             }
2499           }
2500           S2++;
2501         }
2502         S1++;
2503       }
2504       if (!fast)
2505         limit = nonempty ? NaN : huge (limit);
2506    5) NaNs need to be supported, but it is known at compile time or cheaply
2507       at runtime whether array is nonempty or not, rank > 1:
2508       limit = Infinity;
2509       fast = false;
2510       S1 = from1;
2511       while (S1 <= to1) {
2512         S2 = from2;
2513         while (S2 <= to2) {
2514           if (fast) limit = min (a[S1][S2], limit);
2515           else {
2516             if (a[S1][S2] <= limit) {
2517               limit = a[S1][S2];
2518               fast = true;
2519             }
2520           }
2521           S2++;
2522         }
2523         S1++;
2524       }
2525       if (!fast)
2526         limit = (nonempty_array) ? NaN : huge (limit);
2527    6) NaNs aren't supported, but infinities are.  Array mask is used:
2528       limit = Infinity;
2529       nonempty = false;
2530       S = from;
2531       while (S <= to) {
2532         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2533         S++;
2534       }
2535       limit = nonempty ? limit : huge (limit);
2536    7) Same without array mask:
2537       limit = Infinity;
2538       S = from;
2539       while (S <= to) { limit = min (a[S], limit); S++; }
2540       limit = (from <= to) ? limit : huge (limit);
2541    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2542       limit = huge (limit);
2543       S = from;
2544       while (S <= to) { limit = min (a[S], limit); S++); }
2545       (or
2546       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2547       with array mask instead).
2548    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2549    setting limit = huge (limit); in the else branch.  */
2550
2551 static void
2552 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2553 {
2554   tree limit;
2555   tree type;
2556   tree tmp;
2557   tree ifbody;
2558   tree nonempty;
2559   tree nonempty_var;
2560   tree lab;
2561   tree fast;
2562   tree huge_cst = NULL, nan_cst = NULL;
2563   stmtblock_t body;
2564   stmtblock_t block, block2;
2565   gfc_loopinfo loop;
2566   gfc_actual_arglist *actual;
2567   gfc_ss *arrayss;
2568   gfc_ss *maskss;
2569   gfc_se arrayse;
2570   gfc_se maskse;
2571   gfc_expr *arrayexpr;
2572   gfc_expr *maskexpr;
2573   int n;
2574
2575   if (se->ss)
2576     {
2577       gfc_conv_intrinsic_funcall (se, expr);
2578       return;
2579     }
2580
2581   type = gfc_typenode_for_spec (&expr->ts);
2582   /* Initialize the result.  */
2583   limit = gfc_create_var (type, "limit");
2584   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2585   switch (expr->ts.type)
2586     {
2587     case BT_REAL:
2588       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2589                                         expr->ts.kind, 0);
2590       if (HONOR_INFINITIES (DECL_MODE (limit)))
2591         {
2592           REAL_VALUE_TYPE real;
2593           real_inf (&real);
2594           tmp = build_real (type, real);
2595         }
2596       else
2597         tmp = huge_cst;
2598       if (HONOR_NANS (DECL_MODE (limit)))
2599         {
2600           REAL_VALUE_TYPE real;
2601           real_nan (&real, "", 1, DECL_MODE (limit));
2602           nan_cst = build_real (type, real);
2603         }
2604       break;
2605
2606     case BT_INTEGER:
2607       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2608       break;
2609
2610     default:
2611       gcc_unreachable ();
2612     }
2613
2614   /* We start with the most negative possible value for MAXVAL, and the most
2615      positive possible value for MINVAL. The most negative possible value is
2616      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2617      possible value is HUGE in both cases.  */
2618   if (op == GT_EXPR)
2619     {
2620       tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2621       if (huge_cst)
2622         huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2623     }
2624
2625   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2626     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2627                        tmp, build_int_cst (type, 1));
2628
2629   gfc_add_modify (&se->pre, limit, tmp);
2630
2631   /* Walk the arguments.  */
2632   actual = expr->value.function.actual;
2633   arrayexpr = actual->expr;
2634   arrayss = gfc_walk_expr (arrayexpr);
2635   gcc_assert (arrayss != gfc_ss_terminator);
2636
2637   actual = actual->next->next;
2638   gcc_assert (actual);
2639   maskexpr = actual->expr;
2640   nonempty = NULL;
2641   if (maskexpr && maskexpr->rank != 0)
2642     {
2643       maskss = gfc_walk_expr (maskexpr);
2644       gcc_assert (maskss != gfc_ss_terminator);
2645     }
2646   else
2647     {
2648       mpz_t asize;
2649       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2650         {
2651           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2652           mpz_clear (asize);
2653           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2654                                   gfc_index_zero_node);
2655         }
2656       maskss = NULL;
2657     }
2658
2659   /* Initialize the scalarizer.  */
2660   gfc_init_loopinfo (&loop);
2661   gfc_add_ss_to_loop (&loop, arrayss);
2662   if (maskss)
2663     gfc_add_ss_to_loop (&loop, maskss);
2664
2665   /* Initialize the loop.  */
2666   gfc_conv_ss_startstride (&loop);
2667   gfc_conv_loop_setup (&loop, &expr->where);
2668
2669   if (nonempty == NULL && maskss == NULL
2670       && loop.dimen == 1 && loop.from[0] && loop.to[0])
2671     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2672                             loop.to[0]);
2673   nonempty_var = NULL;
2674   if (nonempty == NULL
2675       && (HONOR_INFINITIES (DECL_MODE (limit))
2676           || HONOR_NANS (DECL_MODE (limit))))
2677     {
2678       nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2679       gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2680       nonempty = nonempty_var;
2681     }
2682   lab = NULL;
2683   fast = NULL;
2684   if (HONOR_NANS (DECL_MODE (limit)))
2685     {
2686       if (loop.dimen == 1)
2687         {
2688           lab = gfc_build_label_decl (NULL_TREE);
2689           TREE_USED (lab) = 1;
2690         }
2691       else
2692         {
2693           fast = gfc_create_var (boolean_type_node, "fast");
2694           gfc_add_modify (&se->pre, fast, boolean_false_node);
2695         }
2696     }
2697
2698   gfc_mark_ss_chain_used (arrayss, 1);
2699   if (maskss)
2700     gfc_mark_ss_chain_used (maskss, 1);
2701   /* Generate the loop body.  */
2702   gfc_start_scalarized_body (&loop, &body);
2703
2704   /* If we have a mask, only add this element if the mask is set.  */
2705   if (maskss)
2706     {
2707       gfc_init_se (&maskse, NULL);
2708       gfc_copy_loopinfo_to_se (&maskse, &loop);
2709       maskse.ss = maskss;
2710       gfc_conv_expr_val (&maskse, maskexpr);
2711       gfc_add_block_to_block (&body, &maskse.pre);
2712
2713       gfc_start_block (&block);
2714     }
2715   else
2716     gfc_init_block (&block);
2717
2718   /* Compare with the current limit.  */
2719   gfc_init_se (&arrayse, NULL);
2720   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2721   arrayse.ss = arrayss;
2722   gfc_conv_expr_val (&arrayse, arrayexpr);
2723   gfc_add_block_to_block (&block, &arrayse.pre);
2724
2725   gfc_init_block (&block2);
2726
2727   if (nonempty_var)
2728     gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2729
2730   if (HONOR_NANS (DECL_MODE (limit)))
2731     {
2732       tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2733                          boolean_type_node, arrayse.expr, limit);
2734       if (lab)
2735         ifbody = build1_v (GOTO_EXPR, lab);
2736       else
2737         {
2738           stmtblock_t ifblock;
2739
2740           gfc_init_block (&ifblock);
2741           gfc_add_modify (&ifblock, limit, arrayse.expr);
2742           gfc_add_modify (&ifblock, fast, boolean_true_node);
2743           ifbody = gfc_finish_block (&ifblock);
2744         }
2745       tmp = build3_v (COND_EXPR, tmp, ifbody,
2746                       build_empty_stmt (input_location));
2747       gfc_add_expr_to_block (&block2, tmp);
2748     }
2749   else
2750     {
2751       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2752          signed zeros.  */
2753       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2754         {
2755           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2756           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2757           tmp = build3_v (COND_EXPR, tmp, ifbody,
2758                           build_empty_stmt (input_location));
2759           gfc_add_expr_to_block (&block2, tmp);
2760         }
2761       else
2762         {
2763           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2764                              type, arrayse.expr, limit);
2765           gfc_add_modify (&block2, limit, tmp);
2766         }
2767     }
2768
2769   if (fast)
2770     {
2771       tree elsebody = gfc_finish_block (&block2);
2772
2773       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2774          signed zeros.  */
2775       if (HONOR_NANS (DECL_MODE (limit))
2776           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2777         {
2778           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2779           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2780           ifbody = build3_v (COND_EXPR, tmp, ifbody,
2781                              build_empty_stmt (input_location));
2782         }
2783       else
2784         {
2785           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2786                              type, arrayse.expr, limit);
2787           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2788         }
2789       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2790       gfc_add_expr_to_block (&block, tmp);
2791     }
2792   else
2793     gfc_add_block_to_block (&block, &block2);
2794
2795   gfc_add_block_to_block (&block, &arrayse.post);
2796
2797   tmp = gfc_finish_block (&block);
2798   if (maskss)
2799     /* We enclose the above in if (mask) {...}.  */
2800     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2801                     build_empty_stmt (input_location));
2802   gfc_add_expr_to_block (&body, tmp);
2803
2804   if (lab)
2805     {
2806       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2807
2808       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2809       gfc_add_modify (&loop.code[0], limit, tmp);
2810       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2811
2812       gfc_start_block (&body);
2813
2814       /* If we have a mask, only add this element if the mask is set.  */
2815       if (maskss)
2816         {
2817           gfc_init_se (&maskse, NULL);
2818           gfc_copy_loopinfo_to_se (&maskse, &loop);
2819           maskse.ss = maskss;
2820           gfc_conv_expr_val (&maskse, maskexpr);
2821           gfc_add_block_to_block (&body, &maskse.pre);
2822
2823           gfc_start_block (&block);
2824         }
2825       else
2826         gfc_init_block (&block);
2827
2828       /* Compare with the current limit.  */
2829       gfc_init_se (&arrayse, NULL);
2830       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2831       arrayse.ss = arrayss;
2832       gfc_conv_expr_val (&arrayse, arrayexpr);
2833       gfc_add_block_to_block (&block, &arrayse.pre);
2834
2835       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2836          signed zeros.  */
2837       if (HONOR_NANS (DECL_MODE (limit))
2838           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2839         {
2840           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2841           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2842           tmp = build3_v (COND_EXPR, tmp, ifbody,
2843                           build_empty_stmt (input_location));
2844           gfc_add_expr_to_block (&block, tmp);
2845         }
2846       else
2847         {
2848           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2849                              type, arrayse.expr, limit);
2850           gfc_add_modify (&block, limit, tmp);
2851         }
2852
2853       gfc_add_block_to_block (&block, &arrayse.post);
2854
2855       tmp = gfc_finish_block (&block);
2856       if (maskss)
2857         /* We enclose the above in if (mask) {...}.  */
2858         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2859                         build_empty_stmt (input_location));
2860       gfc_add_expr_to_block (&body, tmp);
2861       /* Avoid initializing loopvar[0] again, it should be left where
2862          it finished by the first loop.  */
2863       loop.from[0] = loop.loopvar[0];
2864     }
2865   gfc_trans_scalarizing_loops (&loop, &body);
2866
2867   if (fast)
2868     {
2869       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2870       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2871       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2872                       ifbody);
2873       gfc_add_expr_to_block (&loop.pre, tmp);
2874     }
2875   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2876     {
2877       tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2878       gfc_add_modify (&loop.pre, limit, tmp);
2879     }
2880
2881   /* For a scalar mask, enclose the loop in an if statement.  */
2882   if (maskexpr && maskss == NULL)
2883     {
2884       tree else_stmt;
2885
2886       gfc_init_se (&maskse, NULL);
2887       gfc_conv_expr_val (&maskse, maskexpr);
2888       gfc_init_block (&block);
2889       gfc_add_block_to_block (&block, &loop.pre);
2890       gfc_add_block_to_block (&block, &loop.post);
2891       tmp = gfc_finish_block (&block);
2892
2893       if (HONOR_INFINITIES (DECL_MODE (limit)))
2894         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
2895       else
2896         else_stmt = build_empty_stmt (input_location);
2897       tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
2898       gfc_add_expr_to_block (&block, tmp);
2899       gfc_add_block_to_block (&se->pre, &block);
2900     }
2901   else
2902     {
2903       gfc_add_block_to_block (&se->pre, &loop.pre);
2904       gfc_add_block_to_block (&se->pre, &loop.post);
2905     }
2906
2907   gfc_cleanup_loop (&loop);
2908
2909   se->expr = limit;
2910 }
2911
2912 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2913 static void
2914 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2915 {
2916   tree args[2];
2917   tree type;
2918   tree tmp;
2919
2920   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2921   type = TREE_TYPE (args[0]);
2922
2923   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2924   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2925   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2926                      build_int_cst (type, 0));
2927   type = gfc_typenode_for_spec (&expr->ts);
2928   se->expr = convert (type, tmp);
2929 }
2930
2931 /* Generate code to perform the specified operation.  */
2932 static void
2933 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
2934 {
2935   tree args[2];
2936
2937   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2938   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2939 }
2940
2941 /* Bitwise not.  */
2942 static void
2943 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2944 {
2945   tree arg;
2946
2947   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2948   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2949 }
2950
2951 /* Set or clear a single bit.  */
2952 static void
2953 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2954 {
2955   tree args[2];
2956   tree type;
2957   tree tmp;
2958   enum tree_code op;
2959
2960   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2961   type = TREE_TYPE (args[0]);
2962
2963   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2964   if (set)
2965     op = BIT_IOR_EXPR;
2966   else
2967     {
2968       op = BIT_AND_EXPR;
2969       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2970     }
2971   se->expr = fold_build2 (op, type, args[0], tmp);
2972 }
2973
2974 /* Extract a sequence of bits.
2975     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2976 static void
2977 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2978 {
2979   tree args[3];
2980   tree type;
2981   tree tmp;
2982   tree mask;
2983
2984   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2985   type = TREE_TYPE (args[0]);
2986
2987   mask = build_int_cst (type, -1);
2988   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2989   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2990
2991   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2992
2993   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2994 }
2995
2996 /* RSHIFT (I, SHIFT) = I >> SHIFT
2997    LSHIFT (I, SHIFT) = I << SHIFT  */
2998 static void
2999 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3000 {
3001   tree args[2];
3002
3003   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3004
3005   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3006                           TREE_TYPE (args[0]), args[0], args[1]);
3007 }
3008
3009 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3010                         ? 0
3011                         : ((shift >= 0) ? i << shift : i >> -shift)
3012    where all shifts are logical shifts.  */
3013 static void
3014 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3015 {
3016   tree args[2];
3017   tree type;
3018   tree utype;
3019   tree tmp;
3020   tree width;
3021   tree num_bits;
3022   tree cond;
3023   tree lshift;
3024   tree rshift;
3025
3026   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3027   type = TREE_TYPE (args[0]);
3028   utype = unsigned_type_for (type);
3029
3030   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3031
3032   /* Left shift if positive.  */
3033   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3034
3035   /* Right shift if negative.
3036      We convert to an unsigned type because we want a logical shift.
3037      The standard doesn't define the case of shifting negative
3038      numbers, and we try to be compatible with other compilers, most
3039      notably g77, here.  */
3040   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3041                                             convert (utype, args[0]), width));
3042
3043   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3044                      build_int_cst (TREE_TYPE (args[1]), 0));
3045   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3046
3047   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3048      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3049      special case.  */
3050   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3051   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3052
3053   se->expr = fold_build3 (COND_EXPR, type, cond,
3054                           build_int_cst (type, 0), tmp);
3055 }
3056
3057
3058 /* Circular shift.  AKA rotate or barrel shift.  */
3059
3060 static void
3061 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3062 {
3063   tree *args;
3064   tree type;
3065   tree tmp;
3066   tree lrot;
3067   tree rrot;
3068   tree zero;
3069   unsigned int num_args;
3070
3071   num_args = gfc_intrinsic_argument_list_length (expr);
3072   args = (tree *) alloca (sizeof (tree) * num_args);
3073
3074   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3075
3076   if (num_args == 3)
3077     {
3078       /* Use a library function for the 3 parameter version.  */
3079       tree int4type = gfc_get_int_type (4);
3080
3081       type = TREE_TYPE (args[0]);
3082       /* We convert the first argument to at least 4 bytes, and
3083          convert back afterwards.  This removes the need for library
3084          functions for all argument sizes, and function will be
3085          aligned to at least 32 bits, so there's no loss.  */
3086       if (expr->ts.kind < 4)
3087         args[0] = convert (int4type, args[0]);
3088
3089       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3090          need loads of library  functions.  They cannot have values >
3091          BIT_SIZE (I) so the conversion is safe.  */
3092       args[1] = convert (int4type, args[1]);
3093       args[2] = convert (int4type, args[2]);
3094
3095       switch (expr->ts.kind)
3096         {
3097         case 1:
3098         case 2:
3099         case 4:
3100           tmp = gfor_fndecl_math_ishftc4;
3101           break;
3102         case 8:
3103           tmp = gfor_fndecl_math_ishftc8;
3104           break;
3105         case 16:
3106           tmp = gfor_fndecl_math_ishftc16;
3107           break;
3108         default:
3109           gcc_unreachable ();
3110         }
3111       se->expr = build_call_expr_loc (input_location,
3112                                   tmp, 3, args[0], args[1], args[2]);
3113       /* Convert the result back to the original type, if we extended
3114          the first argument's width above.  */
3115       if (expr->ts.kind < 4)
3116         se->expr = convert (type, se->expr);
3117
3118       return;
3119     }
3120   type = TREE_TYPE (args[0]);
3121
3122   /* Rotate left if positive.  */
3123   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3124
3125   /* Rotate right if negative.  */
3126   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3127   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3128
3129   zero = build_int_cst (TREE_TYPE (args[1]), 0);
3130   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3131   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3132
3133   /* Do nothing if shift == 0.  */
3134   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3135   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3136 }
3137
3138 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3139                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3140
3141    The conditional expression is necessary because the result of LEADZ(0)
3142    is defined, but the result of __builtin_clz(0) is undefined for most
3143    targets.
3144
3145    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3146    difference in bit size between the argument of LEADZ and the C int.  */
3147
3148 static void
3149 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3150 {
3151   tree arg;
3152   tree arg_type;
3153   tree cond;
3154   tree result_type;
3155   tree leadz;
3156   tree bit_size;
3157   tree tmp;
3158   tree func;
3159   int s, argsize;
3160
3161   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3162   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3163
3164   /* Which variant of __builtin_clz* should we call?  */
3165   if (argsize <= INT_TYPE_SIZE)
3166     {
3167       arg_type = unsigned_type_node;
3168       func = built_in_decls[BUILT_IN_CLZ];
3169     }
3170   else if (argsize <= LONG_TYPE_SIZE)
3171     {
3172       arg_type = long_unsigned_type_node;
3173       func = built_in_decls[BUILT_IN_CLZL];
3174     }
3175   else if (argsize <= LONG_LONG_TYPE_SIZE)
3176     {
3177       arg_type = long_long_unsigned_type_node;
3178       func = built_in_decls[BUILT_IN_CLZLL];
3179     }
3180   else
3181     {
3182       gcc_assert (argsize == 128);
3183       arg_type = gfc_build_uint_type (argsize);
3184       func = gfor_fndecl_clz128;
3185     }
3186
3187   /* Convert the actual argument twice: first, to the unsigned type of the
3188      same size; then, to the proper argument type for the built-in
3189      function.  But the return type is of the default INTEGER kind.  */
3190   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3191   arg = fold_convert (arg_type, arg);
3192   result_type = gfc_get_int_type (gfc_default_integer_kind);
3193
3194   /* Compute LEADZ for the case i .ne. 0.  */
3195   s = TYPE_PRECISION (arg_type) - argsize;
3196   tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3197   leadz = fold_build2 (MINUS_EXPR, result_type,
3198                        tmp, build_int_cst (result_type, s));
3199
3200   /* Build BIT_SIZE.  */
3201   bit_size = build_int_cst (result_type, argsize);
3202
3203   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3204                       arg, build_int_cst (arg_type, 0));
3205   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3206 }
3207
3208 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3209
3210    The conditional expression is necessary because the result of TRAILZ(0)
3211    is defined, but the result of __builtin_ctz(0) is undefined for most
3212    targets.  */
3213
3214 static void
3215 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3216 {
3217   tree arg;
3218   tree arg_type;
3219   tree cond;
3220   tree result_type;
3221   tree trailz;
3222   tree bit_size;
3223   tree func;
3224   int argsize;
3225
3226   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3227   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3228
3229   /* Which variant of __builtin_ctz* should we call?  */
3230   if (argsize <= INT_TYPE_SIZE)
3231     {
3232       arg_type = unsigned_type_node;
3233       func = built_in_decls[BUILT_IN_CTZ];
3234     }
3235   else if (argsize <= LONG_TYPE_SIZE)
3236     {
3237       arg_type = long_unsigned_type_node;
3238       func = built_in_decls[BUILT_IN_CTZL];
3239     }
3240   else if (argsize <= LONG_LONG_TYPE_SIZE)
3241     {
3242       arg_type = long_long_unsigned_type_node;
3243       func = built_in_decls[BUILT_IN_CTZLL];
3244     }
3245   else
3246     {
3247       gcc_assert (argsize == 128);
3248       arg_type = gfc_build_uint_type (argsize);
3249       func = gfor_fndecl_ctz128;
3250     }
3251
3252   /* Convert the actual argument twice: first, to the unsigned type of the
3253      same size; then, to the proper argument type for the built-in
3254      function.  But the return type is of the default INTEGER kind.  */
3255   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3256   arg = fold_convert (arg_type, arg);
3257   result_type = gfc_get_int_type (gfc_default_integer_kind);
3258
3259   /* Compute TRAILZ for the case i .ne. 0.  */
3260   trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3261                                                        func, 1, arg));
3262
3263   /* Build BIT_SIZE.  */
3264   bit_size = build_int_cst (result_type, argsize);
3265
3266   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3267                       arg, build_int_cst (arg_type, 0));
3268   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3269 }
3270
3271 /* Process an intrinsic with unspecified argument-types that has an optional
3272    argument (which could be of type character), e.g. EOSHIFT.  For those, we
3273    need to append the string length of the optional argument if it is not
3274    present and the type is really character.
3275    primary specifies the position (starting at 1) of the non-optional argument
3276    specifying the type and optional gives the position of the optional
3277    argument in the arglist.  */
3278
3279 static void
3280 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3281                                      unsigned primary, unsigned optional)
3282 {
3283   gfc_actual_arglist* prim_arg;
3284   gfc_actual_arglist* opt_arg;
3285   unsigned cur_pos;
3286   gfc_actual_arglist* arg;
3287   gfc_symbol* sym;
3288   tree append_args;
3289
3290   /* Find the two arguments given as position.  */
3291   cur_pos = 0;
3292   prim_arg = NULL;
3293   opt_arg = NULL;
3294   for (arg = expr->value.function.actual; arg; arg = arg->next)
3295     {
3296       ++cur_pos;
3297
3298       if (cur_pos == primary)
3299         prim_arg = arg;
3300       if (cur_pos == optional)
3301         opt_arg = arg;
3302
3303       if (cur_pos >= primary && cur_pos >= optional)
3304         break;
3305     }
3306   gcc_assert (prim_arg);
3307   gcc_assert (prim_arg->expr);
3308   gcc_assert (opt_arg);
3309
3310   /* If we do have type CHARACTER and the optional argument is really absent,
3311      append a dummy 0 as string length.  */
3312   append_args = NULL_TREE;
3313   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3314     {
3315       tree dummy;
3316
3317       dummy = build_int_cst (gfc_charlen_type_node, 0);
3318       append_args = gfc_chainon_list (append_args, dummy);
3319     }
3320
3321   /* Build the call itself.  */
3322   sym = gfc_get_symbol_for_expr (expr);
3323   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3324                           append_args);
3325   gfc_free (sym);
3326 }
3327
3328
3329 /* The length of a character string.  */
3330 static void
3331 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3332 {
3333   tree len;
3334   tree type;
3335   tree decl;
3336   gfc_symbol *sym;
3337   gfc_se argse;
3338   gfc_expr *arg;
3339   gfc_ss *ss;
3340
3341   gcc_assert (!se->ss);
3342
3343   arg = expr->value.function.actual->expr;
3344
3345   type = gfc_typenode_for_spec (&expr->ts);
3346   switch (arg->expr_type)
3347     {
3348     case EXPR_CONSTANT:
3349       len = build_int_cst (NULL_TREE, arg->value.character.length);
3350       break;
3351
3352     case EXPR_ARRAY:
3353       /* Obtain the string length from the function used by
3354          trans-array.c(gfc_trans_array_constructor).  */
3355       len = NULL_TREE;
3356       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3357       break;
3358
3359     case EXPR_VARIABLE:
3360       if (arg->ref == NULL
3361             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3362         {
3363           /* This doesn't catch all cases.
3364              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3365              and the surrounding thread.  */
3366           sym = arg->symtree->n.sym;
3367           decl = gfc_get_symbol_decl (sym);
3368           if (decl == current_function_decl && sym->attr.function
3369                 && (sym->result == sym))
3370             decl = gfc_get_fake_result_decl (sym, 0);
3371
3372           len = sym->ts.u.cl->backend_decl;
3373           gcc_assert (len);
3374           break;
3375         }
3376
3377       /* Otherwise fall through.  */
3378
3379     default:
3380       /* Anybody stupid enough to do this deserves inefficient code.  */
3381       ss = gfc_walk_expr (arg);
3382       gfc_init_se (&argse, se);
3383       if (ss == gfc_ss_terminator)
3384         gfc_conv_expr (&argse, arg);
3385       else
3386         gfc_conv_expr_descriptor (&argse, arg, ss);
3387       gfc_add_block_to_block (&se->pre, &argse.pre);
3388       gfc_add_block_to_block (&se->post, &argse.post);
3389       len = argse.string_length;
3390       break;
3391     }
3392   se->expr = convert (type, len);
3393 }
3394
3395 /* The length of a character string not including trailing blanks.  */
3396 static void
3397 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3398 {
3399   int kind = expr->value.function.actual->expr->ts.kind;
3400   tree args[2], type, fndecl;
3401
3402   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3403   type = gfc_typenode_for_spec (&expr->ts);
3404
3405   if (kind == 1)
3406     fndecl = gfor_fndecl_string_len_trim;
3407   else if (kind == 4)
3408     fndecl = gfor_fndecl_string_len_trim_char4;
3409   else
3410     gcc_unreachable ();
3411
3412   se->expr = build_call_expr_loc (input_location,
3413                               fndecl, 2, args[0], args[1]);
3414   se->expr = convert (type, se->expr);
3415 }
3416
3417
3418 /* Returns the starting position of a substring within a string.  */
3419
3420 static void
3421 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3422                                       tree function)
3423 {
3424   tree logical4_type_node = gfc_get_logical_type (4);
3425   tree type;
3426   tree fndecl;
3427   tree *args;
3428   unsigned int num_args;
3429
3430   args = (tree *) alloca (sizeof (tree) * 5);
3431
3432   /* Get number of arguments; characters count double due to the
3433      string length argument. Kind= is not passed to the library
3434      and thus ignored.  */
3435   if (expr->value.function.actual->next->next->expr == NULL)
3436     num_args = 4;
3437   else
3438     num_args = 5;
3439
3440   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3441   type = gfc_typenode_for_spec (&expr->ts);
3442
3443   if (num_args == 4)
3444     args[4] = build_int_cst (logical4_type_node, 0);
3445   else
3446     args[4] = convert (logical4_type_node, args[4]);
3447
3448   fndecl = build_addr (function, current_function_decl);
3449   se->expr = build_call_array_loc (input_location,
3450                                TREE_TYPE (TREE_TYPE (function)), fndecl,
3451                                5, args);
3452   se->expr = convert (type, se->expr);
3453
3454 }
3455
3456 /* The ascii value for a single character.  */
3457 static void
3458 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3459 {
3460   tree args[2], type, pchartype;
3461
3462   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3463   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3464   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3465   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3466   type = gfc_typenode_for_spec (&expr->ts);
3467
3468   se->expr = build_fold_indirect_ref_loc (input_location,
3469                                       args[1]);
3470   se->expr = convert (type, se->expr);
3471 }
3472
3473
3474 /* Intrinsic ISNAN calls __builtin_isnan.  */
3475
3476 static void
3477 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3478 {
3479   tree arg;
3480
3481   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3482   se->expr = build_call_expr_loc (input_location,
3483                               built_in_decls[BUILT_IN_ISNAN], 1, arg);
3484   STRIP_TYPE_NOPS (se->expr);
3485   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3486 }
3487
3488
3489 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3490    their argument against a constant integer value.  */
3491
3492 static void
3493 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3494 {
3495   tree arg;
3496
3497   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3498   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3499                           arg, build_int_cst (TREE_TYPE (arg), value));
3500 }
3501
3502
3503
3504 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3505
3506 static void
3507 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3508 {
3509   tree tsource;
3510   tree fsource;
3511   tree mask;
3512   tree type;
3513   tree len, len2;
3514   tree *args;
3515   unsigned int num_args;
3516
3517   num_args = gfc_intrinsic_argument_list_length (expr);
3518   args = (tree *) alloca (sizeof (tree) * num_args);
3519
3520   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3521   if (expr->ts.type != BT_CHARACTER)
3522     {
3523       tsource = args[0];
3524       fsource = args[1];
3525       mask = args[2];
3526     }
3527   else
3528     {
3529       /* We do the same as in the non-character case, but the argument
3530          list is different because of the string length arguments. We
3531          also have to set the string length for the result.  */
3532       len = args[0];
3533       tsource = args[1];
3534       len2 = args[2];
3535       fsource = args[3];
3536       mask = args[4];
3537
3538       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3539                                    &se->pre);
3540       se->string_length = len;
3541     }
3542   type = TREE_TYPE (tsource);
3543   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3544                           fold_convert (type, fsource));
3545 }
3546
3547
3548 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3549 static void
3550 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3551 {
3552   tree arg, type, tmp, frexp;
3553
3554   frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3555
3556   type = gfc_typenode_for_spec (&expr->ts);
3557   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3558   tmp = gfc_create_var (integer_type_node, NULL);
3559   se->expr = build_call_expr_loc (input_location, frexp, 2,
3560                                   fold_convert (type, arg),
3561                                   gfc_build_addr_expr (NULL_TREE, tmp));
3562   se->expr = fold_convert (type, se->expr);
3563 }
3564
3565
3566 /* NEAREST (s, dir) is translated into
3567      tmp = copysign (HUGE_VAL, dir);
3568      return nextafter (s, tmp);
3569  */
3570 static void
3571 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3572 {
3573   tree args[2], type, tmp, nextafter, copysign, huge_val;
3574
3575   nextafter = builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
3576   copysign = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
3577   huge_val = builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
3578
3579   type = gfc_typenode_for_spec (&expr->ts);
3580   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3581   tmp = build_call_expr_loc (input_location, copysign, 2,
3582                              build_call_expr_loc (input_location, huge_val, 0),
3583                              fold_convert (type, args[1]));
3584   se->expr = build_call_expr_loc (input_location, nextafter, 2,
3585                                   fold_convert (type, args[0]), tmp);
3586   se->expr = fold_convert (type, se->expr);
3587 }
3588
3589
3590 /* SPACING (s) is translated into
3591     int e;
3592     if (s == 0)
3593       res = tiny;
3594     else
3595     {
3596       frexp (s, &e);
3597       e = e - prec;
3598       e = MAX_EXPR (e, emin);
3599       res = scalbn (1., e);
3600     }
3601     return res;
3602
3603  where prec is the precision of s, gfc_real_kinds[k].digits,
3604        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3605    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3606
3607 static void
3608 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3609 {
3610   tree arg, type, prec, emin, tiny, res, e;
3611   tree cond, tmp, frexp, scalbn;
3612   int k;
3613   stmtblock_t block;
3614
3615   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3616   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3617   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3618   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3619
3620   frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3621   scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3622
3623   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3624   arg = gfc_evaluate_now (arg, &se->pre);
3625
3626   type = gfc_typenode_for_spec (&expr->ts);
3627   e = gfc_create_var (integer_type_node, NULL);
3628   res = gfc_create_var (type, NULL);
3629
3630
3631   /* Build the block for s /= 0.  */
3632   gfc_start_block (&block);
3633   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
3634                              gfc_build_addr_expr (NULL_TREE, e));
3635   gfc_add_expr_to_block (&block, tmp);
3636
3637   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3638   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3639                                           tmp, emin));
3640
3641   tmp = build_call_expr_loc (input_location, scalbn, 2,
3642                          build_real_from_int_cst (type, integer_one_node), e);
3643   gfc_add_modify (&block, res, tmp);
3644
3645   /* Finish by building the IF statement.  */
3646   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3647                       build_real_from_int_cst (type, integer_zero_node));
3648   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3649                   gfc_finish_block (&block));
3650
3651   gfc_add_expr_to_block (&se->pre, tmp);
3652   se->expr = res;
3653 }
3654
3655
3656 /* RRSPACING (s) is translated into
3657       int e;
3658       real x;
3659       x = fabs (s);
3660       if (x != 0)
3661       {
3662         frexp (s, &e);
3663         x = scalbn (x, precision - e);
3664       }
3665       return x;
3666
3667  where precision is gfc_real_kinds[k].digits.  */
3668
3669 static void
3670 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3671 {
3672   tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
3673   int prec, k;
3674   stmtblock_t block;
3675
3676   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3677   prec = gfc_real_kinds[k].digits;
3678
3679   frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3680   scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3681   fabs = builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
3682
3683   type = gfc_typenode_for_spec (&expr->ts);
3684   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3685   arg = gfc_evaluate_now (arg, &se->pre);
3686
3687   e = gfc_create_var (integer_type_node, NULL);
3688   x = gfc_create_var (type, NULL);
3689   gfc_add_modify (&se->pre, x,
3690                   build_call_expr_loc (input_location, fabs, 1, arg));
3691
3692
3693   gfc_start_block (&block);
3694   tmp = build_call_expr_loc (input_location, frexp, 2, arg,
3695                              gfc_build_addr_expr (NULL_TREE, e));
3696   gfc_add_expr_to_block (&block, tmp);
3697
3698   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3699                      build_int_cst (NULL_TREE, prec), e);
3700   tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
3701   gfc_add_modify (&block, x, tmp);
3702   stmt = gfc_finish_block (&block);
3703
3704   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3705                       build_real_from_int_cst (type, integer_zero_node));
3706   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3707   gfc_add_expr_to_block (&se->pre, tmp);
3708
3709   se->expr = fold_convert (type, x);
3710 }
3711
3712
3713 /* SCALE (s, i) is translated into scalbn (s, i).  */
3714 static void
3715 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3716 {
3717   tree args[2], type, scalbn;
3718
3719   scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3720
3721   type = gfc_typenode_for_spec (&expr->ts);
3722   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3723   se->expr = build_call_expr_loc (input_location, scalbn, 2,
3724                                   fold_convert (type, args[0]),
3725                                   fold_convert (integer_type_node, args[1]));
3726   se->expr = fold_convert (type, se->expr);
3727 }
3728
3729
3730 /* SET_EXPONENT (s, i) is translated into
3731    scalbn (frexp (s, &dummy_int), i).  */
3732 static void
3733 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3734 {
3735   tree args[2], type, tmp, frexp, scalbn;
3736
3737   frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
3738   scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
3739
3740   type = gfc_typenode_for_spec (&expr->ts);
3741   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3742
3743   tmp = gfc_create_var (integer_type_node, NULL);
3744   tmp = build_call_expr_loc (input_location, frexp, 2,
3745                              fold_convert (type, args[0]),
3746                              gfc_build_addr_expr (NULL_TREE, tmp));
3747   se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
3748                                   fold_convert (integer_type_node, args[1]));
3749   se->expr = fold_convert (type, se->expr);
3750 }
3751
3752
3753 static void
3754 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3755 {
3756   gfc_actual_arglist *actual;
3757   tree arg1;
3758   tree type;
3759   tree fncall0;
3760   tree fncall1;
3761   gfc_se argse;
3762   gfc_ss *ss;
3763
3764   gfc_init_se (&argse, NULL);
3765   actual = expr->value.function.actual;
3766
3767   ss = gfc_walk_expr (actual->expr);
3768   gcc_assert (ss != gfc_ss_terminator);
3769   argse.want_pointer = 1;
3770   argse.data_not_needed = 1;
3771   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3772   gfc_add_block_to_block (&se->pre, &argse.pre);
3773   gfc_add_block_to_block (&se->post, &argse.post);
3774   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3775
3776   /* Build the call to size0.  */
3777   fncall0 = build_call_expr_loc (input_location,
3778                              gfor_fndecl_size0, 1, arg1);
3779
3780   actual = actual->next;
3781
3782   if (actual->expr)
3783     {
3784       gfc_init_se (&argse, NULL);
3785       gfc_conv_expr_type (&argse, actual->expr,
3786                           gfc_array_index_type);
3787       gfc_add_block_to_block (&se->pre, &argse.pre);
3788
3789       /* Unusually, for an intrinsic, size does not exclude
3790          an optional arg2, so we must test for it.  */
3791       if (actual->expr->expr_type == EXPR_VARIABLE
3792             && actual->expr->symtree->n.sym->attr.dummy
3793             && actual->expr->symtree->n.sym->attr.optional)
3794         {
3795           tree tmp;
3796           /* Build the call to size1.  */
3797           fncall1 = build_call_expr_loc (input_location,
3798                                      gfor_fndecl_size1, 2,
3799                                      arg1, argse.expr);
3800
3801           gfc_init_se (&argse, NULL);
3802           argse.want_pointer = 1;
3803           argse.data_not_needed = 1;
3804           gfc_conv_expr (&argse, actual->expr);
3805           gfc_add_block_to_block (&se->pre, &argse.pre);
3806           tmp = fold_build2 (NE_EXPR, boolean_type_node,
3807                              argse.expr, null_pointer_node);
3808           tmp = gfc_evaluate_now (tmp, &se->pre);
3809           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3810                                   tmp, fncall1, fncall0);
3811         }
3812       else
3813         {
3814           se->expr = NULL_TREE;
3815           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3816                                     argse.expr, gfc_index_one_node);
3817         }
3818     }
3819   else if (expr->value.function.actual->expr->rank == 1)
3820     {
3821       argse.expr = gfc_index_zero_node;
3822       se->expr = NULL_TREE;
3823     }
3824   else
3825     se->expr = fncall0;
3826
3827   if (se->expr == NULL_TREE)
3828     {
3829       tree ubound, lbound;
3830
3831       arg1 = build_fold_indirect_ref_loc (input_location,
3832                                       arg1);
3833       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
3834       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
3835       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3836                               ubound, lbound);
3837       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
3838                               gfc_index_one_node);
3839       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
3840                               gfc_index_zero_node);
3841     }
3842
3843   type = gfc_typenode_for_spec (&expr->ts);
3844   se->expr = convert (type, se->expr);
3845 }
3846
3847
3848 /* Helper function to compute the size of a character variable,
3849    excluding the terminating null characters.  The result has
3850    gfc_array_index_type type.  */
3851
3852 static tree
3853 size_of_string_in_bytes (int kind, tree string_length)
3854 {
3855   tree bytesize;
3856   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
3857
3858   bytesize = build_int_cst (gfc_array_index_type,
3859                             gfc_character_kinds[i].bit_size / 8);
3860
3861   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
3862                       fold_convert (gfc_array_index_type, string_length));
3863 }
3864
3865
3866 static void
3867 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3868 {
3869   gfc_expr *arg;
3870   gfc_ss *ss;
3871   gfc_se argse;
3872   tree source_bytes;
3873   tree type;
3874   tree tmp;
3875   tree lower;
3876   tree upper;
3877   int n;
3878
3879   arg = expr->value.function.actual->expr;
3880
3881   gfc_init_se (&argse, NULL);
3882   ss = gfc_walk_expr (arg);
3883
3884   if (ss == gfc_ss_terminator)
3885     {
3886       gfc_conv_expr_reference (&argse, arg);
3887
3888       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
3889                                                  argse.expr));
3890
3891       /* Obtain the source word length.  */
3892       if (arg->ts.type == BT_CHARACTER)
3893         se->expr = size_of_string_in_bytes (arg->ts.kind,
3894                                             argse.string_length);
3895       else
3896         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3897     }
3898   else
3899     {
3900       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3901       argse.want_pointer = 0;
3902       gfc_conv_expr_descriptor (&argse, arg, ss);
3903       type = gfc_get_element_type (TREE_TYPE (argse.expr));
3904
3905       /* Obtain the argument's word length.  */
3906       if (arg->ts.type == BT_CHARACTER)
3907         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3908       else
3909         tmp = fold_convert (gfc_array_index_type,
3910                             size_in_bytes (type));
3911       gfc_add_modify (&argse.pre, source_bytes, tmp);
3912
3913       /* Obtain the size of the array in bytes.  */
3914       for (n = 0; n < arg->rank; n++)
3915         {
3916           tree idx;
3917           idx = gfc_rank_cst[n];
3918           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
3919           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
3920           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3921                              upper, lower);
3922           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3923                              tmp, gfc_index_one_node);
3924           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3925                              tmp, source_bytes);
3926           gfc_add_modify (&argse.pre, source_bytes, tmp);
3927         }
3928       se->expr = source_bytes;
3929     }
3930
3931   gfc_add_block_to_block (&se->pre, &argse.pre);
3932 }
3933
3934
3935 /* Intrinsic string comparison functions.  */
3936
3937 static void
3938 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3939 {
3940   tree args[4];
3941
3942   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3943
3944   se->expr
3945     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3946                                 expr->value.function.actual->expr->ts.kind);
3947   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3948                           build_int_cst (TREE_TYPE (se->expr), 0));
3949 }
3950
3951 /* Generate a call to the adjustl/adjustr library function.  */
3952 static void
3953 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3954 {
3955   tree args[3];
3956   tree len;
3957   tree type;
3958   tree var;
3959   tree tmp;
3960
3961   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3962   len = args[1];
3963
3964   type = TREE_TYPE (args[2]);
3965   var = gfc_conv_string_tmp (se, type, len);
3966   args[0] = var;
3967
3968   tmp = build_call_expr_loc (input_location,
3969                          fndecl, 3, args[0], args[1], args[2]);
3970   gfc_add_expr_to_block (&se->pre, tmp);
3971   se->expr = var;
3972   se->string_length = len;
3973 }
3974
3975
3976 /* Generate code for the TRANSFER intrinsic:
3977         For scalar results:
3978           DEST = TRANSFER (SOURCE, MOLD)
3979         where:
3980           typeof<DEST> = typeof<MOLD>
3981         and:
3982           MOLD is scalar.
3983
3984         For array results:
3985           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3986         where:
3987           typeof<DEST> = typeof<MOLD>
3988         and:
3989           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3990               sizeof (DEST(0) * SIZE).  */
3991 static void
3992 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3993 {
3994   tree tmp;
3995   tree tmpdecl;
3996   tree ptr;
3997   tree extent;
3998   tree source;
3999   tree source_type;
4000   tree source_bytes;
4001   tree mold_type;
4002   tree dest_word_len;
4003   tree size_words;
4004   tree size_bytes;
4005   tree upper;
4006   tree lower;
4007   tree stmt;
4008   gfc_actual_arglist *arg;
4009   gfc_se argse;
4010   gfc_ss *ss;
4011   gfc_ss_info *info;
4012   stmtblock_t block;
4013   int n;
4014   bool scalar_mold;
4015
4016   info = NULL;
4017   if (se->loop)
4018     info = &se->ss->data.info;
4019
4020   /* Convert SOURCE.  The output from this stage is:-
4021         source_bytes = length of the source in bytes
4022         source = pointer to the source data.  */
4023   arg = expr->value.function.actual;
4024
4025   /* Ensure double transfer through LOGICAL preserves all
4026      the needed bits.  */
4027   if (arg->expr->expr_type == EXPR_FUNCTION
4028         && arg->expr->value.function.esym == NULL
4029         && arg->expr->value.function.isym != NULL
4030         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4031         && arg->expr->ts.type == BT_LOGICAL
4032         && expr->ts.type != arg->expr->ts.type)
4033     arg->expr->value.function.name = "__transfer_in_transfer";
4034
4035   gfc_init_se (&argse, NULL);
4036   ss = gfc_walk_expr (arg->expr);
4037
4038   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4039
4040   /* Obtain the pointer to source and the length of source in bytes.  */
4041   if (ss == gfc_ss_terminator)
4042     {
4043       gfc_conv_expr_reference (&argse, arg->expr);
4044       source = argse.expr;
4045
4046       source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4047                                                         argse.expr));
4048
4049       /* Obtain the source word length.  */
4050       if (arg->expr->ts.type == BT_CHARACTER)
4051         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4052                                        argse.string_length);
4053       else
4054         tmp = fold_convert (gfc_array_index_type,
4055                             size_in_bytes (source_type));
4056     }
4057   else
4058     {
4059       argse.want_pointer = 0;
4060       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4061       source = gfc_conv_descriptor_data_get (argse.expr);
4062       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4063
4064       /* Repack the source if not a full variable array.  */
4065       if (arg->expr->expr_type == EXPR_VARIABLE
4066               && arg->expr->ref->u.ar.type != AR_FULL)
4067         {
4068           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4069
4070           if (gfc_option.warn_array_temp)
4071             gfc_warning ("Creating array temporary at %L", &expr->where);
4072
4073           source = build_call_expr_loc (input_location,
4074                                     gfor_fndecl_in_pack, 1, tmp);
4075           source = gfc_evaluate_now (source, &argse.pre);
4076
4077           /* Free the temporary.  */
4078           gfc_start_block (&block);
4079           tmp = gfc_call_free (convert (pvoid_type_node, source));
4080           gfc_add_expr_to_block (&block, tmp);
4081           stmt = gfc_finish_block (&block);
4082
4083           /* Clean up if it was repacked.  */
4084           gfc_init_block (&block);
4085           tmp = gfc_conv_array_data (argse.expr);
4086           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4087           tmp = build3_v (COND_EXPR, tmp, stmt,
4088                           build_empty_stmt (input_location));
4089           gfc_add_expr_to_block (&block, tmp);
4090           gfc_add_block_to_block (&block, &se->post);
4091           gfc_init_block (&se->post);
4092           gfc_add_block_to_block (&se->post, &block);
4093         }
4094
4095       /* Obtain the source word length.  */
4096       if (arg->expr->ts.type == BT_CHARACTER)
4097         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4098                                        argse.string_length);
4099       else
4100         tmp = fold_convert (gfc_array_index_type,
4101                             size_in_bytes (source_type));
4102
4103       /* Obtain the size of the array in bytes.  */
4104       extent = gfc_create_var (gfc_array_index_type, NULL);
4105       for (n = 0; n < arg->expr->rank; n++)
4106         {
4107           tree idx;
4108           idx = gfc_rank_cst[n];
4109           gfc_add_modify (&argse.pre, source_bytes, tmp);
4110           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4111           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4112           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4113                              upper, lower);
4114           gfc_add_modify (&argse.pre, extent, tmp);
4115           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4116                              extent, gfc_index_one_node);
4117           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4118                              tmp, source_bytes);
4119         }
4120     }
4121
4122   gfc_add_modify (&argse.pre, source_bytes, tmp);
4123   gfc_add_block_to_block (&se->pre, &argse.pre);
4124   gfc_add_block_to_block (&se->post, &argse.post);
4125
4126   /* Now convert MOLD.  The outputs are:
4127         mold_type = the TREE type of MOLD
4128         dest_word_len = destination word length in bytes.  */
4129   arg = arg->next;
4130
4131   gfc_init_se (&argse, NULL);
4132   ss = gfc_walk_expr (arg->expr);
4133
4134   scalar_mold = arg->expr->rank == 0;
4135
4136   if (ss == gfc_ss_terminator)
4137     {
4138       gfc_conv_expr_reference (&argse, arg->expr);
4139       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4140                                                       argse.expr));
4141     }
4142   else
4143     {
4144       gfc_init_se (&argse, NULL);
4145       argse.want_pointer = 0;
4146       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4147       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4148     }
4149
4150   gfc_add_block_to_block (&se->pre, &argse.pre);
4151   gfc_add_block_to_block (&se->post, &argse.post);
4152
4153   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4154     {
4155       /* If this TRANSFER is nested in another TRANSFER, use a type
4156          that preserves all bits.  */
4157       if (arg->expr->ts.type == BT_LOGICAL)
4158         mold_type = gfc_get_int_type (arg->expr->ts.kind);
4159     }
4160
4161   if (arg->expr->ts.type == BT_CHARACTER)
4162     {
4163       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4164       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4165     }
4166   else
4167     tmp = fold_convert (gfc_array_index_type,
4168                         size_in_bytes (mold_type));
4169
4170   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4171   gfc_add_modify (&se->pre, dest_word_len, tmp);
4172
4173   /* Finally convert SIZE, if it is present.  */
4174   arg = arg->next;
4175   size_words = gfc_create_var (gfc_array_index_type, NULL);
4176
4177   if (arg->expr)
4178     {
4179       gfc_init_se (&argse, NULL);
4180       gfc_conv_expr_reference (&argse, arg->expr);
4181       tmp = convert (gfc_array_index_type,
4182                      build_fold_indirect_ref_loc (input_location,
4183                                               argse.expr));
4184       gfc_add_block_to_block (&se->pre, &argse.pre);
4185       gfc_add_block_to_block (&se->post, &argse.post);
4186     }
4187   else
4188     tmp = NULL_TREE;
4189
4190   /* Separate array and scalar results.  */
4191   if (scalar_mold && tmp == NULL_TREE)
4192     goto scalar_transfer;
4193
4194   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4195   if (tmp != NULL_TREE)
4196     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4197                        tmp, dest_word_len);
4198   else
4199     tmp = source_bytes;
4200
4201   gfc_add_modify (&se->pre, size_bytes, tmp);
4202   gfc_add_modify (&se->pre, size_words,
4203                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4204                                     size_bytes, dest_word_len));
4205
4206   /* Evaluate the bounds of the result.  If the loop range exists, we have
4207      to check if it is too large.  If so, we modify loop->to be consistent
4208      with min(size, size(source)).  Otherwise, size is made consistent with
4209      the loop range, so that the right number of bytes is transferred.*/
4210   n = se->loop->order[0];
4211   if (se->loop->to[n] != NULL_TREE)
4212     {
4213       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4214                          se->loop->to[n], se->loop->from[n]);
4215       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4216                          tmp, gfc_index_one_node);
4217       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4218                          tmp, size_words);
4219       gfc_add_modify (&se->pre, size_words, tmp);
4220       gfc_add_modify (&se->pre, size_bytes,
4221                            fold_build2 (MULT_EXPR, gfc_array_index_type,
4222                                         size_words, dest_word_len));
4223       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4224                            size_words, se->loop->from[n]);
4225       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4226                            upper, gfc_index_one_node);
4227     }
4228   else
4229     {
4230       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4231                            size_words, gfc_index_one_node);
4232       se->loop->from[n] = gfc_index_zero_node;
4233     }
4234
4235   se->loop->to[n] = upper;
4236
4237   /* Build a destination descriptor, using the pointer, source, as the
4238      data field.  */
4239   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4240                                info, mold_type, NULL_TREE, false, true, false,
4241                                &expr->where);
4242
4243   /* Cast the pointer to the result.  */
4244   tmp = gfc_conv_descriptor_data_get (info->descriptor);
4245   tmp = fold_convert (pvoid_type_node, tmp);
4246
4247   /* Use memcpy to do the transfer.  */
4248   tmp = build_call_expr_loc (input_location,
4249                          built_in_decls[BUILT_IN_MEMCPY],
4250                          3,
4251                          tmp,
4252                          fold_convert (pvoid_type_node, source),
4253                          fold_build2 (MIN_EXPR, gfc_array_index_type,
4254                                       size_bytes, source_bytes));
4255   gfc_add_expr_to_block (&se->pre, tmp);
4256
4257   se->expr = info->descriptor;
4258   if (expr->ts.type == BT_CHARACTER)
4259     se->string_length = dest_word_len;
4260
4261   return;
4262
4263 /* Deal with scalar results.  */
4264 scalar_transfer:
4265   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4266                         dest_word_len, source_bytes);
4267   extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4268                         extent, gfc_index_zero_node);
4269
4270   if (expr->ts.type == BT_CHARACTER)
4271     {
4272       tree direct;
4273       tree indirect;
4274
4275       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4276       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4277                                 "transfer");
4278
4279       /* If source is longer than the destination, use a pointer to
4280          the source directly.  */
4281       gfc_init_block (&block);
4282       gfc_add_modify (&block, tmpdecl, ptr);
4283       direct = gfc_finish_block (&block);
4284
4285       /* Otherwise, allocate a string with the length of the destination
4286          and copy the source into it.  */
4287       gfc_init_block (&block);
4288       tmp = gfc_get_pchar_type (expr->ts.kind);
4289       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4290       gfc_add_modify (&block, tmpdecl,
4291                       fold_convert (TREE_TYPE (ptr), tmp));
4292       tmp = build_call_expr_loc (input_location,
4293                              built_in_decls[BUILT_IN_MEMCPY], 3,
4294                              fold_convert (pvoid_type_node, tmpdecl),
4295                              fold_convert (pvoid_type_node, ptr),
4296                              extent);
4297       gfc_add_expr_to_block (&block, tmp);
4298       indirect = gfc_finish_block (&block);
4299
4300       /* Wrap it up with the condition.  */
4301       tmp = fold_build2 (LE_EXPR, boolean_type_node,
4302                          dest_word_len, source_bytes);
4303       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4304       gfc_add_expr_to_block (&se->pre, tmp);
4305
4306       se->expr = tmpdecl;
4307       se->string_length = dest_word_len;
4308     }
4309   else
4310     {
4311       tmpdecl = gfc_create_var (mold_type, "transfer");
4312
4313       ptr = convert (build_pointer_type (mold_type), source);
4314
4315       /* Use memcpy to do the transfer.  */
4316       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4317       tmp = build_call_expr_loc (input_location,
4318                              built_in_decls[BUILT_IN_MEMCPY], 3,
4319                              fold_convert (pvoid_type_node, tmp),
4320                              fold_convert (pvoid_type_node, ptr),
4321                              extent);
4322       gfc_add_expr_to_block (&se->pre, tmp);
4323
4324       se->expr = tmpdecl;
4325     }
4326 }
4327
4328
4329 /* Generate code for the ALLOCATED intrinsic.
4330    Generate inline code that directly check the address of the argument.  */
4331
4332 static void
4333 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4334 {
4335   gfc_actual_arglist *arg1;
4336   gfc_se arg1se;
4337   gfc_ss *ss1;
4338   tree tmp;
4339
4340   gfc_init_se (&arg1se, NULL);
4341   arg1 = expr->value.function.actual;
4342   ss1 = gfc_walk_expr (arg1->expr);
4343
4344   if (ss1 == gfc_ss_terminator)
4345     {
4346       /* Allocatable scalar.  */
4347       arg1se.want_pointer = 1;
4348       if (arg1->expr->ts.type == BT_CLASS)
4349         gfc_add_component_ref (arg1->expr, "$data");
4350       gfc_conv_expr (&arg1se, arg1->expr);
4351       tmp = arg1se.expr;
4352     }
4353   else
4354     {
4355       /* Allocatable array.  */
4356       arg1se.descriptor_only = 1;
4357       gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4358       tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4359     }
4360
4361   tmp = fold_build2 (NE_EXPR, boolean_type_node,
4362                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4363   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4364 }
4365
4366
4367 /* Generate code for the ASSOCIATED intrinsic.
4368    If both POINTER and TARGET are arrays, generate a call to library function
4369    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4370    In other cases, generate inline code that directly compare the address of
4371    POINTER with the address of TARGET.  */
4372
4373 static void
4374 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4375 {
4376   gfc_actual_arglist *arg1;
4377   gfc_actual_arglist *arg2;
4378   gfc_se arg1se;
4379   gfc_se arg2se;
4380   tree tmp2;
4381   tree tmp;
4382   tree nonzero_charlen;
4383   tree nonzero_arraylen;
4384   gfc_ss *ss1, *ss2;
4385
4386   gfc_init_se (&arg1se, NULL);
4387   gfc_init_se (&arg2se, NULL);
4388   arg1 = expr->value.function.actual;
4389   if (arg1->expr->ts.type == BT_CLASS)
4390     gfc_add_component_ref (arg1->expr, "$data");
4391   arg2 = arg1->next;
4392   ss1 = gfc_walk_expr (arg1->expr);
4393
4394   if (!arg2->expr)
4395     {
4396       /* No optional target.  */
4397       if (ss1 == gfc_ss_terminator)
4398         {
4399           /* A pointer to a scalar.  */
4400           arg1se.want_pointer = 1;
4401           gfc_conv_expr (&arg1se, arg1->expr);
4402           tmp2 = arg1se.expr;
4403         }
4404       else
4405         {
4406           /* A pointer to an array.  */
4407           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4408           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4409         }
4410       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4411       gfc_add_block_to_block (&se->post, &arg1se.post);
4412       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4413                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4414       se->expr = tmp;
4415     }
4416   else
4417     {
4418       /* An optional target.  */
4419       ss2 = gfc_walk_expr (arg2->expr);
4420
4421       nonzero_charlen = NULL_TREE;
4422       if (arg1->expr->ts.type == BT_CHARACTER)
4423         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4424                                        arg1->expr->ts.u.cl->backend_decl,
4425                                        integer_zero_node);
4426
4427       if (ss1 == gfc_ss_terminator)
4428         {
4429           /* A pointer to a scalar.  */
4430           gcc_assert (ss2 == gfc_ss_terminator);
4431           arg1se.want_pointer = 1;
4432           gfc_conv_expr (&arg1se, arg1->expr);
4433           arg2se.want_pointer = 1;
4434           gfc_conv_expr (&arg2se, arg2->expr);
4435           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4436           gfc_add_block_to_block (&se->post, &arg1se.post);
4437           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4438                              arg1se.expr, arg2se.expr);
4439           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4440                               arg1se.expr, null_pointer_node);
4441           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4442                                   tmp, tmp2);
4443         }
4444       else
4445         {
4446           /* An array pointer of zero length is not associated if target is
4447              present.  */
4448           arg1se.descriptor_only = 1;
4449           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4450           tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4451                                             gfc_rank_cst[arg1->expr->rank - 1]);
4452           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4453                                           build_int_cst (TREE_TYPE (tmp), 0));
4454
4455           /* A pointer to an array, call library function _gfor_associated.  */
4456           gcc_assert (ss2 != gfc_ss_terminator);
4457           arg1se.want_pointer = 1;
4458           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4459
4460           arg2se.want_pointer = 1;
4461           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4462           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4463           gfc_add_block_to_block (&se->post, &arg2se.post);
4464           se->expr = build_call_expr_loc (input_location,
4465                                       gfor_fndecl_associated, 2,
4466                                       arg1se.expr, arg2se.expr);
4467           se->expr = convert (boolean_type_node, se->expr);
4468           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4469                                   se->expr, nonzero_arraylen);
4470         }
4471
4472       /* If target is present zero character length pointers cannot
4473          be associated.  */
4474       if (nonzero_charlen != NULL_TREE)
4475         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4476                                 se->expr, nonzero_charlen);
4477     }
4478
4479   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4480 }
4481
4482
4483 /* Generate code for the SAME_TYPE_AS intrinsic.
4484    Generate inline code that directly checks the vindices.  */
4485
4486 static void
4487 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4488 {
4489   gfc_expr *a, *b;
4490   gfc_se se1, se2;
4491   tree tmp;
4492
4493   gfc_init_se (&se1, NULL);
4494   gfc_init_se (&se2, NULL);
4495
4496   a = expr->value.function.actual->expr;
4497   b = expr->value.function.actual->next->expr;
4498
4499   if (a->ts.type == BT_CLASS)
4500     {
4501       gfc_add_component_ref (a, "$vptr");
4502       gfc_add_component_ref (a, "$hash");
4503     }
4504   else if (a->ts.type == BT_DERIVED)
4505     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4506                           a->ts.u.derived->hash_value);
4507
4508   if (b->ts.type == BT_CLASS)
4509     {
4510       gfc_add_component_ref (b, "$vptr");
4511       gfc_add_component_ref (b, "$hash");
4512     }
4513   else if (b->ts.type == BT_DERIVED)
4514     b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4515                           b->ts.u.derived->hash_value);
4516
4517   gfc_conv_expr (&se1, a);
4518   gfc_conv_expr (&se2, b);
4519
4520   tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4521                      se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4522   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4523 }
4524
4525
4526 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4527
4528 static void
4529 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4530 {
4531   tree args[2];
4532
4533   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4534   se->expr = build_call_expr_loc (input_location,
4535                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
4536   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4537 }
4538
4539
4540 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4541
4542 static void
4543 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4544 {
4545   tree arg, type;
4546
4547   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4548
4549   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4550   type = gfc_get_int_type (4);
4551   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4552
4553   /* Convert it to the required type.  */
4554   type = gfc_typenode_for_spec (&expr->ts);
4555   se->expr = build_call_expr_loc (input_location,
4556                               gfor_fndecl_si_kind, 1, arg);
4557   se->expr = fold_convert (type, se->expr);
4558 }
4559
4560
4561 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4562
4563 static void
4564 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4565 {
4566   gfc_actual_arglist *actual;
4567   tree args, type;
4568   gfc_se argse;
4569
4570   args = NULL_TREE;
4571   for (actual = expr->value.function.actual; actual; actual = actual->next)
4572     {
4573       gfc_init_se (&argse, se);
4574
4575       /* Pass a NULL pointer for an absent arg.  */
4576       if (actual->expr == NULL)
4577         argse.expr = null_pointer_node;
4578       else
4579         {
4580           gfc_typespec ts;
4581           gfc_clear_ts (&ts);
4582
4583           if (actual->expr->ts.kind != gfc_c_int_kind)
4584             {
4585               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4586               ts.type = BT_INTEGER;
4587               ts.kind = gfc_c_int_kind;
4588               gfc_convert_type (actual->expr, &ts, 2);
4589             }
4590           gfc_conv_expr_reference (&argse, actual->expr);
4591         }
4592
4593       gfc_add_block_to_block (&se->pre, &argse.pre);
4594       gfc_add_block_to_block (&se->post, &argse.post);
4595       args = gfc_chainon_list (args, argse.expr);
4596     }
4597
4598   /* Convert it to the required type.  */
4599   type = gfc_typenode_for_spec (&expr->ts);
4600   se->expr = build_function_call_expr (input_location,
4601                                        gfor_fndecl_sr_kind, args);
4602   se->expr = fold_convert (type, se->expr);
4603 }
4604
4605
4606 /* Generate code for TRIM (A) intrinsic function.  */
4607
4608 static void
4609 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4610 {
4611   tree var;
4612   tree len;
4613   tree addr;
4614   tree tmp;
4615   tree cond;
4616   tree fndecl;
4617   tree function;
4618   tree *args;
4619   unsigned int num_args;
4620
4621   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4622   args = (tree *) alloca (sizeof (tree) * num_args);
4623
4624   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4625   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4626   len = gfc_create_var (gfc_charlen_type_node, "len");
4627
4628   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4629   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4630   args[1] = addr;
4631
4632   if (expr->ts.kind == 1)
4633     function = gfor_fndecl_string_trim;
4634   else if (expr->ts.kind == 4)
4635     function = gfor_fndecl_string_trim_char4;
4636   else
4637     gcc_unreachable ();
4638
4639   fndecl = build_addr (function, current_function_decl);
4640   tmp = build_call_array_loc (input_location,
4641                           TREE_TYPE (TREE_TYPE (function)), fndecl,
4642                           num_args, args);
4643   gfc_add_expr_to_block (&se->pre, tmp);
4644
4645   /* Free the temporary afterwards, if necessary.  */
4646   cond = fold_build2 (GT_EXPR, boolean_type_node,
4647                       len, build_int_cst (TREE_TYPE (len), 0));
4648   tmp = gfc_call_free (var);
4649   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4650   gfc_add_expr_to_block (&se->post, tmp);
4651
4652   se->expr = var;
4653   se->string_length = len;
4654 }
4655
4656
4657 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4658
4659 static void
4660 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4661 {
4662   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4663   tree type, cond, tmp, count, exit_label, n, max, largest;
4664   tree size;
4665   stmtblock_t block, body;
4666   int i;
4667
4668   /* We store in charsize the size of a character.  */
4669   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4670   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4671
4672   /* Get the arguments.  */
4673   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4674   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4675   src = args[1];
4676   ncopies = gfc_evaluate_now (args[2], &se->pre);
4677   ncopies_type = TREE_TYPE (ncopies);
4678
4679   /* Check that NCOPIES is not negative.  */
4680   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4681                       build_int_cst (ncopies_type, 0));
4682   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4683                            "Argument NCOPIES of REPEAT intrinsic is negative "
4684                            "(its value is %lld)",
4685                            fold_convert (long_integer_type_node, ncopies));
4686
4687   /* If the source length is zero, any non negative value of NCOPIES
4688      is valid, and nothing happens.  */
4689   n = gfc_create_var (ncopies_type, "ncopies");
4690   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4691                       build_int_cst (size_type_node, 0));
4692   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4693                      build_int_cst (ncopies_type, 0), ncopies);
4694   gfc_add_modify (&se->pre, n, tmp);
4695   ncopies = n;
4696
4697   /* Check that ncopies is not too large: ncopies should be less than
4698      (or equal to) MAX / slen, where MAX is the maximal integer of
4699      the gfc_charlen_type_node type.  If slen == 0, we need a special
4700      case to avoid the division by zero.  */
4701   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4702   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4703   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4704                      fold_convert (size_type_node, max), slen);
4705   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4706               ? size_type_node : ncopies_type;
4707   cond = fold_build2 (GT_EXPR, boolean_type_node,
4708                       fold_convert (largest, ncopies),
4709                       fold_convert (largest, max));
4710   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4711                      build_int_cst (size_type_node, 0));
4712   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4713                       cond);
4714   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4715                            "Argument NCOPIES of REPEAT intrinsic is too large");
4716
4717   /* Compute the destination length.  */
4718   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4719                       fold_convert (gfc_charlen_type_node, slen),
4720                       fold_convert (gfc_charlen_type_node, ncopies));
4721   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4722   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4723
4724   /* Generate the code to do the repeat operation:
4725        for (i = 0; i < ncopies; i++)
4726          memmove (dest + (i * slen * size), src, slen*size);  */
4727   gfc_start_block (&block);
4728   count = gfc_create_var (ncopies_type, "count");
4729   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4730   exit_label = gfc_build_label_decl (NULL_TREE);
4731
4732   /* Start the loop body.  */
4733   gfc_start_block (&body);
4734
4735   /* Exit the loop if count >= ncopies.  */
4736   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4737   tmp = build1_v (GOTO_EXPR, exit_label);
4738   TREE_USED (exit_label) = 1;
4739   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4740                      build_empty_stmt (input_location));
4741   gfc_add_expr_to_block (&body, tmp);
4742
4743   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4744   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4745                      fold_convert (gfc_charlen_type_node, slen),
4746                      fold_convert (gfc_charlen_type_node, count));
4747   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4748                      tmp, fold_convert (gfc_charlen_type_node, size));
4749   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4750                      fold_convert (pvoid_type_node, dest),
4751                      fold_convert (sizetype, tmp));
4752   tmp = build_call_expr_loc (input_location,
4753                          built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4754                          fold_build2 (MULT_EXPR, size_type_node, slen,
4755                                       fold_convert (size_type_node, size)));
4756   gfc_add_expr_to_block (&body, tmp);
4757
4758   /* Increment count.  */
4759   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4760                      count, build_int_cst (TREE_TYPE (count), 1));
4761   gfc_add_modify (&body, count, tmp);
4762
4763   /* Build the loop.  */
4764   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4765   gfc_add_expr_to_block (&block, tmp);
4766
4767   /* Add the exit label.  */
4768   tmp = build1_v (LABEL_EXPR, exit_label);
4769   gfc_add_expr_to_block (&block, tmp);
4770
4771   /* Finish the block.  */
4772   tmp = gfc_finish_block (&block);
4773   gfc_add_expr_to_block (&se->pre, tmp);
4774
4775   /* Set the result value.  */
4776   se->expr = dest;
4777   se->string_length = dlen;
4778 }
4779
4780
4781 /* Generate code for the IARGC intrinsic.  */
4782
4783 static void
4784 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4785 {
4786   tree tmp;
4787   tree fndecl;
4788   tree type;
4789
4790   /* Call the library function.  This always returns an INTEGER(4).  */
4791   fndecl = gfor_fndecl_iargc;
4792   tmp = build_call_expr_loc (input_location,
4793                          fndecl, 0);
4794
4795   /* Convert it to the required type.  */
4796   type = gfc_typenode_for_spec (&expr->ts);
4797   tmp = fold_convert (type, tmp);
4798
4799   se->expr = tmp;
4800 }
4801
4802
4803 /* The loc intrinsic returns the address of its argument as
4804    gfc_index_integer_kind integer.  */
4805
4806 static void
4807 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4808 {
4809   tree temp_var;
4810   gfc_expr *arg_expr;
4811   gfc_ss *ss;
4812
4813   gcc_assert (!se->ss);
4814
4815   arg_expr = expr->value.function.actual->expr;
4816   ss = gfc_walk_expr (arg_expr);
4817   if (ss == gfc_ss_terminator)
4818     gfc_conv_expr_reference (se, arg_expr);
4819   else
4820     gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
4821   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4822
4823   /* Create a temporary variable for loc return value.  Without this,
4824      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4825   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4826   gfc_add_modify (&se->pre, temp_var, se->expr);
4827   se->expr = temp_var;
4828 }
4829
4830 /* Generate code for an intrinsic function.  Some map directly to library
4831    calls, others get special handling.  In some cases the name of the function
4832    used depends on the type specifiers.  */
4833
4834 void
4835 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4836 {
4837   const char *name;
4838   int lib, kind;
4839   tree fndecl;
4840
4841   name = &expr->value.function.name[2];
4842
4843   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4844     {
4845       lib = gfc_is_intrinsic_libcall (expr);
4846       if (lib != 0)
4847         {
4848           if (lib == 1)
4849             se->ignore_optional = 1;
4850
4851           switch (expr->value.function.isym->id)
4852             {
4853             case GFC_ISYM_EOSHIFT:
4854             case GFC_ISYM_PACK:
4855             case GFC_ISYM_RESHAPE:
4856               /* For all of those the first argument specifies the type and the
4857                  third is optional.  */
4858               conv_generic_with_optional_char_arg (se, expr, 1, 3);
4859               break;
4860
4861             default:
4862               gfc_conv_intrinsic_funcall (se, expr);
4863               break;
4864             }
4865
4866           return;
4867         }
4868     }
4869
4870   switch (expr->value.function.isym->id)
4871     {
4872     case GFC_ISYM_NONE:
4873       gcc_unreachable ();
4874
4875     case GFC_ISYM_REPEAT:
4876       gfc_conv_intrinsic_repeat (se, expr);
4877       break;
4878
4879     case GFC_ISYM_TRIM:
4880       gfc_conv_intrinsic_trim (se, expr);
4881       break;
4882
4883     case GFC_ISYM_SC_KIND:
4884       gfc_conv_intrinsic_sc_kind (se, expr);
4885       break;
4886
4887     case GFC_ISYM_SI_KIND:
4888       gfc_conv_intrinsic_si_kind (se, expr);
4889       break;
4890
4891     case GFC_ISYM_SR_KIND:
4892       gfc_conv_intrinsic_sr_kind (se, expr);
4893       break;
4894
4895     case GFC_ISYM_EXPONENT:
4896       gfc_conv_intrinsic_exponent (se, expr);
4897       break;
4898
4899     case GFC_ISYM_SCAN:
4900       kind = expr->value.function.actual->expr->ts.kind;
4901       if (kind == 1)
4902        fndecl = gfor_fndecl_string_scan;
4903       else if (kind == 4)
4904        fndecl = gfor_fndecl_string_scan_char4;
4905       else
4906        gcc_unreachable ();
4907
4908       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4909       break;
4910
4911     case GFC_ISYM_VERIFY:
4912       kind = expr->value.function.actual->expr->ts.kind;
4913       if (kind == 1)
4914        fndecl = gfor_fndecl_string_verify;
4915       else if (kind == 4)
4916        fndecl = gfor_fndecl_string_verify_char4;
4917       else
4918        gcc_unreachable ();
4919
4920       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4921       break;
4922
4923     case GFC_ISYM_ALLOCATED:
4924       gfc_conv_allocated (se, expr);
4925       break;
4926
4927     case GFC_ISYM_ASSOCIATED:
4928       gfc_conv_associated(se, expr);
4929       break;
4930
4931     case GFC_ISYM_SAME_TYPE_AS:
4932       gfc_conv_same_type_as (se, expr);
4933       break;
4934
4935     case GFC_ISYM_ABS:
4936       gfc_conv_intrinsic_abs (se, expr);
4937       break;
4938
4939     case GFC_ISYM_ADJUSTL:
4940       if (expr->ts.kind == 1)
4941        fndecl = gfor_fndecl_adjustl;
4942       else if (expr->ts.kind == 4)
4943        fndecl = gfor_fndecl_adjustl_char4;
4944       else
4945        gcc_unreachable ();
4946
4947       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4948       break;
4949
4950     case GFC_ISYM_ADJUSTR:
4951       if (expr->ts.kind == 1)
4952        fndecl = gfor_fndecl_adjustr;
4953       else if (expr->ts.kind == 4)
4954        fndecl = gfor_fndecl_adjustr_char4;
4955       else
4956        gcc_unreachable ();
4957
4958       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4959       break;
4960
4961     case GFC_ISYM_AIMAG:
4962       gfc_conv_intrinsic_imagpart (se, expr);
4963       break;
4964
4965     case GFC_ISYM_AINT:
4966       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4967       break;
4968
4969     case GFC_ISYM_ALL:
4970       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4971       break;
4972
4973     case GFC_ISYM_ANINT:
4974       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4975       break;
4976
4977     case GFC_ISYM_AND:
4978       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4979       break;
4980
4981     case GFC_ISYM_ANY:
4982       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4983       break;
4984
4985     case GFC_ISYM_BTEST:
4986       gfc_conv_intrinsic_btest (se, expr);
4987       break;
4988
4989     case GFC_ISYM_ACHAR:
4990     case GFC_ISYM_CHAR:
4991       gfc_conv_intrinsic_char (se, expr);
4992       break;
4993
4994     case GFC_ISYM_CONVERSION:
4995     case GFC_ISYM_REAL:
4996     case GFC_ISYM_LOGICAL:
4997     case GFC_ISYM_DBLE:
4998       gfc_conv_intrinsic_conversion (se, expr);
4999       break;
5000
5001       /* Integer conversions are handled separately to make sure we get the
5002          correct rounding mode.  */
5003     case GFC_ISYM_INT:
5004     case GFC_ISYM_INT2:
5005     case GFC_ISYM_INT8:
5006     case GFC_ISYM_LONG:
5007       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5008       break;
5009
5010     case GFC_ISYM_NINT:
5011       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5012       break;
5013
5014     case GFC_ISYM_CEILING:
5015       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5016       break;
5017
5018     case GFC_ISYM_FLOOR:
5019       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5020       break;
5021
5022     case GFC_ISYM_MOD:
5023       gfc_conv_intrinsic_mod (se, expr, 0);
5024       break;
5025
5026     case GFC_ISYM_MODULO:
5027       gfc_conv_intrinsic_mod (se, expr, 1);
5028       break;
5029
5030     case GFC_ISYM_CMPLX:
5031       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5032       break;
5033
5034     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5035       gfc_conv_intrinsic_iargc (se, expr);
5036       break;
5037
5038     case GFC_ISYM_COMPLEX:
5039       gfc_conv_intrinsic_cmplx (se, expr, 1);
5040       break;
5041
5042     case GFC_ISYM_CONJG:
5043       gfc_conv_intrinsic_conjg (se, expr);
5044       break;
5045
5046     case GFC_ISYM_COUNT:
5047       gfc_conv_intrinsic_count (se, expr);
5048       break;
5049
5050     case GFC_ISYM_CTIME:
5051       gfc_conv_intrinsic_ctime (se, expr);
5052       break;
5053
5054     case GFC_ISYM_DIM:
5055       gfc_conv_intrinsic_dim (se, expr);
5056       break;
5057
5058     case GFC_ISYM_DOT_PRODUCT:
5059       gfc_conv_intrinsic_dot_product (se, expr);
5060       break;
5061
5062     case GFC_ISYM_DPROD:
5063       gfc_conv_intrinsic_dprod (se, expr);
5064       break;
5065
5066     case GFC_ISYM_FDATE:
5067       gfc_conv_intrinsic_fdate (se, expr);
5068       break;
5069
5070     case GFC_ISYM_FRACTION:
5071       gfc_conv_intrinsic_fraction (se, expr);
5072       break;
5073
5074     case GFC_ISYM_IAND:
5075       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5076       break;
5077
5078     case GFC_ISYM_IBCLR:
5079       gfc_conv_intrinsic_singlebitop (se, expr, 0);
5080       break;
5081
5082     case GFC_ISYM_IBITS:
5083       gfc_conv_intrinsic_ibits (se, expr);
5084       break;
5085
5086     case GFC_ISYM_IBSET:
5087       gfc_conv_intrinsic_singlebitop (se, expr, 1);
5088       break;
5089
5090     case GFC_ISYM_IACHAR:
5091     case GFC_ISYM_ICHAR:
5092       /* We assume ASCII character sequence.  */
5093       gfc_conv_intrinsic_ichar (se, expr);
5094       break;
5095
5096     case GFC_ISYM_IARGC:
5097       gfc_conv_intrinsic_iargc (se, expr);
5098       break;
5099
5100     case GFC_ISYM_IEOR:
5101       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5102       break;
5103
5104     case GFC_ISYM_INDEX:
5105       kind = expr->value.function.actual->expr->ts.kind;
5106       if (kind == 1)
5107        fndecl = gfor_fndecl_string_index;
5108       else if (kind == 4)
5109        fndecl = gfor_fndecl_string_index_char4;
5110       else
5111        gcc_unreachable ();
5112
5113       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5114       break;
5115
5116     case GFC_ISYM_IOR:
5117       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5118       break;
5119
5120     case GFC_ISYM_IS_IOSTAT_END:
5121       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5122       break;
5123
5124     case GFC_ISYM_IS_IOSTAT_EOR:
5125       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5126       break;
5127
5128     case GFC_ISYM_ISNAN:
5129       gfc_conv_intrinsic_isnan (se, expr);
5130       break;
5131
5132     case GFC_ISYM_LSHIFT:
5133       gfc_conv_intrinsic_rlshift (se, expr, 0);
5134       break;
5135
5136     case GFC_ISYM_RSHIFT:
5137       gfc_conv_intrinsic_rlshift (se, expr, 1);
5138       break;
5139
5140     case GFC_ISYM_ISHFT:
5141       gfc_conv_intrinsic_ishft (se, expr);
5142       break;
5143
5144     case GFC_ISYM_ISHFTC:
5145       gfc_conv_intrinsic_ishftc (se, expr);
5146       break;
5147
5148     case GFC_ISYM_LEADZ:
5149       gfc_conv_intrinsic_leadz (se, expr);
5150       break;
5151
5152     case GFC_ISYM_TRAILZ:
5153       gfc_conv_intrinsic_trailz (se, expr);
5154       break;
5155
5156     case GFC_ISYM_LBOUND:
5157       gfc_conv_intrinsic_bound (se, expr, 0);
5158       break;
5159
5160     case GFC_ISYM_TRANSPOSE:
5161       if (se->ss && se->ss->useflags)
5162         {
5163           gfc_conv_tmp_array_ref (se);
5164           gfc_advance_se_ss_chain (se);
5165         }
5166       else
5167         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5168       break;
5169
5170     case GFC_ISYM_LEN:
5171       gfc_conv_intrinsic_len (se, expr);
5172       break;
5173
5174     case GFC_ISYM_LEN_TRIM:
5175       gfc_conv_intrinsic_len_trim (se, expr);
5176       break;
5177
5178     case GFC_ISYM_LGE:
5179       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5180       break;
5181
5182     case GFC_ISYM_LGT:
5183       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5184       break;
5185
5186     case GFC_ISYM_LLE:
5187       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5188       break;
5189
5190     case GFC_ISYM_LLT:
5191       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5192       break;
5193
5194     case GFC_ISYM_MAX:
5195       if (expr->ts.type == BT_CHARACTER)
5196         gfc_conv_intrinsic_minmax_char (se, expr, 1);
5197       else
5198         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5199       break;
5200
5201     case GFC_ISYM_MAXLOC:
5202       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5203       break;
5204
5205     case GFC_ISYM_MAXVAL:
5206       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5207       break;
5208
5209     case GFC_ISYM_MERGE:
5210       gfc_conv_intrinsic_merge (se, expr);
5211       break;
5212
5213     case GFC_ISYM_MIN:
5214       if (expr->ts.type == BT_CHARACTER)
5215         gfc_conv_intrinsic_minmax_char (se, expr, -1);
5216       else
5217         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5218       break;
5219
5220     case GFC_ISYM_MINLOC:
5221       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5222       break;
5223
5224     case GFC_ISYM_MINVAL:
5225       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5226       break;
5227
5228     case GFC_ISYM_NEAREST:
5229       gfc_conv_intrinsic_nearest (se, expr);
5230       break;
5231
5232     case GFC_ISYM_NOT:
5233       gfc_conv_intrinsic_not (se, expr);
5234       break;
5235
5236     case GFC_ISYM_OR:
5237       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5238       break;
5239
5240     case GFC_ISYM_PRESENT:
5241       gfc_conv_intrinsic_present (se, expr);
5242       break;
5243
5244     case GFC_ISYM_PRODUCT:
5245       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5246       break;
5247
5248     case GFC_ISYM_RRSPACING:
5249       gfc_conv_intrinsic_rrspacing (se, expr);
5250       break;
5251
5252     case GFC_ISYM_SET_EXPONENT:
5253       gfc_conv_intrinsic_set_exponent (se, expr);
5254       break;
5255
5256     case GFC_ISYM_SCALE:
5257       gfc_conv_intrinsic_scale (se, expr);
5258       break;
5259
5260     case GFC_ISYM_SIGN:
5261       gfc_conv_intrinsic_sign (se, expr);
5262       break;
5263
5264     case GFC_ISYM_SIZE:
5265       gfc_conv_intrinsic_size (se, expr);
5266       break;
5267
5268     case GFC_ISYM_SIZEOF:
5269       gfc_conv_intrinsic_sizeof (se, expr);
5270       break;
5271
5272     case GFC_ISYM_SPACING:
5273       gfc_conv_intrinsic_spacing (se, expr);
5274       break;
5275
5276     case GFC_ISYM_SUM:
5277       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5278       break;
5279
5280     case GFC_ISYM_TRANSFER:
5281       if (se->ss && se->ss->useflags)
5282         {
5283           /* Access the previously obtained result.  */
5284           gfc_conv_tmp_array_ref (se);
5285           gfc_advance_se_ss_chain (se);
5286         }
5287       else
5288         gfc_conv_intrinsic_transfer (se, expr);
5289       break;
5290
5291     case GFC_ISYM_TTYNAM:
5292       gfc_conv_intrinsic_ttynam (se, expr);
5293       break;
5294
5295     case GFC_ISYM_UBOUND:
5296       gfc_conv_intrinsic_bound (se, expr, 1);
5297       break;
5298
5299     case GFC_ISYM_XOR:
5300       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5301       break;
5302
5303     case GFC_ISYM_LOC:
5304       gfc_conv_intrinsic_loc (se, expr);
5305       break;
5306
5307     case GFC_ISYM_ACCESS:
5308     case GFC_ISYM_CHDIR:
5309     case GFC_ISYM_CHMOD:
5310     case GFC_ISYM_DTIME:
5311     case GFC_ISYM_ETIME:
5312     case GFC_ISYM_EXTENDS_TYPE_OF:
5313     case GFC_ISYM_FGET:
5314     case GFC_ISYM_FGETC:
5315     case GFC_ISYM_FNUM:
5316     case GFC_ISYM_FPUT:
5317     case GFC_ISYM_FPUTC:
5318     case GFC_ISYM_FSTAT:
5319     case GFC_ISYM_FTELL:
5320     case GFC_ISYM_GETCWD:
5321     case GFC_ISYM_GETGID:
5322     case GFC_ISYM_GETPID:
5323     case GFC_ISYM_GETUID:
5324     case GFC_ISYM_HOSTNM:
5325     case GFC_ISYM_KILL:
5326     case GFC_ISYM_IERRNO:
5327     case GFC_ISYM_IRAND:
5328     case GFC_ISYM_ISATTY:
5329     case GFC_ISYM_LINK:
5330     case GFC_ISYM_LSTAT:
5331     case GFC_ISYM_MALLOC:
5332     case GFC_ISYM_MATMUL:
5333     case GFC_ISYM_MCLOCK:
5334     case GFC_ISYM_MCLOCK8:
5335     case GFC_ISYM_RAND:
5336     case GFC_ISYM_RENAME:
5337     case GFC_ISYM_SECOND:
5338     case GFC_ISYM_SECNDS:
5339     case GFC_ISYM_SIGNAL:
5340     case GFC_ISYM_STAT:
5341     case GFC_ISYM_SYMLNK:
5342     case GFC_ISYM_SYSTEM:
5343     case GFC_ISYM_TIME:
5344     case GFC_ISYM_TIME8:
5345     case GFC_ISYM_UMASK:
5346     case GFC_ISYM_UNLINK:
5347       gfc_conv_intrinsic_funcall (se, expr);
5348       break;
5349
5350     case GFC_ISYM_EOSHIFT:
5351     case GFC_ISYM_PACK:
5352     case GFC_ISYM_RESHAPE:
5353       /* For those, expr->rank should always be >0 and thus the if above the
5354          switch should have matched.  */
5355       gcc_unreachable ();
5356       break;
5357
5358     default:
5359       gfc_conv_intrinsic_lib_function (se, expr);
5360       break;
5361     }
5362 }
5363
5364
5365 /* This generates code to execute before entering the scalarization loop.
5366    Currently does nothing.  */
5367
5368 void
5369 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5370 {
5371   switch (ss->expr->value.function.isym->id)
5372     {
5373     case GFC_ISYM_UBOUND:
5374     case GFC_ISYM_LBOUND:
5375       break;
5376
5377     default:
5378       gcc_unreachable ();
5379     }
5380 }
5381
5382
5383 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5384    inside the scalarization loop.  */
5385
5386 static gfc_ss *
5387 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5388 {
5389   gfc_ss *newss;
5390
5391   /* The two argument version returns a scalar.  */
5392   if (expr->value.function.actual->next->expr)
5393     return ss;
5394
5395   newss = gfc_get_ss ();
5396   newss->type = GFC_SS_INTRINSIC;
5397   newss->expr = expr;
5398   newss->next = ss;
5399   newss->data.info.dimen = 1;
5400
5401   return newss;
5402 }
5403
5404
5405 /* Walk an intrinsic array libcall.  */
5406
5407 static gfc_ss *
5408 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5409 {
5410   gfc_ss *newss;
5411
5412   gcc_assert (expr->rank > 0);
5413
5414   newss = gfc_get_ss ();
5415   newss->type = GFC_SS_FUNCTION;
5416   newss->expr = expr;
5417   newss->next = ss;
5418   newss->data.info.dimen = expr->rank;
5419
5420   return newss;
5421 }
5422
5423
5424 /* Returns nonzero if the specified intrinsic function call maps directly to
5425    an external library call.  Should only be used for functions that return
5426    arrays.  */
5427
5428 int
5429 gfc_is_intrinsic_libcall (gfc_expr * expr)
5430 {
5431   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5432   gcc_assert (expr->rank > 0);
5433
5434   switch (expr->value.function.isym->id)
5435     {
5436     case GFC_ISYM_ALL:
5437     case GFC_ISYM_ANY:
5438     case GFC_ISYM_COUNT:
5439     case GFC_ISYM_MATMUL:
5440     case GFC_ISYM_MAXLOC:
5441     case GFC_ISYM_MAXVAL:
5442     case GFC_ISYM_MINLOC:
5443     case GFC_ISYM_MINVAL:
5444     case GFC_ISYM_PRODUCT:
5445     case GFC_ISYM_SUM:
5446     case GFC_ISYM_SHAPE:
5447     case GFC_ISYM_SPREAD:
5448     case GFC_ISYM_TRANSPOSE:
5449       /* Ignore absent optional parameters.  */
5450       return 1;
5451
5452     case GFC_ISYM_RESHAPE:
5453     case GFC_ISYM_CSHIFT:
5454     case GFC_ISYM_EOSHIFT:
5455     case GFC_ISYM_PACK:
5456     case GFC_ISYM_UNPACK:
5457       /* Pass absent optional parameters.  */
5458       return 2;
5459
5460     default:
5461       return 0;
5462     }
5463 }
5464
5465 /* Walk an intrinsic function.  */
5466 gfc_ss *
5467 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5468                              gfc_intrinsic_sym * isym)
5469 {
5470   gcc_assert (isym);
5471
5472   if (isym->elemental)
5473     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5474
5475   if (expr->rank == 0)
5476     return ss;
5477
5478   if (gfc_is_intrinsic_libcall (expr))
5479     return gfc_walk_intrinsic_libfunc (ss, expr);
5480
5481   /* Special cases.  */
5482   switch (isym->id)
5483     {
5484     case GFC_ISYM_LBOUND:
5485     case GFC_ISYM_UBOUND:
5486       return gfc_walk_intrinsic_bound (ss, expr);
5487
5488     case GFC_ISYM_TRANSFER:
5489       return gfc_walk_intrinsic_libfunc (ss, expr);
5490
5491     default:
5492       /* This probably meant someone forgot to add an intrinsic to the above
5493          list(s) when they implemented it, or something's gone horribly
5494          wrong.  */
5495       gcc_unreachable ();
5496     }
5497 }
5498
5499 #include "gt-fortran-trans-intrinsic.h"