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       gfc_conv_expr_reference (&argse, arg);
3889
3890       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
3891                                                  argse.expr));
3892
3893       /* Obtain the source word length.  */
3894       if (arg->ts.type == BT_CHARACTER)
3895         se->expr = size_of_string_in_bytes (arg->ts.kind,
3896                                             argse.string_length);
3897       else
3898         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3899     }
3900   else
3901     {
3902       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3903       argse.want_pointer = 0;
3904       gfc_conv_expr_descriptor (&argse, arg, ss);
3905       type = gfc_get_element_type (TREE_TYPE (argse.expr));
3906
3907       /* Obtain the argument's word length.  */
3908       if (arg->ts.type == BT_CHARACTER)
3909         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3910       else
3911         tmp = fold_convert (gfc_array_index_type,
3912                             size_in_bytes (type));
3913       gfc_add_modify (&argse.pre, source_bytes, tmp);
3914
3915       /* Obtain the size of the array in bytes.  */
3916       for (n = 0; n < arg->rank; n++)
3917         {
3918           tree idx;
3919           idx = gfc_rank_cst[n];
3920           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
3921           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
3922           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3923                              upper, lower);
3924           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3925                              tmp, gfc_index_one_node);
3926           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3927                              tmp, source_bytes);
3928           gfc_add_modify (&argse.pre, source_bytes, tmp);
3929         }
3930       se->expr = source_bytes;
3931     }
3932
3933   gfc_add_block_to_block (&se->pre, &argse.pre);
3934 }
3935
3936
3937 /* Intrinsic string comparison functions.  */
3938
3939 static void
3940 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3941 {
3942   tree args[4];
3943
3944   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3945
3946   se->expr
3947     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3948                                 expr->value.function.actual->expr->ts.kind);
3949   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3950                           build_int_cst (TREE_TYPE (se->expr), 0));
3951 }
3952
3953 /* Generate a call to the adjustl/adjustr library function.  */
3954 static void
3955 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3956 {
3957   tree args[3];
3958   tree len;
3959   tree type;
3960   tree var;
3961   tree tmp;
3962
3963   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3964   len = args[1];
3965
3966   type = TREE_TYPE (args[2]);
3967   var = gfc_conv_string_tmp (se, type, len);
3968   args[0] = var;
3969
3970   tmp = build_call_expr_loc (input_location,
3971                          fndecl, 3, args[0], args[1], args[2]);
3972   gfc_add_expr_to_block (&se->pre, tmp);
3973   se->expr = var;
3974   se->string_length = len;
3975 }
3976
3977
3978 /* Generate code for the TRANSFER intrinsic:
3979         For scalar results:
3980           DEST = TRANSFER (SOURCE, MOLD)
3981         where:
3982           typeof<DEST> = typeof<MOLD>
3983         and:
3984           MOLD is scalar.
3985
3986         For array results:
3987           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3988         where:
3989           typeof<DEST> = typeof<MOLD>
3990         and:
3991           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3992               sizeof (DEST(0) * SIZE).  */
3993 static void
3994 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3995 {
3996   tree tmp;
3997   tree tmpdecl;
3998   tree ptr;
3999   tree extent;
4000   tree source;
4001   tree source_type;
4002   tree source_bytes;
4003   tree mold_type;
4004   tree dest_word_len;
4005   tree size_words;
4006   tree size_bytes;
4007   tree upper;
4008   tree lower;
4009   tree stmt;
4010   gfc_actual_arglist *arg;
4011   gfc_se argse;
4012   gfc_ss *ss;
4013   gfc_ss_info *info;
4014   stmtblock_t block;
4015   int n;
4016   bool scalar_mold;
4017
4018   info = NULL;
4019   if (se->loop)
4020     info = &se->ss->data.info;
4021
4022   /* Convert SOURCE.  The output from this stage is:-
4023         source_bytes = length of the source in bytes
4024         source = pointer to the source data.  */
4025   arg = expr->value.function.actual;
4026
4027   /* Ensure double transfer through LOGICAL preserves all
4028      the needed bits.  */
4029   if (arg->expr->expr_type == EXPR_FUNCTION
4030         && arg->expr->value.function.esym == NULL
4031         && arg->expr->value.function.isym != NULL
4032         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4033         && arg->expr->ts.type == BT_LOGICAL
4034         && expr->ts.type != arg->expr->ts.type)
4035     arg->expr->value.function.name = "__transfer_in_transfer";
4036
4037   gfc_init_se (&argse, NULL);
4038   ss = gfc_walk_expr (arg->expr);
4039
4040   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4041
4042   /* Obtain the pointer to source and the length of source in bytes.  */
4043   if (ss == gfc_ss_terminator)
4044     {
4045       gfc_conv_expr_reference (&argse, arg->expr);
4046       source = argse.expr;
4047
4048       source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4049                                                         argse.expr));
4050
4051       /* Obtain the source word length.  */
4052       if (arg->expr->ts.type == BT_CHARACTER)
4053         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4054                                        argse.string_length);
4055       else
4056         tmp = fold_convert (gfc_array_index_type,
4057                             size_in_bytes (source_type));
4058     }
4059   else
4060     {
4061       argse.want_pointer = 0;
4062       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4063       source = gfc_conv_descriptor_data_get (argse.expr);
4064       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4065
4066       /* Repack the source if not a full variable array.  */
4067       if (arg->expr->expr_type == EXPR_VARIABLE
4068               && arg->expr->ref->u.ar.type != AR_FULL)
4069         {
4070           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4071
4072           if (gfc_option.warn_array_temp)
4073             gfc_warning ("Creating array temporary at %L", &expr->where);
4074
4075           source = build_call_expr_loc (input_location,
4076                                     gfor_fndecl_in_pack, 1, tmp);
4077           source = gfc_evaluate_now (source, &argse.pre);
4078
4079           /* Free the temporary.  */
4080           gfc_start_block (&block);
4081           tmp = gfc_call_free (convert (pvoid_type_node, source));
4082           gfc_add_expr_to_block (&block, tmp);
4083           stmt = gfc_finish_block (&block);
4084
4085           /* Clean up if it was repacked.  */
4086           gfc_init_block (&block);
4087           tmp = gfc_conv_array_data (argse.expr);
4088           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4089           tmp = build3_v (COND_EXPR, tmp, stmt,
4090                           build_empty_stmt (input_location));
4091           gfc_add_expr_to_block (&block, tmp);
4092           gfc_add_block_to_block (&block, &se->post);
4093           gfc_init_block (&se->post);
4094           gfc_add_block_to_block (&se->post, &block);
4095         }
4096
4097       /* Obtain the source word length.  */
4098       if (arg->expr->ts.type == BT_CHARACTER)
4099         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4100                                        argse.string_length);
4101       else
4102         tmp = fold_convert (gfc_array_index_type,
4103                             size_in_bytes (source_type));
4104
4105       /* Obtain the size of the array in bytes.  */
4106       extent = gfc_create_var (gfc_array_index_type, NULL);
4107       for (n = 0; n < arg->expr->rank; n++)
4108         {
4109           tree idx;
4110           idx = gfc_rank_cst[n];
4111           gfc_add_modify (&argse.pre, source_bytes, tmp);
4112           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4113           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4114           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4115                              upper, lower);
4116           gfc_add_modify (&argse.pre, extent, tmp);
4117           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4118                              extent, gfc_index_one_node);
4119           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4120                              tmp, source_bytes);
4121         }
4122     }
4123
4124   gfc_add_modify (&argse.pre, source_bytes, tmp);
4125   gfc_add_block_to_block (&se->pre, &argse.pre);
4126   gfc_add_block_to_block (&se->post, &argse.post);
4127
4128   /* Now convert MOLD.  The outputs are:
4129         mold_type = the TREE type of MOLD
4130         dest_word_len = destination word length in bytes.  */
4131   arg = arg->next;
4132
4133   gfc_init_se (&argse, NULL);
4134   ss = gfc_walk_expr (arg->expr);
4135
4136   scalar_mold = arg->expr->rank == 0;
4137
4138   if (ss == gfc_ss_terminator)
4139     {
4140       gfc_conv_expr_reference (&argse, arg->expr);
4141       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4142                                                       argse.expr));
4143     }
4144   else
4145     {
4146       gfc_init_se (&argse, NULL);
4147       argse.want_pointer = 0;
4148       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4149       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4150     }
4151
4152   gfc_add_block_to_block (&se->pre, &argse.pre);
4153   gfc_add_block_to_block (&se->post, &argse.post);
4154
4155   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4156     {
4157       /* If this TRANSFER is nested in another TRANSFER, use a type
4158          that preserves all bits.  */
4159       if (arg->expr->ts.type == BT_LOGICAL)
4160         mold_type = gfc_get_int_type (arg->expr->ts.kind);
4161     }
4162
4163   if (arg->expr->ts.type == BT_CHARACTER)
4164     {
4165       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4166       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4167     }
4168   else
4169     tmp = fold_convert (gfc_array_index_type,
4170                         size_in_bytes (mold_type));
4171
4172   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4173   gfc_add_modify (&se->pre, dest_word_len, tmp);
4174
4175   /* Finally convert SIZE, if it is present.  */
4176   arg = arg->next;
4177   size_words = gfc_create_var (gfc_array_index_type, NULL);
4178
4179   if (arg->expr)
4180     {
4181       gfc_init_se (&argse, NULL);
4182       gfc_conv_expr_reference (&argse, arg->expr);
4183       tmp = convert (gfc_array_index_type,
4184                      build_fold_indirect_ref_loc (input_location,
4185                                               argse.expr));
4186       gfc_add_block_to_block (&se->pre, &argse.pre);
4187       gfc_add_block_to_block (&se->post, &argse.post);
4188     }
4189   else
4190     tmp = NULL_TREE;
4191
4192   /* Separate array and scalar results.  */
4193   if (scalar_mold && tmp == NULL_TREE)
4194     goto scalar_transfer;
4195
4196   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4197   if (tmp != NULL_TREE)
4198     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4199                        tmp, dest_word_len);
4200   else
4201     tmp = source_bytes;
4202
4203   gfc_add_modify (&se->pre, size_bytes, tmp);
4204   gfc_add_modify (&se->pre, size_words,
4205                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4206                                     size_bytes, dest_word_len));
4207
4208   /* Evaluate the bounds of the result.  If the loop range exists, we have
4209      to check if it is too large.  If so, we modify loop->to be consistent
4210      with min(size, size(source)).  Otherwise, size is made consistent with
4211      the loop range, so that the right number of bytes is transferred.*/
4212   n = se->loop->order[0];
4213   if (se->loop->to[n] != NULL_TREE)
4214     {
4215       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4216                          se->loop->to[n], se->loop->from[n]);
4217       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4218                          tmp, gfc_index_one_node);
4219       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4220                          tmp, size_words);
4221       gfc_add_modify (&se->pre, size_words, tmp);
4222       gfc_add_modify (&se->pre, size_bytes,
4223                            fold_build2 (MULT_EXPR, gfc_array_index_type,
4224                                         size_words, dest_word_len));
4225       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4226                            size_words, se->loop->from[n]);
4227       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4228                            upper, gfc_index_one_node);
4229     }
4230   else
4231     {
4232       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4233                            size_words, gfc_index_one_node);
4234       se->loop->from[n] = gfc_index_zero_node;
4235     }
4236
4237   se->loop->to[n] = upper;
4238
4239   /* Build a destination descriptor, using the pointer, source, as the
4240      data field.  */
4241   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4242                                info, mold_type, NULL_TREE, false, true, false,
4243                                &expr->where);
4244
4245   /* Cast the pointer to the result.  */
4246   tmp = gfc_conv_descriptor_data_get (info->descriptor);
4247   tmp = fold_convert (pvoid_type_node, tmp);
4248
4249   /* Use memcpy to do the transfer.  */
4250   tmp = build_call_expr_loc (input_location,
4251                          built_in_decls[BUILT_IN_MEMCPY],
4252                          3,
4253                          tmp,
4254                          fold_convert (pvoid_type_node, source),
4255                          fold_build2 (MIN_EXPR, gfc_array_index_type,
4256                                       size_bytes, source_bytes));
4257   gfc_add_expr_to_block (&se->pre, tmp);
4258
4259   se->expr = info->descriptor;
4260   if (expr->ts.type == BT_CHARACTER)
4261     se->string_length = dest_word_len;
4262
4263   return;
4264
4265 /* Deal with scalar results.  */
4266 scalar_transfer:
4267   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4268                         dest_word_len, source_bytes);
4269   extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4270                         extent, gfc_index_zero_node);
4271
4272   if (expr->ts.type == BT_CHARACTER)
4273     {
4274       tree direct;
4275       tree indirect;
4276
4277       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4278       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4279                                 "transfer");
4280
4281       /* If source is longer than the destination, use a pointer to
4282          the source directly.  */
4283       gfc_init_block (&block);
4284       gfc_add_modify (&block, tmpdecl, ptr);
4285       direct = gfc_finish_block (&block);
4286
4287       /* Otherwise, allocate a string with the length of the destination
4288          and copy the source into it.  */
4289       gfc_init_block (&block);
4290       tmp = gfc_get_pchar_type (expr->ts.kind);
4291       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4292       gfc_add_modify (&block, tmpdecl,
4293                       fold_convert (TREE_TYPE (ptr), tmp));
4294       tmp = build_call_expr_loc (input_location,
4295                              built_in_decls[BUILT_IN_MEMCPY], 3,
4296                              fold_convert (pvoid_type_node, tmpdecl),
4297                              fold_convert (pvoid_type_node, ptr),
4298                              extent);
4299       gfc_add_expr_to_block (&block, tmp);
4300       indirect = gfc_finish_block (&block);
4301
4302       /* Wrap it up with the condition.  */
4303       tmp = fold_build2 (LE_EXPR, boolean_type_node,
4304                          dest_word_len, source_bytes);
4305       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4306       gfc_add_expr_to_block (&se->pre, tmp);
4307
4308       se->expr = tmpdecl;
4309       se->string_length = dest_word_len;
4310     }
4311   else
4312     {
4313       tmpdecl = gfc_create_var (mold_type, "transfer");
4314
4315       ptr = convert (build_pointer_type (mold_type), source);
4316
4317       /* Use memcpy to do the transfer.  */
4318       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4319       tmp = build_call_expr_loc (input_location,
4320                              built_in_decls[BUILT_IN_MEMCPY], 3,
4321                              fold_convert (pvoid_type_node, tmp),
4322                              fold_convert (pvoid_type_node, ptr),
4323                              extent);
4324       gfc_add_expr_to_block (&se->pre, tmp);
4325
4326       se->expr = tmpdecl;
4327     }
4328 }
4329
4330
4331 /* Generate code for the ALLOCATED intrinsic.
4332    Generate inline code that directly check the address of the argument.  */
4333
4334 static void
4335 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4336 {
4337   gfc_actual_arglist *arg1;
4338   gfc_se arg1se;
4339   gfc_ss *ss1;
4340   tree tmp;
4341
4342   gfc_init_se (&arg1se, NULL);
4343   arg1 = expr->value.function.actual;
4344   ss1 = gfc_walk_expr (arg1->expr);
4345
4346   if (ss1 == gfc_ss_terminator)
4347     {
4348       /* Allocatable scalar.  */
4349       arg1se.want_pointer = 1;
4350       if (arg1->expr->ts.type == BT_CLASS)
4351         gfc_add_component_ref (arg1->expr, "$data");
4352       gfc_conv_expr (&arg1se, arg1->expr);
4353       tmp = arg1se.expr;
4354     }
4355   else
4356     {
4357       /* Allocatable array.  */
4358       arg1se.descriptor_only = 1;
4359       gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4360       tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4361     }
4362
4363   tmp = fold_build2 (NE_EXPR, boolean_type_node,
4364                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4365   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4366 }
4367
4368
4369 /* Generate code for the ASSOCIATED intrinsic.
4370    If both POINTER and TARGET are arrays, generate a call to library function
4371    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4372    In other cases, generate inline code that directly compare the address of
4373    POINTER with the address of TARGET.  */
4374
4375 static void
4376 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4377 {
4378   gfc_actual_arglist *arg1;
4379   gfc_actual_arglist *arg2;
4380   gfc_se arg1se;
4381   gfc_se arg2se;
4382   tree tmp2;
4383   tree tmp;
4384   tree nonzero_charlen;
4385   tree nonzero_arraylen;
4386   gfc_ss *ss1, *ss2;
4387
4388   gfc_init_se (&arg1se, NULL);
4389   gfc_init_se (&arg2se, NULL);
4390   arg1 = expr->value.function.actual;
4391   if (arg1->expr->ts.type == BT_CLASS)
4392     gfc_add_component_ref (arg1->expr, "$data");
4393   arg2 = arg1->next;
4394   ss1 = gfc_walk_expr (arg1->expr);
4395
4396   if (!arg2->expr)
4397     {
4398       /* No optional target.  */
4399       if (ss1 == gfc_ss_terminator)
4400         {
4401           /* A pointer to a scalar.  */
4402           arg1se.want_pointer = 1;
4403           gfc_conv_expr (&arg1se, arg1->expr);
4404           tmp2 = arg1se.expr;
4405         }
4406       else
4407         {
4408           /* A pointer to an array.  */
4409           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4410           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4411         }
4412       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4413       gfc_add_block_to_block (&se->post, &arg1se.post);
4414       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4415                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4416       se->expr = tmp;
4417     }
4418   else
4419     {
4420       /* An optional target.  */
4421       if (arg2->expr->ts.type == BT_CLASS)
4422         gfc_add_component_ref (arg2->expr, "$data");
4423       ss2 = gfc_walk_expr (arg2->expr);
4424
4425       nonzero_charlen = NULL_TREE;
4426       if (arg1->expr->ts.type == BT_CHARACTER)
4427         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4428                                        arg1->expr->ts.u.cl->backend_decl,
4429                                        integer_zero_node);
4430
4431       if (ss1 == gfc_ss_terminator)
4432         {
4433           /* A pointer to a scalar.  */
4434           gcc_assert (ss2 == gfc_ss_terminator);
4435           arg1se.want_pointer = 1;
4436           gfc_conv_expr (&arg1se, arg1->expr);
4437           arg2se.want_pointer = 1;
4438           gfc_conv_expr (&arg2se, arg2->expr);
4439           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4440           gfc_add_block_to_block (&se->post, &arg1se.post);
4441           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4442                              arg1se.expr, arg2se.expr);
4443           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4444                               arg1se.expr, null_pointer_node);
4445           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4446                                   tmp, tmp2);
4447         }
4448       else
4449         {
4450           /* An array pointer of zero length is not associated if target is
4451              present.  */
4452           arg1se.descriptor_only = 1;
4453           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4454           tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4455                                             gfc_rank_cst[arg1->expr->rank - 1]);
4456           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4457                                           build_int_cst (TREE_TYPE (tmp), 0));
4458
4459           /* A pointer to an array, call library function _gfor_associated.  */
4460           gcc_assert (ss2 != gfc_ss_terminator);
4461           arg1se.want_pointer = 1;
4462           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4463
4464           arg2se.want_pointer = 1;
4465           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4466           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4467           gfc_add_block_to_block (&se->post, &arg2se.post);
4468           se->expr = build_call_expr_loc (input_location,
4469                                       gfor_fndecl_associated, 2,
4470                                       arg1se.expr, arg2se.expr);
4471           se->expr = convert (boolean_type_node, se->expr);
4472           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4473                                   se->expr, nonzero_arraylen);
4474         }
4475
4476       /* If target is present zero character length pointers cannot
4477          be associated.  */
4478       if (nonzero_charlen != NULL_TREE)
4479         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4480                                 se->expr, nonzero_charlen);
4481     }
4482
4483   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4484 }
4485
4486
4487 /* Generate code for the SAME_TYPE_AS intrinsic.
4488    Generate inline code that directly checks the vindices.  */
4489
4490 static void
4491 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4492 {
4493   gfc_expr *a, *b;
4494   gfc_se se1, se2;
4495   tree tmp;
4496
4497   gfc_init_se (&se1, NULL);
4498   gfc_init_se (&se2, NULL);
4499
4500   a = expr->value.function.actual->expr;
4501   b = expr->value.function.actual->next->expr;
4502
4503   if (a->ts.type == BT_CLASS)
4504     {
4505       gfc_add_component_ref (a, "$vptr");
4506       gfc_add_component_ref (a, "$hash");
4507     }
4508   else if (a->ts.type == BT_DERIVED)
4509     a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4510                           a->ts.u.derived->hash_value);
4511
4512   if (b->ts.type == BT_CLASS)
4513     {
4514       gfc_add_component_ref (b, "$vptr");
4515       gfc_add_component_ref (b, "$hash");
4516     }
4517   else if (b->ts.type == BT_DERIVED)
4518     b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
4519                           b->ts.u.derived->hash_value);
4520
4521   gfc_conv_expr (&se1, a);
4522   gfc_conv_expr (&se2, b);
4523
4524   tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4525                      se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4526   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4527 }
4528
4529
4530 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4531
4532 static void
4533 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4534 {
4535   tree args[2];
4536
4537   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4538   se->expr = build_call_expr_loc (input_location,
4539                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
4540   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4541 }
4542
4543
4544 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4545
4546 static void
4547 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4548 {
4549   tree arg, type;
4550
4551   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4552
4553   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4554   type = gfc_get_int_type (4);
4555   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4556
4557   /* Convert it to the required type.  */
4558   type = gfc_typenode_for_spec (&expr->ts);
4559   se->expr = build_call_expr_loc (input_location,
4560                               gfor_fndecl_si_kind, 1, arg);
4561   se->expr = fold_convert (type, se->expr);
4562 }
4563
4564
4565 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4566
4567 static void
4568 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4569 {
4570   gfc_actual_arglist *actual;
4571   tree args, type;
4572   gfc_se argse;
4573
4574   args = NULL_TREE;
4575   for (actual = expr->value.function.actual; actual; actual = actual->next)
4576     {
4577       gfc_init_se (&argse, se);
4578
4579       /* Pass a NULL pointer for an absent arg.  */
4580       if (actual->expr == NULL)
4581         argse.expr = null_pointer_node;
4582       else
4583         {
4584           gfc_typespec ts;
4585           gfc_clear_ts (&ts);
4586
4587           if (actual->expr->ts.kind != gfc_c_int_kind)
4588             {
4589               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4590               ts.type = BT_INTEGER;
4591               ts.kind = gfc_c_int_kind;
4592               gfc_convert_type (actual->expr, &ts, 2);
4593             }
4594           gfc_conv_expr_reference (&argse, actual->expr);
4595         }
4596
4597       gfc_add_block_to_block (&se->pre, &argse.pre);
4598       gfc_add_block_to_block (&se->post, &argse.post);
4599       args = gfc_chainon_list (args, argse.expr);
4600     }
4601
4602   /* Convert it to the required type.  */
4603   type = gfc_typenode_for_spec (&expr->ts);
4604   se->expr = build_function_call_expr (input_location,
4605                                        gfor_fndecl_sr_kind, args);
4606   se->expr = fold_convert (type, se->expr);
4607 }
4608
4609
4610 /* Generate code for TRIM (A) intrinsic function.  */
4611
4612 static void
4613 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4614 {
4615   tree var;
4616   tree len;
4617   tree addr;
4618   tree tmp;
4619   tree cond;
4620   tree fndecl;
4621   tree function;
4622   tree *args;
4623   unsigned int num_args;
4624
4625   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4626   args = (tree *) alloca (sizeof (tree) * num_args);
4627
4628   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4629   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4630   len = gfc_create_var (gfc_charlen_type_node, "len");
4631
4632   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4633   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4634   args[1] = addr;
4635
4636   if (expr->ts.kind == 1)
4637     function = gfor_fndecl_string_trim;
4638   else if (expr->ts.kind == 4)
4639     function = gfor_fndecl_string_trim_char4;
4640   else
4641     gcc_unreachable ();
4642
4643   fndecl = build_addr (function, current_function_decl);
4644   tmp = build_call_array_loc (input_location,
4645                           TREE_TYPE (TREE_TYPE (function)), fndecl,
4646                           num_args, args);
4647   gfc_add_expr_to_block (&se->pre, tmp);
4648
4649   /* Free the temporary afterwards, if necessary.  */
4650   cond = fold_build2 (GT_EXPR, boolean_type_node,
4651                       len, build_int_cst (TREE_TYPE (len), 0));
4652   tmp = gfc_call_free (var);
4653   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4654   gfc_add_expr_to_block (&se->post, tmp);
4655
4656   se->expr = var;
4657   se->string_length = len;
4658 }
4659
4660
4661 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4662
4663 static void
4664 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4665 {
4666   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4667   tree type, cond, tmp, count, exit_label, n, max, largest;
4668   tree size;
4669   stmtblock_t block, body;
4670   int i;
4671
4672   /* We store in charsize the size of a character.  */
4673   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4674   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4675
4676   /* Get the arguments.  */
4677   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4678   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4679   src = args[1];
4680   ncopies = gfc_evaluate_now (args[2], &se->pre);
4681   ncopies_type = TREE_TYPE (ncopies);
4682
4683   /* Check that NCOPIES is not negative.  */
4684   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4685                       build_int_cst (ncopies_type, 0));
4686   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4687                            "Argument NCOPIES of REPEAT intrinsic is negative "
4688                            "(its value is %lld)",
4689                            fold_convert (long_integer_type_node, ncopies));
4690
4691   /* If the source length is zero, any non negative value of NCOPIES
4692      is valid, and nothing happens.  */
4693   n = gfc_create_var (ncopies_type, "ncopies");
4694   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4695                       build_int_cst (size_type_node, 0));
4696   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4697                      build_int_cst (ncopies_type, 0), ncopies);
4698   gfc_add_modify (&se->pre, n, tmp);
4699   ncopies = n;
4700
4701   /* Check that ncopies is not too large: ncopies should be less than
4702      (or equal to) MAX / slen, where MAX is the maximal integer of
4703      the gfc_charlen_type_node type.  If slen == 0, we need a special
4704      case to avoid the division by zero.  */
4705   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4706   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4707   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4708                      fold_convert (size_type_node, max), slen);
4709   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4710               ? size_type_node : ncopies_type;
4711   cond = fold_build2 (GT_EXPR, boolean_type_node,
4712                       fold_convert (largest, ncopies),
4713                       fold_convert (largest, max));
4714   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4715                      build_int_cst (size_type_node, 0));
4716   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4717                       cond);
4718   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4719                            "Argument NCOPIES of REPEAT intrinsic is too large");
4720
4721   /* Compute the destination length.  */
4722   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4723                       fold_convert (gfc_charlen_type_node, slen),
4724                       fold_convert (gfc_charlen_type_node, ncopies));
4725   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4726   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4727
4728   /* Generate the code to do the repeat operation:
4729        for (i = 0; i < ncopies; i++)
4730          memmove (dest + (i * slen * size), src, slen*size);  */
4731   gfc_start_block (&block);
4732   count = gfc_create_var (ncopies_type, "count");
4733   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4734   exit_label = gfc_build_label_decl (NULL_TREE);
4735
4736   /* Start the loop body.  */
4737   gfc_start_block (&body);
4738
4739   /* Exit the loop if count >= ncopies.  */
4740   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4741   tmp = build1_v (GOTO_EXPR, exit_label);
4742   TREE_USED (exit_label) = 1;
4743   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4744                      build_empty_stmt (input_location));
4745   gfc_add_expr_to_block (&body, tmp);
4746
4747   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4748   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4749                      fold_convert (gfc_charlen_type_node, slen),
4750                      fold_convert (gfc_charlen_type_node, count));
4751   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4752                      tmp, fold_convert (gfc_charlen_type_node, size));
4753   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4754                      fold_convert (pvoid_type_node, dest),
4755                      fold_convert (sizetype, tmp));
4756   tmp = build_call_expr_loc (input_location,
4757                          built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4758                          fold_build2 (MULT_EXPR, size_type_node, slen,
4759                                       fold_convert (size_type_node, size)));
4760   gfc_add_expr_to_block (&body, tmp);
4761
4762   /* Increment count.  */
4763   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4764                      count, build_int_cst (TREE_TYPE (count), 1));
4765   gfc_add_modify (&body, count, tmp);
4766
4767   /* Build the loop.  */
4768   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4769   gfc_add_expr_to_block (&block, tmp);
4770
4771   /* Add the exit label.  */
4772   tmp = build1_v (LABEL_EXPR, exit_label);
4773   gfc_add_expr_to_block (&block, tmp);
4774
4775   /* Finish the block.  */
4776   tmp = gfc_finish_block (&block);
4777   gfc_add_expr_to_block (&se->pre, tmp);
4778
4779   /* Set the result value.  */
4780   se->expr = dest;
4781   se->string_length = dlen;
4782 }
4783
4784
4785 /* Generate code for the IARGC intrinsic.  */
4786
4787 static void
4788 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4789 {
4790   tree tmp;
4791   tree fndecl;
4792   tree type;
4793
4794   /* Call the library function.  This always returns an INTEGER(4).  */
4795   fndecl = gfor_fndecl_iargc;
4796   tmp = build_call_expr_loc (input_location,
4797                          fndecl, 0);
4798
4799   /* Convert it to the required type.  */
4800   type = gfc_typenode_for_spec (&expr->ts);
4801   tmp = fold_convert (type, tmp);
4802
4803   se->expr = tmp;
4804 }
4805
4806
4807 /* The loc intrinsic returns the address of its argument as
4808    gfc_index_integer_kind integer.  */
4809
4810 static void
4811 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4812 {
4813   tree temp_var;
4814   gfc_expr *arg_expr;
4815   gfc_ss *ss;
4816
4817   gcc_assert (!se->ss);
4818
4819   arg_expr = expr->value.function.actual->expr;
4820   ss = gfc_walk_expr (arg_expr);
4821   if (ss == gfc_ss_terminator)
4822     gfc_conv_expr_reference (se, arg_expr);
4823   else
4824     gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
4825   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4826
4827   /* Create a temporary variable for loc return value.  Without this,
4828      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4829   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4830   gfc_add_modify (&se->pre, temp_var, se->expr);
4831   se->expr = temp_var;
4832 }
4833
4834 /* Generate code for an intrinsic function.  Some map directly to library
4835    calls, others get special handling.  In some cases the name of the function
4836    used depends on the type specifiers.  */
4837
4838 void
4839 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4840 {
4841   const char *name;
4842   int lib, kind;
4843   tree fndecl;
4844
4845   name = &expr->value.function.name[2];
4846
4847   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4848     {
4849       lib = gfc_is_intrinsic_libcall (expr);
4850       if (lib != 0)
4851         {
4852           if (lib == 1)
4853             se->ignore_optional = 1;
4854
4855           switch (expr->value.function.isym->id)
4856             {
4857             case GFC_ISYM_EOSHIFT:
4858             case GFC_ISYM_PACK:
4859             case GFC_ISYM_RESHAPE:
4860               /* For all of those the first argument specifies the type and the
4861                  third is optional.  */
4862               conv_generic_with_optional_char_arg (se, expr, 1, 3);
4863               break;
4864
4865             default:
4866               gfc_conv_intrinsic_funcall (se, expr);
4867               break;
4868             }
4869
4870           return;
4871         }
4872     }
4873
4874   switch (expr->value.function.isym->id)
4875     {
4876     case GFC_ISYM_NONE:
4877       gcc_unreachable ();
4878
4879     case GFC_ISYM_REPEAT:
4880       gfc_conv_intrinsic_repeat (se, expr);
4881       break;
4882
4883     case GFC_ISYM_TRIM:
4884       gfc_conv_intrinsic_trim (se, expr);
4885       break;
4886
4887     case GFC_ISYM_SC_KIND:
4888       gfc_conv_intrinsic_sc_kind (se, expr);
4889       break;
4890
4891     case GFC_ISYM_SI_KIND:
4892       gfc_conv_intrinsic_si_kind (se, expr);
4893       break;
4894
4895     case GFC_ISYM_SR_KIND:
4896       gfc_conv_intrinsic_sr_kind (se, expr);
4897       break;
4898
4899     case GFC_ISYM_EXPONENT:
4900       gfc_conv_intrinsic_exponent (se, expr);
4901       break;
4902
4903     case GFC_ISYM_SCAN:
4904       kind = expr->value.function.actual->expr->ts.kind;
4905       if (kind == 1)
4906        fndecl = gfor_fndecl_string_scan;
4907       else if (kind == 4)
4908        fndecl = gfor_fndecl_string_scan_char4;
4909       else
4910        gcc_unreachable ();
4911
4912       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4913       break;
4914
4915     case GFC_ISYM_VERIFY:
4916       kind = expr->value.function.actual->expr->ts.kind;
4917       if (kind == 1)
4918        fndecl = gfor_fndecl_string_verify;
4919       else if (kind == 4)
4920        fndecl = gfor_fndecl_string_verify_char4;
4921       else
4922        gcc_unreachable ();
4923
4924       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4925       break;
4926
4927     case GFC_ISYM_ALLOCATED:
4928       gfc_conv_allocated (se, expr);
4929       break;
4930
4931     case GFC_ISYM_ASSOCIATED:
4932       gfc_conv_associated(se, expr);
4933       break;
4934
4935     case GFC_ISYM_SAME_TYPE_AS:
4936       gfc_conv_same_type_as (se, expr);
4937       break;
4938
4939     case GFC_ISYM_ABS:
4940       gfc_conv_intrinsic_abs (se, expr);
4941       break;
4942
4943     case GFC_ISYM_ADJUSTL:
4944       if (expr->ts.kind == 1)
4945        fndecl = gfor_fndecl_adjustl;
4946       else if (expr->ts.kind == 4)
4947        fndecl = gfor_fndecl_adjustl_char4;
4948       else
4949        gcc_unreachable ();
4950
4951       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4952       break;
4953
4954     case GFC_ISYM_ADJUSTR:
4955       if (expr->ts.kind == 1)
4956        fndecl = gfor_fndecl_adjustr;
4957       else if (expr->ts.kind == 4)
4958        fndecl = gfor_fndecl_adjustr_char4;
4959       else
4960        gcc_unreachable ();
4961
4962       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4963       break;
4964
4965     case GFC_ISYM_AIMAG:
4966       gfc_conv_intrinsic_imagpart (se, expr);
4967       break;
4968
4969     case GFC_ISYM_AINT:
4970       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4971       break;
4972
4973     case GFC_ISYM_ALL:
4974       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4975       break;
4976
4977     case GFC_ISYM_ANINT:
4978       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4979       break;
4980
4981     case GFC_ISYM_AND:
4982       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4983       break;
4984
4985     case GFC_ISYM_ANY:
4986       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4987       break;
4988
4989     case GFC_ISYM_BTEST:
4990       gfc_conv_intrinsic_btest (se, expr);
4991       break;
4992
4993     case GFC_ISYM_ACHAR:
4994     case GFC_ISYM_CHAR:
4995       gfc_conv_intrinsic_char (se, expr);
4996       break;
4997
4998     case GFC_ISYM_CONVERSION:
4999     case GFC_ISYM_REAL:
5000     case GFC_ISYM_LOGICAL:
5001     case GFC_ISYM_DBLE:
5002       gfc_conv_intrinsic_conversion (se, expr);
5003       break;
5004
5005       /* Integer conversions are handled separately to make sure we get the
5006          correct rounding mode.  */
5007     case GFC_ISYM_INT:
5008     case GFC_ISYM_INT2:
5009     case GFC_ISYM_INT8:
5010     case GFC_ISYM_LONG:
5011       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5012       break;
5013
5014     case GFC_ISYM_NINT:
5015       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5016       break;
5017
5018     case GFC_ISYM_CEILING:
5019       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5020       break;
5021
5022     case GFC_ISYM_FLOOR:
5023       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5024       break;
5025
5026     case GFC_ISYM_MOD:
5027       gfc_conv_intrinsic_mod (se, expr, 0);
5028       break;
5029
5030     case GFC_ISYM_MODULO:
5031       gfc_conv_intrinsic_mod (se, expr, 1);
5032       break;
5033
5034     case GFC_ISYM_CMPLX:
5035       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5036       break;
5037
5038     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5039       gfc_conv_intrinsic_iargc (se, expr);
5040       break;
5041
5042     case GFC_ISYM_COMPLEX:
5043       gfc_conv_intrinsic_cmplx (se, expr, 1);
5044       break;
5045
5046     case GFC_ISYM_CONJG:
5047       gfc_conv_intrinsic_conjg (se, expr);
5048       break;
5049
5050     case GFC_ISYM_COUNT:
5051       gfc_conv_intrinsic_count (se, expr);
5052       break;
5053
5054     case GFC_ISYM_CTIME:
5055       gfc_conv_intrinsic_ctime (se, expr);
5056       break;
5057
5058     case GFC_ISYM_DIM:
5059       gfc_conv_intrinsic_dim (se, expr);
5060       break;
5061
5062     case GFC_ISYM_DOT_PRODUCT:
5063       gfc_conv_intrinsic_dot_product (se, expr);
5064       break;
5065
5066     case GFC_ISYM_DPROD:
5067       gfc_conv_intrinsic_dprod (se, expr);
5068       break;
5069
5070     case GFC_ISYM_FDATE:
5071       gfc_conv_intrinsic_fdate (se, expr);
5072       break;
5073
5074     case GFC_ISYM_FRACTION:
5075       gfc_conv_intrinsic_fraction (se, expr);
5076       break;
5077
5078     case GFC_ISYM_IAND:
5079       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5080       break;
5081
5082     case GFC_ISYM_IBCLR:
5083       gfc_conv_intrinsic_singlebitop (se, expr, 0);
5084       break;
5085
5086     case GFC_ISYM_IBITS:
5087       gfc_conv_intrinsic_ibits (se, expr);
5088       break;
5089
5090     case GFC_ISYM_IBSET:
5091       gfc_conv_intrinsic_singlebitop (se, expr, 1);
5092       break;
5093
5094     case GFC_ISYM_IACHAR:
5095     case GFC_ISYM_ICHAR:
5096       /* We assume ASCII character sequence.  */
5097       gfc_conv_intrinsic_ichar (se, expr);
5098       break;
5099
5100     case GFC_ISYM_IARGC:
5101       gfc_conv_intrinsic_iargc (se, expr);
5102       break;
5103
5104     case GFC_ISYM_IEOR:
5105       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5106       break;
5107
5108     case GFC_ISYM_INDEX:
5109       kind = expr->value.function.actual->expr->ts.kind;
5110       if (kind == 1)
5111        fndecl = gfor_fndecl_string_index;
5112       else if (kind == 4)
5113        fndecl = gfor_fndecl_string_index_char4;
5114       else
5115        gcc_unreachable ();
5116
5117       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5118       break;
5119
5120     case GFC_ISYM_IOR:
5121       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5122       break;
5123
5124     case GFC_ISYM_IS_IOSTAT_END:
5125       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5126       break;
5127
5128     case GFC_ISYM_IS_IOSTAT_EOR:
5129       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5130       break;
5131
5132     case GFC_ISYM_ISNAN:
5133       gfc_conv_intrinsic_isnan (se, expr);
5134       break;
5135
5136     case GFC_ISYM_LSHIFT:
5137       gfc_conv_intrinsic_rlshift (se, expr, 0);
5138       break;
5139
5140     case GFC_ISYM_RSHIFT:
5141       gfc_conv_intrinsic_rlshift (se, expr, 1);
5142       break;
5143
5144     case GFC_ISYM_ISHFT:
5145       gfc_conv_intrinsic_ishft (se, expr);
5146       break;
5147
5148     case GFC_ISYM_ISHFTC:
5149       gfc_conv_intrinsic_ishftc (se, expr);
5150       break;
5151
5152     case GFC_ISYM_LEADZ:
5153       gfc_conv_intrinsic_leadz (se, expr);
5154       break;
5155
5156     case GFC_ISYM_TRAILZ:
5157       gfc_conv_intrinsic_trailz (se, expr);
5158       break;
5159
5160     case GFC_ISYM_LBOUND:
5161       gfc_conv_intrinsic_bound (se, expr, 0);
5162       break;
5163
5164     case GFC_ISYM_TRANSPOSE:
5165       if (se->ss && se->ss->useflags)
5166         {
5167           gfc_conv_tmp_array_ref (se);
5168           gfc_advance_se_ss_chain (se);
5169         }
5170       else
5171         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5172       break;
5173
5174     case GFC_ISYM_LEN:
5175       gfc_conv_intrinsic_len (se, expr);
5176       break;
5177
5178     case GFC_ISYM_LEN_TRIM:
5179       gfc_conv_intrinsic_len_trim (se, expr);
5180       break;
5181
5182     case GFC_ISYM_LGE:
5183       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5184       break;
5185
5186     case GFC_ISYM_LGT:
5187       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5188       break;
5189
5190     case GFC_ISYM_LLE:
5191       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5192       break;
5193
5194     case GFC_ISYM_LLT:
5195       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5196       break;
5197
5198     case GFC_ISYM_MAX:
5199       if (expr->ts.type == BT_CHARACTER)
5200         gfc_conv_intrinsic_minmax_char (se, expr, 1);
5201       else
5202         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5203       break;
5204
5205     case GFC_ISYM_MAXLOC:
5206       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5207       break;
5208
5209     case GFC_ISYM_MAXVAL:
5210       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5211       break;
5212
5213     case GFC_ISYM_MERGE:
5214       gfc_conv_intrinsic_merge (se, expr);
5215       break;
5216
5217     case GFC_ISYM_MIN:
5218       if (expr->ts.type == BT_CHARACTER)
5219         gfc_conv_intrinsic_minmax_char (se, expr, -1);
5220       else
5221         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5222       break;
5223
5224     case GFC_ISYM_MINLOC:
5225       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5226       break;
5227
5228     case GFC_ISYM_MINVAL:
5229       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5230       break;
5231
5232     case GFC_ISYM_NEAREST:
5233       gfc_conv_intrinsic_nearest (se, expr);
5234       break;
5235
5236     case GFC_ISYM_NOT:
5237       gfc_conv_intrinsic_not (se, expr);
5238       break;
5239
5240     case GFC_ISYM_OR:
5241       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5242       break;
5243
5244     case GFC_ISYM_PRESENT:
5245       gfc_conv_intrinsic_present (se, expr);
5246       break;
5247
5248     case GFC_ISYM_PRODUCT:
5249       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5250       break;
5251
5252     case GFC_ISYM_RRSPACING:
5253       gfc_conv_intrinsic_rrspacing (se, expr);
5254       break;
5255
5256     case GFC_ISYM_SET_EXPONENT:
5257       gfc_conv_intrinsic_set_exponent (se, expr);
5258       break;
5259
5260     case GFC_ISYM_SCALE:
5261       gfc_conv_intrinsic_scale (se, expr);
5262       break;
5263
5264     case GFC_ISYM_SIGN:
5265       gfc_conv_intrinsic_sign (se, expr);
5266       break;
5267
5268     case GFC_ISYM_SIZE:
5269       gfc_conv_intrinsic_size (se, expr);
5270       break;
5271
5272     case GFC_ISYM_SIZEOF:
5273       gfc_conv_intrinsic_sizeof (se, expr);
5274       break;
5275
5276     case GFC_ISYM_SPACING:
5277       gfc_conv_intrinsic_spacing (se, expr);
5278       break;
5279
5280     case GFC_ISYM_SUM:
5281       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5282       break;
5283
5284     case GFC_ISYM_TRANSFER:
5285       if (se->ss && se->ss->useflags)
5286         {
5287           /* Access the previously obtained result.  */
5288           gfc_conv_tmp_array_ref (se);
5289           gfc_advance_se_ss_chain (se);
5290         }
5291       else
5292         gfc_conv_intrinsic_transfer (se, expr);
5293       break;
5294
5295     case GFC_ISYM_TTYNAM:
5296       gfc_conv_intrinsic_ttynam (se, expr);
5297       break;
5298
5299     case GFC_ISYM_UBOUND:
5300       gfc_conv_intrinsic_bound (se, expr, 1);
5301       break;
5302
5303     case GFC_ISYM_XOR:
5304       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5305       break;
5306
5307     case GFC_ISYM_LOC:
5308       gfc_conv_intrinsic_loc (se, expr);
5309       break;
5310
5311     case GFC_ISYM_ACCESS:
5312     case GFC_ISYM_CHDIR:
5313     case GFC_ISYM_CHMOD:
5314     case GFC_ISYM_DTIME:
5315     case GFC_ISYM_ETIME:
5316     case GFC_ISYM_EXTENDS_TYPE_OF:
5317     case GFC_ISYM_FGET:
5318     case GFC_ISYM_FGETC:
5319     case GFC_ISYM_FNUM:
5320     case GFC_ISYM_FPUT:
5321     case GFC_ISYM_FPUTC:
5322     case GFC_ISYM_FSTAT:
5323     case GFC_ISYM_FTELL:
5324     case GFC_ISYM_GETCWD:
5325     case GFC_ISYM_GETGID:
5326     case GFC_ISYM_GETPID:
5327     case GFC_ISYM_GETUID:
5328     case GFC_ISYM_HOSTNM:
5329     case GFC_ISYM_KILL:
5330     case GFC_ISYM_IERRNO:
5331     case GFC_ISYM_IRAND:
5332     case GFC_ISYM_ISATTY:
5333     case GFC_ISYM_LINK:
5334     case GFC_ISYM_LSTAT:
5335     case GFC_ISYM_MALLOC:
5336     case GFC_ISYM_MATMUL:
5337     case GFC_ISYM_MCLOCK:
5338     case GFC_ISYM_MCLOCK8:
5339     case GFC_ISYM_RAND:
5340     case GFC_ISYM_RENAME:
5341     case GFC_ISYM_SECOND:
5342     case GFC_ISYM_SECNDS:
5343     case GFC_ISYM_SIGNAL:
5344     case GFC_ISYM_STAT:
5345     case GFC_ISYM_SYMLNK:
5346     case GFC_ISYM_SYSTEM:
5347     case GFC_ISYM_TIME:
5348     case GFC_ISYM_TIME8:
5349     case GFC_ISYM_UMASK:
5350     case GFC_ISYM_UNLINK:
5351       gfc_conv_intrinsic_funcall (se, expr);
5352       break;
5353
5354     case GFC_ISYM_EOSHIFT:
5355     case GFC_ISYM_PACK:
5356     case GFC_ISYM_RESHAPE:
5357       /* For those, expr->rank should always be >0 and thus the if above the
5358          switch should have matched.  */
5359       gcc_unreachable ();
5360       break;
5361
5362     default:
5363       gfc_conv_intrinsic_lib_function (se, expr);
5364       break;
5365     }
5366 }
5367
5368
5369 /* This generates code to execute before entering the scalarization loop.
5370    Currently does nothing.  */
5371
5372 void
5373 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5374 {
5375   switch (ss->expr->value.function.isym->id)
5376     {
5377     case GFC_ISYM_UBOUND:
5378     case GFC_ISYM_LBOUND:
5379       break;
5380
5381     default:
5382       gcc_unreachable ();
5383     }
5384 }
5385
5386
5387 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5388    inside the scalarization loop.  */
5389
5390 static gfc_ss *
5391 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5392 {
5393   gfc_ss *newss;
5394
5395   /* The two argument version returns a scalar.  */
5396   if (expr->value.function.actual->next->expr)
5397     return ss;
5398
5399   newss = gfc_get_ss ();
5400   newss->type = GFC_SS_INTRINSIC;
5401   newss->expr = expr;
5402   newss->next = ss;
5403   newss->data.info.dimen = 1;
5404
5405   return newss;
5406 }
5407
5408
5409 /* Walk an intrinsic array libcall.  */
5410
5411 static gfc_ss *
5412 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5413 {
5414   gfc_ss *newss;
5415
5416   gcc_assert (expr->rank > 0);
5417
5418   newss = gfc_get_ss ();
5419   newss->type = GFC_SS_FUNCTION;
5420   newss->expr = expr;
5421   newss->next = ss;
5422   newss->data.info.dimen = expr->rank;
5423
5424   return newss;
5425 }
5426
5427
5428 /* Returns nonzero if the specified intrinsic function call maps directly to
5429    an external library call.  Should only be used for functions that return
5430    arrays.  */
5431
5432 int
5433 gfc_is_intrinsic_libcall (gfc_expr * expr)
5434 {
5435   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5436   gcc_assert (expr->rank > 0);
5437
5438   switch (expr->value.function.isym->id)
5439     {
5440     case GFC_ISYM_ALL:
5441     case GFC_ISYM_ANY:
5442     case GFC_ISYM_COUNT:
5443     case GFC_ISYM_MATMUL:
5444     case GFC_ISYM_MAXLOC:
5445     case GFC_ISYM_MAXVAL:
5446     case GFC_ISYM_MINLOC:
5447     case GFC_ISYM_MINVAL:
5448     case GFC_ISYM_PRODUCT:
5449     case GFC_ISYM_SUM:
5450     case GFC_ISYM_SHAPE:
5451     case GFC_ISYM_SPREAD:
5452     case GFC_ISYM_TRANSPOSE:
5453       /* Ignore absent optional parameters.  */
5454       return 1;
5455
5456     case GFC_ISYM_RESHAPE:
5457     case GFC_ISYM_CSHIFT:
5458     case GFC_ISYM_EOSHIFT:
5459     case GFC_ISYM_PACK:
5460     case GFC_ISYM_UNPACK:
5461       /* Pass absent optional parameters.  */
5462       return 2;
5463
5464     default:
5465       return 0;
5466     }
5467 }
5468
5469 /* Walk an intrinsic function.  */
5470 gfc_ss *
5471 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5472                              gfc_intrinsic_sym * isym)
5473 {
5474   gcc_assert (isym);
5475
5476   if (isym->elemental)
5477     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5478
5479   if (expr->rank == 0)
5480     return ss;
5481
5482   if (gfc_is_intrinsic_libcall (expr))
5483     return gfc_walk_intrinsic_libfunc (ss, expr);
5484
5485   /* Special cases.  */
5486   switch (isym->id)
5487     {
5488     case GFC_ISYM_LBOUND:
5489     case GFC_ISYM_UBOUND:
5490       return gfc_walk_intrinsic_bound (ss, expr);
5491
5492     case GFC_ISYM_TRANSFER:
5493       return gfc_walk_intrinsic_libfunc (ss, expr);
5494
5495     default:
5496       /* This probably meant someone forgot to add an intrinsic to the above
5497          list(s) when they implemented it, or something's gone horribly
5498          wrong.  */
5499       gcc_unreachable ();
5500     }
5501 }
5502
5503 #include "gt-fortran-trans-intrinsic.h"