gcc/fortran/trans-intrinsic.c

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