gcc/fortran/trans-intrinsic.c

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