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