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, cond2, 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       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 974
 975       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 976                            gfc_index_zero_node);
 977       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 978
 979       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 980                            gfc_index_zero_node);
 981
 982       if (upper)
 983         {
 984           tree cond5;
 985           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 986
 987           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
 988           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
 989
 990           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
 991
 992           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 993                                   ubound, gfc_index_zero_node);
 994         }
 995       else
 996         {
 997           if (as->type == AS_ASSUMED_SIZE)
 998             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 999                                 build_int_cst (TREE_TYPE (bound),
1000                                                arg->expr->rank - 1));
1001           else
1002             cond = boolean_false_node;
1003
1004           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
1005           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1006
1007           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1008                                   lbound, gfc_index_one_node);
1009         }
1010     }
1011   else
1012     {
1013       if (upper)
1014         {
1015           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1016           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1017                                   gfc_index_one_node);
1018           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1019                                   gfc_index_zero_node);
1020         }
1021       else
1022         se->expr = gfc_index_one_node;
1023     }
1024
1025   type = gfc_typenode_for_spec (&expr->ts);
1026   se->expr = convert (type, se->expr);
1027 }
1028
1029
1030 static void
1031 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1032 {
1033   tree arg;
1034   int n;
1035
1036   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1037
1038   switch (expr->value.function.actual->expr->ts.type)
1039     {
1040     case BT_INTEGER:
1041     case BT_REAL:
1042       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1043       break;
1044
1045     case BT_COMPLEX:
1046       switch (expr->ts.kind)
1047         {
1048         case 4:
1049           n = BUILT_IN_CABSF;
1050           break;
1051         case 8:
1052           n = BUILT_IN_CABS;
1053           break;
1054         case 10:
1055         case 16:
1056           n = BUILT_IN_CABSL;
1057           break;
1058         default:
1059           gcc_unreachable ();
1060         }
1061       se->expr = build_call_expr_loc (input_location,
1062                                   built_in_decls[n], 1, arg);
1063       break;
1064
1065     default:
1066       gcc_unreachable ();
1067     }
1068 }
1069
1070
1071 /* Create a complex value from one or two real components.  */
1072
1073 static void
1074 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1075 {
1076   tree real;
1077   tree imag;
1078   tree type;
1079   tree *args;
1080   unsigned int num_args;
1081
1082   num_args = gfc_intrinsic_argument_list_length (expr);
1083   args = (tree *) alloca (sizeof (tree) * num_args);
1084
1085   type = gfc_typenode_for_spec (&expr->ts);
1086   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1087   real = convert (TREE_TYPE (type), args[0]);
1088   if (both)
1089     imag = convert (TREE_TYPE (type), args[1]);
1090   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1091     {
1092       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1093                           args[0]);
1094       imag = convert (TREE_TYPE (type), imag);
1095     }
1096   else
1097     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1098
1099   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1100 }
1101
1102 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1103                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1104 /* TODO: MOD(x, 0)  */
1105
1106 static void
1107 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1108 {
1109   tree type;
1110   tree itype;
1111   tree tmp;
1112   tree test;
1113   tree test2;
1114   mpfr_t huge;
1115   int n, ikind;
1116   tree args[2];
1117
1118   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1119
1120   switch (expr->ts.type)
1121     {
1122     case BT_INTEGER:
1123       /* Integer case is easy, we've got a builtin op.  */
1124       type = TREE_TYPE (args[0]);
1125
1126       if (modulo)
1127        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1128       else
1129        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1130       break;
1131
1132     case BT_REAL:
1133       n = END_BUILTINS;
1134       /* Check if we have a builtin fmod.  */
1135       switch (expr->ts.kind)
1136         {
1137         case 4:
1138           n = BUILT_IN_FMODF;
1139           break;
1140
1141         case 8:
1142           n = BUILT_IN_FMOD;
1143           break;
1144
1145         case 10:
1146         case 16:
1147           n = BUILT_IN_FMODL;
1148           break;
1149
1150         default:
1151           break;
1152         }
1153
1154       /* Use it if it exists.  */
1155       if (n != END_BUILTINS)
1156         {
1157           tmp = build_addr (built_in_decls[n], current_function_decl);
1158           se->expr = build_call_array_loc (input_location,
1159                                        TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1160                                        tmp, 2, args);
1161           if (modulo == 0)
1162             return;
1163         }
1164
1165       type = TREE_TYPE (args[0]);
1166
1167       args[0] = gfc_evaluate_now (args[0], &se->pre);
1168       args[1] = gfc_evaluate_now (args[1], &se->pre);
1169
1170       /* Definition:
1171          modulo = arg - floor (arg/arg2) * arg2, so
1172                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1173          where
1174           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1175          thereby avoiding another division and retaining the accuracy
1176          of the builtin function.  */
1177       if (n != END_BUILTINS && modulo)
1178         {
1179           tree zero = gfc_build_const (type, integer_zero_node);
1180           tmp = gfc_evaluate_now (se->expr, &se->pre);
1181           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1182           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1183           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1184           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1185           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1186           test = gfc_evaluate_now (test, &se->pre);
1187           se->expr = fold_build3 (COND_EXPR, type, test,
1188                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1189                                   tmp);
1190           return;
1191         }
1192
1193       /* If we do not have a built_in fmod, the calculation is going to
1194          have to be done longhand.  */
1195       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1196
1197       /* Test if the value is too large to handle sensibly.  */
1198       gfc_set_model_kind (expr->ts.kind);
1199       mpfr_init (huge);
1200       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1201       ikind = expr->ts.kind;
1202       if (n < 0)
1203         {
1204           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1205           ikind = gfc_max_integer_kind;
1206         }
1207       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1208       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1209       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1210
1211       mpfr_neg (huge, huge, GFC_RND_MODE);
1212       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1213       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1214       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1215
1216       itype = gfc_get_int_type (ikind);
1217       if (modulo)
1218        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1219       else
1220        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1221       tmp = convert (type, tmp);
1222       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1223       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1224       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1225       mpfr_clear (huge);
1226       break;
1227
1228     default:
1229       gcc_unreachable ();
1230     }
1231 }
1232
1233 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1234
1235 static void
1236 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1237 {
1238   tree val;
1239   tree tmp;
1240   tree type;
1241   tree zero;
1242   tree args[2];
1243
1244   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1245   type = TREE_TYPE (args[0]);
1246
1247   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1248   val = gfc_evaluate_now (val, &se->pre);
1249
1250   zero = gfc_build_const (type, integer_zero_node);
1251   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1252   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1253 }
1254
1255
1256 /* SIGN(A, B) is absolute value of A times sign of B.
1257    The real value versions use library functions to ensure the correct
1258    handling of negative zero.  Integer case implemented as:
1259    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1260   */
1261
1262 static void
1263 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1264 {
1265   tree tmp;
1266   tree type;
1267   tree args[2];
1268
1269   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1270   if (expr->ts.type == BT_REAL)
1271     {
1272       tree abs;
1273
1274       switch (expr->ts.kind)
1275         {
1276         case 4:
1277           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1278           abs = built_in_decls[BUILT_IN_FABSF];
1279           break;
1280         case 8:
1281           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1282           abs = built_in_decls[BUILT_IN_FABS];
1283           break;
1284         case 10:
1285         case 16:
1286           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1287           abs = built_in_decls[BUILT_IN_FABSL];
1288           break;
1289         default:
1290           gcc_unreachable ();
1291         }
1292
1293       /* We explicitly have to ignore the minus sign. We do so by using
1294          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
1295       if (!gfc_option.flag_sign_zero
1296           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1297         {
1298           tree cond, zero;
1299           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1300           cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1301           se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1302                                   build_call_expr (abs, 1, args[0]),
1303                                   build_call_expr (tmp, 2, args[0], args[1]));
1304         }
1305       else
1306         se->expr = build_call_expr_loc (input_location,
1307                                   tmp, 2, args[0], args[1]);
1308       return;
1309     }
1310
1311   /* Having excluded floating point types, we know we are now dealing
1312      with signed integer types.  */
1313   type = TREE_TYPE (args[0]);
1314
1315   /* Args[0] is used multiple times below.  */
1316   args[0] = gfc_evaluate_now (args[0], &se->pre);
1317
1318   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1319      the signs of A and B are the same, and of all ones if they differ.  */
1320   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1321   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1322                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1323   tmp = gfc_evaluate_now (tmp, &se->pre);
1324
1325   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1326      is all ones (i.e. -1).  */
1327   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1328                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1329                           tmp);
1330 }
1331
1332
1333 /* Test for the presence of an optional argument.  */
1334
1335 static void
1336 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1337 {
1338   gfc_expr *arg;
1339
1340   arg = expr->value.function.actual->expr;
1341   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1342   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1343   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1344 }
1345
1346
1347 /* Calculate the double precision product of two single precision values.  */
1348
1349 static void
1350 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1351 {
1352   tree type;
1353   tree args[2];
1354
1355   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1356
1357   /* Convert the args to double precision before multiplying.  */
1358   type = gfc_typenode_for_spec (&expr->ts);
1359   args[0] = convert (type, args[0]);
1360   args[1] = convert (type, args[1]);
1361   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1362 }
1363
1364
1365 /* Return a length one character string containing an ascii character.  */
1366
1367 static void
1368 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1369 {
1370   tree arg[2];
1371   tree var;
1372   tree type;
1373   unsigned int num_args;
1374
1375   num_args = gfc_intrinsic_argument_list_length (expr);
1376   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1377
1378   type = gfc_get_char_type (expr->ts.kind);
1379   var = gfc_create_var (type, "char");
1380
1381   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1382   gfc_add_modify (&se->pre, var, arg[0]);
1383   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1384   se->string_length = integer_one_node;
1385 }
1386
1387
1388 static void
1389 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1390 {
1391   tree var;
1392   tree len;
1393   tree tmp;
1394   tree cond;
1395   tree fndecl;
1396   tree *args;
1397   unsigned int num_args;
1398
1399   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1400   args = (tree *) alloca (sizeof (tree) * num_args);
1401
1402   var = gfc_create_var (pchar_type_node, "pstr");
1403   len = gfc_create_var (gfc_get_int_type (8), "len");
1404
1405   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1406   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1407   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1408
1409   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1410   tmp = build_call_array_loc (input_location,
1411                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1412                           fndecl, num_args, args);
1413   gfc_add_expr_to_block (&se->pre, tmp);
1414
1415   /* Free the temporary afterwards, if necessary.  */
1416   cond = fold_build2 (GT_EXPR, boolean_type_node,
1417                       len, build_int_cst (TREE_TYPE (len), 0));
1418   tmp = gfc_call_free (var);
1419   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1420   gfc_add_expr_to_block (&se->post, tmp);
1421
1422   se->expr = var;
1423   se->string_length = len;
1424 }
1425
1426
1427 static void
1428 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1429 {
1430   tree var;
1431   tree len;
1432   tree tmp;
1433   tree cond;
1434   tree fndecl;
1435   tree *args;
1436   unsigned int num_args;
1437
1438   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1439   args = (tree *) alloca (sizeof (tree) * num_args);
1440
1441   var = gfc_create_var (pchar_type_node, "pstr");
1442   len = gfc_create_var (gfc_get_int_type (4), "len");
1443
1444   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1445   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1446   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1447
1448   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1449   tmp = build_call_array_loc (input_location,
1450                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1451                           fndecl, num_args, args);
1452   gfc_add_expr_to_block (&se->pre, tmp);
1453
1454   /* Free the temporary afterwards, if necessary.  */
1455   cond = fold_build2 (GT_EXPR, boolean_type_node,
1456                       len, build_int_cst (TREE_TYPE (len), 0));
1457   tmp = gfc_call_free (var);
1458   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1459   gfc_add_expr_to_block (&se->post, tmp);
1460
1461   se->expr = var;
1462   se->string_length = len;
1463 }
1464
1465
1466 /* Return a character string containing the tty name.  */
1467
1468 static void
1469 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1470 {
1471   tree var;
1472   tree len;
1473   tree tmp;
1474   tree cond;
1475   tree fndecl;
1476   tree *args;
1477   unsigned int num_args;
1478
1479   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1480   args = (tree *) alloca (sizeof (tree) * num_args);
1481
1482   var = gfc_create_var (pchar_type_node, "pstr");
1483   len = gfc_create_var (gfc_get_int_type (4), "len");
1484
1485   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1486   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1487   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1488
1489   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1490   tmp = build_call_array_loc (input_location,
1491                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1492                           fndecl, num_args, args);
1493   gfc_add_expr_to_block (&se->pre, tmp);
1494
1495   /* Free the temporary afterwards, if necessary.  */
1496   cond = fold_build2 (GT_EXPR, boolean_type_node,
1497                       len, build_int_cst (TREE_TYPE (len), 0));
1498   tmp = gfc_call_free (var);
1499   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1500   gfc_add_expr_to_block (&se->post, tmp);
1501
1502   se->expr = var;
1503   se->string_length = len;
1504 }
1505
1506
1507 /* Get the minimum/maximum value of all the parameters.
1508     minmax (a1, a2, a3, ...)
1509     {
1510       mvar = a1;
1511       if (a2 .op. mvar || isnan(mvar))
1512         mvar = a2;
1513       if (a3 .op. mvar || isnan(mvar))
1514         mvar = a3;
1515       ...
1516       return mvar
1517     }
1518  */
1519
1520 /* TODO: Mismatching types can occur when specific names are used.
1521    These should be handled during resolution.  */
1522 static void
1523 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1524 {
1525   tree tmp;
1526   tree mvar;
1527   tree val;
1528   tree thencase;
1529   tree *args;
1530   tree type;
1531   gfc_actual_arglist *argexpr;
1532   unsigned int i, nargs;
1533
1534   nargs = gfc_intrinsic_argument_list_length (expr);
1535   args = (tree *) alloca (sizeof (tree) * nargs);
1536
1537   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1538   type = gfc_typenode_for_spec (&expr->ts);
1539
1540   argexpr = expr->value.function.actual;
1541   if (TREE_TYPE (args[0]) != type)
1542     args[0] = convert (type, args[0]);
1543   /* Only evaluate the argument once.  */
1544   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1545     args[0] = gfc_evaluate_now (args[0], &se->pre);
1546
1547   mvar = gfc_create_var (type, "M");
1548   gfc_add_modify (&se->pre, mvar, args[0]);
1549   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1550     {
1551       tree cond, isnan;
1552
1553       val = args[i];
1554
1555       /* Handle absent optional arguments by ignoring the comparison.  */
1556       if (argexpr->expr->expr_type == EXPR_VARIABLE
1557           && argexpr->expr->symtree->n.sym->attr.optional
1558           && TREE_CODE (val) == INDIRECT_REF)
1559         cond = fold_build2_loc (input_location,
1560                                 NE_EXPR, boolean_type_node,
1561                                 TREE_OPERAND (val, 0),
1562                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1563       else
1564       {
1565         cond = NULL_TREE;
1566
1567         /* Only evaluate the argument once.  */
1568         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1569           val = gfc_evaluate_now (val, &se->pre);
1570       }
1571
1572       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1573
1574       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1575
1576       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1577          __builtin_isnan might be made dependent on that module being loaded,
1578          to help performance of programs that don't rely on IEEE semantics.  */
1579       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1580         {
1581           isnan = build_call_expr_loc (input_location,
1582                                    built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1583           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1584                              fold_convert (boolean_type_node, isnan));
1585         }
1586       tmp = build3_v (COND_EXPR, tmp, thencase,
1587                       build_empty_stmt (input_location));
1588
1589       if (cond != NULL_TREE)
1590         tmp = build3_v (COND_EXPR, cond, tmp,
1591                         build_empty_stmt (input_location));
1592
1593       gfc_add_expr_to_block (&se->pre, tmp);
1594       argexpr = argexpr->next;
1595     }
1596   se->expr = mvar;
1597 }
1598
1599
1600 /* Generate library calls for MIN and MAX intrinsics for character
1601    variables.  */
1602 static void
1603 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1604 {
1605   tree *args;
1606   tree var, len, fndecl, tmp, cond, function;
1607   unsigned int nargs;
1608
1609   nargs = gfc_intrinsic_argument_list_length (expr);
1610   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1611   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1612
1613   /* Create the result variables.  */
1614   len = gfc_create_var (gfc_charlen_type_node, "len");
1615   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1616   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1617   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1618   args[2] = build_int_cst (NULL_TREE, op);
1619   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1620
1621   if (expr->ts.kind == 1)
1622     function = gfor_fndecl_string_minmax;
1623   else if (expr->ts.kind == 4)
1624     function = gfor_fndecl_string_minmax_char4;
1625   else
1626     gcc_unreachable ();
1627
1628   /* Make the function call.  */
1629   fndecl = build_addr (function, current_function_decl);
1630   tmp = build_call_array_loc (input_location,
1631                           TREE_TYPE (TREE_TYPE (function)), fndecl,
1632                           nargs + 4, args);
1633   gfc_add_expr_to_block (&se->pre, tmp);
1634
1635   /* Free the temporary afterwards, if necessary.  */
1636   cond = fold_build2 (GT_EXPR, boolean_type_node,
1637                       len, build_int_cst (TREE_TYPE (len), 0));
1638   tmp = gfc_call_free (var);
1639   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1640   gfc_add_expr_to_block (&se->post, tmp);
1641
1642   se->expr = var;
1643   se->string_length = len;
1644 }
1645
1646
1647 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1648    has the generic name.  */
1649
1650 static gfc_symbol *
1651 gfc_get_symbol_for_expr (gfc_expr * expr)
1652 {
1653   gfc_symbol *sym;
1654
1655   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1656   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1657   sym = gfc_new_symbol (expr->value.function.name, NULL);
1658
1659   sym->ts = expr->ts;
1660   sym->attr.external = 1;
1661   sym->attr.function = 1;
1662   sym->attr.always_explicit = 1;
1663   sym->attr.proc = PROC_INTRINSIC;
1664   sym->attr.flavor = FL_PROCEDURE;
1665   sym->result = sym;
1666   if (expr->rank > 0)
1667     {
1668       sym->attr.dimension = 1;
1669       sym->as = gfc_get_array_spec ();
1670       sym->as->type = AS_ASSUMED_SHAPE;
1671       sym->as->rank = expr->rank;
1672     }
1673
1674   /* TODO: proper argument lists for external intrinsics.  */
1675   return sym;
1676 }
1677
1678 /* Generate a call to an external intrinsic function.  */
1679 static void
1680 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1681 {
1682   gfc_symbol *sym;
1683   tree append_args;
1684
1685   gcc_assert (!se->ss || se->ss->expr == expr);
1686
1687   if (se->ss)
1688     gcc_assert (expr->rank > 0);
1689   else
1690     gcc_assert (expr->rank == 0);
1691
1692   sym = gfc_get_symbol_for_expr (expr);
1693
1694   /* Calls to libgfortran_matmul need to be appended special arguments,
1695      to be able to call the BLAS ?gemm functions if required and possible.  */
1696   append_args = NULL_TREE;
1697   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1698       && sym->ts.type != BT_LOGICAL)
1699     {
1700       tree cint = gfc_get_int_type (gfc_c_int_kind);
1701
1702       if (gfc_option.flag_external_blas
1703           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1704           && (sym->ts.kind == gfc_default_real_kind
1705               || sym->ts.kind == gfc_default_double_kind))
1706         {
1707           tree gemm_fndecl;
1708
1709           if (sym->ts.type == BT_REAL)
1710             {
1711               if (sym->ts.kind == gfc_default_real_kind)
1712                 gemm_fndecl = gfor_fndecl_sgemm;
1713               else
1714                 gemm_fndecl = gfor_fndecl_dgemm;
1715             }
1716           else
1717             {
1718               if (sym->ts.kind == gfc_default_real_kind)
1719                 gemm_fndecl = gfor_fndecl_cgemm;
1720               else
1721                 gemm_fndecl = gfor_fndecl_zgemm;
1722             }
1723
1724           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1725           append_args = gfc_chainon_list
1726                           (append_args, build_int_cst
1727                                           (cint, gfc_option.blas_matmul_limit));
1728           append_args = gfc_chainon_list (append_args,
1729                                           gfc_build_addr_expr (NULL_TREE,
1730                                                                gemm_fndecl));
1731         }
1732       else
1733         {
1734           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1735           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1736           append_args = gfc_chainon_list (append_args, null_pointer_node);
1737         }
1738     }
1739
1740   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1741                           append_args);
1742   gfc_free (sym);
1743 }
1744
1745 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1746    Implemented as
1747     any(a)
1748     {
1749       forall (i=...)
1750         if (a[i] != 0)
1751           return 1
1752       end forall
1753       return 0
1754     }
1755     all(a)
1756     {
1757       forall (i=...)
1758         if (a[i] == 0)
1759           return 0
1760       end forall
1761       return 1
1762     }
1763  */
1764 static void
1765 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1766 {
1767   tree resvar;
1768   stmtblock_t block;
1769   stmtblock_t body;
1770   tree type;
1771   tree tmp;
1772   tree found;
1773   gfc_loopinfo loop;
1774   gfc_actual_arglist *actual;
1775   gfc_ss *arrayss;
1776   gfc_se arrayse;
1777   tree exit_label;
1778
1779   if (se->ss)
1780     {
1781       gfc_conv_intrinsic_funcall (se, expr);
1782       return;
1783     }
1784
1785   actual = expr->value.function.actual;
1786   type = gfc_typenode_for_spec (&expr->ts);
1787   /* Initialize the result.  */
1788   resvar = gfc_create_var (type, "test");
1789   if (op == EQ_EXPR)
1790     tmp = convert (type, boolean_true_node);
1791   else
1792     tmp = convert (type, boolean_false_node);
1793   gfc_add_modify (&se->pre, resvar, tmp);
1794
1795   /* Walk the arguments.  */
1796   arrayss = gfc_walk_expr (actual->expr);
1797   gcc_assert (arrayss != gfc_ss_terminator);
1798
1799   /* Initialize the scalarizer.  */
1800   gfc_init_loopinfo (&loop);
1801   exit_label = gfc_build_label_decl (NULL_TREE);
1802   TREE_USED (exit_label) = 1;
1803   gfc_add_ss_to_loop (&loop, arrayss);
1804
1805   /* Initialize the loop.  */
1806   gfc_conv_ss_startstride (&loop);
1807   gfc_conv_loop_setup (&loop, &expr->where);
1808
1809   gfc_mark_ss_chain_used (arrayss, 1);
1810   /* Generate the loop body.  */
1811   gfc_start_scalarized_body (&loop, &body);
1812
1813   /* If the condition matches then set the return value.  */
1814   gfc_start_block (&block);
1815   if (op == EQ_EXPR)
1816     tmp = convert (type, boolean_false_node);
1817   else
1818     tmp = convert (type, boolean_true_node);
1819   gfc_add_modify (&block, resvar, tmp);
1820
1821   /* And break out of the loop.  */
1822   tmp = build1_v (GOTO_EXPR, exit_label);
1823   gfc_add_expr_to_block (&block, tmp);
1824
1825   found = gfc_finish_block (&block);
1826
1827   /* Check this element.  */
1828   gfc_init_se (&arrayse, NULL);
1829   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1830   arrayse.ss = arrayss;
1831   gfc_conv_expr_val (&arrayse, actual->expr);
1832
1833   gfc_add_block_to_block (&body, &arrayse.pre);
1834   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1835                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1836   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1837   gfc_add_expr_to_block (&body, tmp);
1838   gfc_add_block_to_block (&body, &arrayse.post);
1839
1840   gfc_trans_scalarizing_loops (&loop, &body);
1841
1842   /* Add the exit label.  */
1843   tmp = build1_v (LABEL_EXPR, exit_label);
1844   gfc_add_expr_to_block (&loop.pre, tmp);
1845
1846   gfc_add_block_to_block (&se->pre, &loop.pre);
1847   gfc_add_block_to_block (&se->pre, &loop.post);
1848   gfc_cleanup_loop (&loop);
1849
1850   se->expr = resvar;
1851 }
1852
1853 /* COUNT(A) = Number of true elements in A.  */
1854 static void
1855 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1856 {
1857   tree resvar;
1858   tree type;
1859   stmtblock_t body;
1860   tree tmp;
1861   gfc_loopinfo loop;
1862   gfc_actual_arglist *actual;
1863   gfc_ss *arrayss;
1864   gfc_se arrayse;
1865
1866   if (se->ss)
1867     {
1868       gfc_conv_intrinsic_funcall (se, expr);
1869       return;
1870     }
1871
1872   actual = expr->value.function.actual;
1873
1874   type = gfc_typenode_for_spec (&expr->ts);
1875   /* Initialize the result.  */
1876   resvar = gfc_create_var (type, "count");
1877   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1878
1879   /* Walk the arguments.  */
1880   arrayss = gfc_walk_expr (actual->expr);
1881   gcc_assert (arrayss != gfc_ss_terminator);
1882
1883   /* Initialize the scalarizer.  */
1884   gfc_init_loopinfo (&loop);
1885   gfc_add_ss_to_loop (&loop, arrayss);
1886
1887   /* Initialize the loop.  */
1888   gfc_conv_ss_startstride (&loop);
1889   gfc_conv_loop_setup (&loop, &expr->where);
1890
1891   gfc_mark_ss_chain_used (arrayss, 1);
1892   /* Generate the loop body.  */
1893   gfc_start_scalarized_body (&loop, &body);
1894
1895   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1896                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1897   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1898
1899   gfc_init_se (&arrayse, NULL);
1900   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1901   arrayse.ss = arrayss;
1902   gfc_conv_expr_val (&arrayse, actual->expr);
1903   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1904                   build_empty_stmt (input_location));
1905
1906   gfc_add_block_to_block (&body, &arrayse.pre);
1907   gfc_add_expr_to_block (&body, tmp);
1908   gfc_add_block_to_block (&body, &arrayse.post);
1909
1910   gfc_trans_scalarizing_loops (&loop, &body);
1911
1912   gfc_add_block_to_block (&se->pre, &loop.pre);
1913   gfc_add_block_to_block (&se->pre, &loop.post);
1914   gfc_cleanup_loop (&loop);
1915
1916   se->expr = resvar;
1917 }
1918
1919 /* Inline implementation of the sum and product intrinsics.  */
1920 static void
1921 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1922 {
1923   tree resvar;
1924   tree type;
1925   stmtblock_t body;
1926   stmtblock_t block;
1927   tree tmp;
1928   gfc_loopinfo loop;
1929   gfc_actual_arglist *actual;
1930   gfc_ss *arrayss;
1931   gfc_ss *maskss;
1932   gfc_se arrayse;
1933   gfc_se maskse;
1934   gfc_expr *arrayexpr;
1935   gfc_expr *maskexpr;
1936
1937   if (se->ss)
1938     {
1939       gfc_conv_intrinsic_funcall (se, expr);
1940       return;
1941     }
1942
1943   type = gfc_typenode_for_spec (&expr->ts);
1944   /* Initialize the result.  */
1945   resvar = gfc_create_var (type, "val");
1946   if (op == PLUS_EXPR)
1947     tmp = gfc_build_const (type, integer_zero_node);
1948   else
1949     tmp = gfc_build_const (type, integer_one_node);
1950
1951   gfc_add_modify (&se->pre, resvar, tmp);
1952
1953   /* Walk the arguments.  */
1954   actual = expr->value.function.actual;
1955   arrayexpr = actual->expr;
1956   arrayss = gfc_walk_expr (arrayexpr);
1957   gcc_assert (arrayss != gfc_ss_terminator);
1958
1959   actual = actual->next->next;
1960   gcc_assert (actual);
1961   maskexpr = actual->expr;
1962   if (maskexpr && maskexpr->rank != 0)
1963     {
1964       maskss = gfc_walk_expr (maskexpr);
1965       gcc_assert (maskss != gfc_ss_terminator);
1966     }
1967   else
1968     maskss = NULL;
1969
1970   /* Initialize the scalarizer.  */
1971   gfc_init_loopinfo (&loop);
1972   gfc_add_ss_to_loop (&loop, arrayss);
1973   if (maskss)
1974     gfc_add_ss_to_loop (&loop, maskss);
1975
1976   /* Initialize the loop.  */
1977   gfc_conv_ss_startstride (&loop);
1978   gfc_conv_loop_setup (&loop, &expr->where);
1979
1980   gfc_mark_ss_chain_used (arrayss, 1);
1981   if (maskss)
1982     gfc_mark_ss_chain_used (maskss, 1);
1983   /* Generate the loop body.  */
1984   gfc_start_scalarized_body (&loop, &body);
1985
1986   /* If we have a mask, only add this element if the mask is set.  */
1987   if (maskss)
1988     {
1989       gfc_init_se (&maskse, NULL);
1990       gfc_copy_loopinfo_to_se (&maskse, &loop);
1991       maskse.ss = maskss;
1992       gfc_conv_expr_val (&maskse, maskexpr);
1993       gfc_add_block_to_block (&body, &maskse.pre);
1994
1995       gfc_start_block (&block);
1996     }
1997   else
1998     gfc_init_block (&block);
1999
2000   /* Do the actual summation/product.  */
2001   gfc_init_se (&arrayse, NULL);
2002   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2003   arrayse.ss = arrayss;
2004   gfc_conv_expr_val (&arrayse, arrayexpr);
2005   gfc_add_block_to_block (&block, &arrayse.pre);
2006
2007   tmp = fold_build2 (op, type, resvar, arrayse.expr);
2008   gfc_add_modify (&block, resvar, tmp);
2009   gfc_add_block_to_block (&block, &arrayse.post);
2010
2011   if (maskss)
2012     {
2013       /* We enclose the above in if (mask) {...} .  */
2014       tmp = gfc_finish_block (&block);
2015
2016       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2017                       build_empty_stmt (input_location));
2018     }
2019   else
2020     tmp = gfc_finish_block (&block);
2021   gfc_add_expr_to_block (&body, tmp);
2022
2023   gfc_trans_scalarizing_loops (&loop, &body);
2024
2025   /* For a scalar mask, enclose the loop in an if statement.  */
2026   if (maskexpr && maskss == NULL)
2027     {
2028       gfc_init_se (&maskse, NULL);
2029       gfc_conv_expr_val (&maskse, maskexpr);
2030       gfc_init_block (&block);
2031       gfc_add_block_to_block (&block, &loop.pre);
2032       gfc_add_block_to_block (&block, &loop.post);
2033       tmp = gfc_finish_block (&block);
2034
2035       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2036                       build_empty_stmt (input_location));
2037       gfc_add_expr_to_block (&block, tmp);
2038       gfc_add_block_to_block (&se->pre, &block);
2039     }
2040   else
2041     {
2042       gfc_add_block_to_block (&se->pre, &loop.pre);
2043       gfc_add_block_to_block (&se->pre, &loop.post);
2044     }
2045
2046   gfc_cleanup_loop (&loop);
2047
2048   se->expr = resvar;
2049 }
2050
2051
2052 /* Inline implementation of the dot_product intrinsic. This function
2053    is based on gfc_conv_intrinsic_arith (the previous function).  */
2054 static void
2055 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2056 {
2057   tree resvar;
2058   tree type;
2059   stmtblock_t body;
2060   stmtblock_t block;
2061   tree tmp;
2062   gfc_loopinfo loop;
2063   gfc_actual_arglist *actual;
2064   gfc_ss *arrayss1, *arrayss2;
2065   gfc_se arrayse1, arrayse2;
2066   gfc_expr *arrayexpr1, *arrayexpr2;
2067
2068   type = gfc_typenode_for_spec (&expr->ts);
2069
2070   /* Initialize the result.  */
2071   resvar = gfc_create_var (type, "val");
2072   if (expr->ts.type == BT_LOGICAL)
2073     tmp = build_int_cst (type, 0);
2074   else
2075     tmp = gfc_build_const (type, integer_zero_node);
2076
2077   gfc_add_modify (&se->pre, resvar, tmp);
2078
2079   /* Walk argument #1.  */
2080   actual = expr->value.function.actual;
2081   arrayexpr1 = actual->expr;
2082   arrayss1 = gfc_walk_expr (arrayexpr1);
2083   gcc_assert (arrayss1 != gfc_ss_terminator);
2084
2085   /* Walk argument #2.  */
2086   actual = actual->next;
2087   arrayexpr2 = actual->expr;
2088   arrayss2 = gfc_walk_expr (arrayexpr2);
2089   gcc_assert (arrayss2 != gfc_ss_terminator);
2090
2091   /* Initialize the scalarizer.  */
2092   gfc_init_loopinfo (&loop);
2093   gfc_add_ss_to_loop (&loop, arrayss1);
2094   gfc_add_ss_to_loop (&loop, arrayss2);
2095
2096   /* Initialize the loop.  */
2097   gfc_conv_ss_startstride (&loop);
2098   gfc_conv_loop_setup (&loop, &expr->where);
2099
2100   gfc_mark_ss_chain_used (arrayss1, 1);
2101   gfc_mark_ss_chain_used (arrayss2, 1);
2102
2103   /* Generate the loop body.  */
2104   gfc_start_scalarized_body (&loop, &body);
2105   gfc_init_block (&block);
2106
2107   /* Make the tree expression for [conjg(]array1[)].  */
2108   gfc_init_se (&arrayse1, NULL);
2109   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2110   arrayse1.ss = arrayss1;
2111   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2112   if (expr->ts.type == BT_COMPLEX)
2113     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2114   gfc_add_block_to_block (&block, &arrayse1.pre);
2115
2116   /* Make the tree expression for array2.  */
2117   gfc_init_se (&arrayse2, NULL);
2118   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2119   arrayse2.ss = arrayss2;
2120   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2121   gfc_add_block_to_block (&block, &arrayse2.pre);
2122
2123   /* Do the actual product and sum.  */
2124   if (expr->ts.type == BT_LOGICAL)
2125     {
2126       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2127       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2128     }
2129   else
2130     {
2131       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2132       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2133     }
2134   gfc_add_modify (&block, resvar, tmp);
2135
2136   /* Finish up the loop block and the loop.  */
2137   tmp = gfc_finish_block (&block);
2138   gfc_add_expr_to_block (&body, tmp);
2139
2140   gfc_trans_scalarizing_loops (&loop, &body);
2141   gfc_add_block_to_block (&se->pre, &loop.pre);
2142   gfc_add_block_to_block (&se->pre, &loop.post);
2143   gfc_cleanup_loop (&loop);
2144
2145   se->expr = resvar;
2146 }
2147
2148
2149 static void
2150 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2151 {
2152   stmtblock_t body;
2153   stmtblock_t block;
2154   stmtblock_t ifblock;
2155   stmtblock_t elseblock;
2156   tree limit;
2157   tree type;
2158   tree tmp;
2159   tree elsetmp;
2160   tree ifbody;
2161   tree offset;
2162   gfc_loopinfo loop;
2163   gfc_actual_arglist *actual;
2164   gfc_ss *arrayss;
2165   gfc_ss *maskss;
2166   gfc_se arrayse;
2167   gfc_se maskse;
2168   gfc_expr *arrayexpr;
2169   gfc_expr *maskexpr;
2170   tree pos;
2171   int n;
2172
2173   if (se->ss)
2174     {
2175       gfc_conv_intrinsic_funcall (se, expr);
2176       return;
2177     }
2178
2179   /* Initialize the result.  */
2180   pos = gfc_create_var (gfc_array_index_type, "pos");
2181   offset = gfc_create_var (gfc_array_index_type, "offset");
2182   type = gfc_typenode_for_spec (&expr->ts);
2183
2184   /* Walk the arguments.  */
2185   actual = expr->value.function.actual;
2186   arrayexpr = actual->expr;
2187   arrayss = gfc_walk_expr (arrayexpr);
2188   gcc_assert (arrayss != gfc_ss_terminator);
2189
2190   actual = actual->next->next;
2191   gcc_assert (actual);
2192   maskexpr = actual->expr;
2193   if (maskexpr && maskexpr->rank != 0)
2194     {
2195       maskss = gfc_walk_expr (maskexpr);
2196       gcc_assert (maskss != gfc_ss_terminator);
2197     }
2198   else
2199     maskss = NULL;
2200
2201   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2202   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2203   switch (arrayexpr->ts.type)
2204     {
2205     case BT_REAL:
2206       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2207                                    arrayexpr->ts.kind, 0);
2208       break;
2209
2210     case BT_INTEGER:
2211       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2212                                   arrayexpr->ts.kind);
2213       break;
2214
2215     default:
2216       gcc_unreachable ();
2217     }
2218
2219   /* We start with the most negative possible value for MAXLOC, and the most
2220      positive possible value for MINLOC. The most negative possible value is
2221      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2222      possible value is HUGE in both cases.  */
2223   if (op == GT_EXPR)
2224     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2225   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2226     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2227                        build_int_cst (type, 1));
2228
2229   gfc_add_modify (&se->pre, limit, tmp);
2230
2231   /* Initialize the scalarizer.  */
2232   gfc_init_loopinfo (&loop);
2233   gfc_add_ss_to_loop (&loop, arrayss);
2234   if (maskss)
2235     gfc_add_ss_to_loop (&loop, maskss);
2236
2237   /* Initialize the loop.  */
2238   gfc_conv_ss_startstride (&loop);
2239   gfc_conv_loop_setup (&loop, &expr->where);
2240
2241   gcc_assert (loop.dimen == 1);
2242
2243   /* Initialize the position to zero, following Fortran 2003.  We are free
2244      to do this because Fortran 95 allows the result of an entirely false
2245      mask to be processor dependent.  */
2246   gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2247
2248   gfc_mark_ss_chain_used (arrayss, 1);
2249   if (maskss)
2250     gfc_mark_ss_chain_used (maskss, 1);
2251   /* Generate the loop body.  */
2252   gfc_start_scalarized_body (&loop, &body);
2253
2254   /* If we have a mask, only check this element if the mask is set.  */
2255   if (maskss)
2256     {
2257       gfc_init_se (&maskse, NULL);
2258       gfc_copy_loopinfo_to_se (&maskse, &loop);
2259       maskse.ss = maskss;
2260       gfc_conv_expr_val (&maskse, maskexpr);
2261       gfc_add_block_to_block (&body, &maskse.pre);
2262
2263       gfc_start_block (&block);
2264     }
2265   else
2266     gfc_init_block (&block);
2267
2268   /* Compare with the current limit.  */
2269   gfc_init_se (&arrayse, NULL);
2270   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2271   arrayse.ss = arrayss;
2272   gfc_conv_expr_val (&arrayse, arrayexpr);
2273   gfc_add_block_to_block (&block, &arrayse.pre);
2274
2275   /* We do the following if this is a more extreme value.  */
2276   gfc_start_block (&ifblock);
2277
2278   /* Assign the value to the limit...  */
2279   gfc_add_modify (&ifblock, limit, arrayse.expr);
2280
2281   /* Remember where we are.  An offset must be added to the loop
2282      counter to obtain the required position.  */
2283   if (loop.from[0])
2284     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2285                        gfc_index_one_node, loop.from[0]);
2286   else
2287     tmp = gfc_index_one_node;
2288
2289   gfc_add_modify (&block, offset, tmp);
2290
2291   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2292                      loop.loopvar[0], offset);
2293   gfc_add_modify (&ifblock, pos, tmp);
2294
2295   ifbody = gfc_finish_block (&ifblock);
2296
2297   /* If it is a more extreme value or pos is still zero and the value
2298      equal to the limit.  */
2299   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2300                      fold_build2 (EQ_EXPR, boolean_type_node,
2301                                   pos, gfc_index_zero_node),
2302                      fold_build2 (EQ_EXPR, boolean_type_node,
2303                                   arrayse.expr, limit));
2304   tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2305                      fold_build2 (op, boolean_type_node,
2306                                   arrayse.expr, limit), tmp);
2307   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location));
2308   gfc_add_expr_to_block (&block, tmp);
2309
2310   if (maskss)
2311     {
2312       /* We enclose the above in if (mask) {...}.  */
2313       tmp = gfc_finish_block (&block);
2314
2315       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2316                       build_empty_stmt (input_location));
2317     }
2318   else
2319     tmp = gfc_finish_block (&block);
2320   gfc_add_expr_to_block (&body, tmp);
2321
2322   gfc_trans_scalarizing_loops (&loop, &body);
2323
2324   /* For a scalar mask, enclose the loop in an if statement.  */
2325   if (maskexpr && maskss == NULL)
2326     {
2327       gfc_init_se (&maskse, NULL);
2328       gfc_conv_expr_val (&maskse, maskexpr);
2329       gfc_init_block (&block);
2330       gfc_add_block_to_block (&block, &loop.pre);
2331       gfc_add_block_to_block (&block, &loop.post);
2332       tmp = gfc_finish_block (&block);
2333
2334       /* For the else part of the scalar mask, just initialize
2335          the pos variable the same way as above.  */
2336
2337       gfc_init_block (&elseblock);
2338       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2339       elsetmp = gfc_finish_block (&elseblock);
2340
2341       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2342       gfc_add_expr_to_block (&block, tmp);
2343       gfc_add_block_to_block (&se->pre, &block);
2344     }
2345   else
2346     {
2347       gfc_add_block_to_block (&se->pre, &loop.pre);
2348       gfc_add_block_to_block (&se->pre, &loop.post);
2349     }
2350   gfc_cleanup_loop (&loop);
2351
2352   se->expr = convert (type, pos);
2353 }
2354
2355 static void
2356 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2357 {
2358   tree limit;
2359   tree type;
2360   tree tmp;
2361   tree ifbody;
2362   stmtblock_t body;
2363   stmtblock_t block;
2364   gfc_loopinfo loop;
2365   gfc_actual_arglist *actual;
2366   gfc_ss *arrayss;
2367   gfc_ss *maskss;
2368   gfc_se arrayse;
2369   gfc_se maskse;
2370   gfc_expr *arrayexpr;
2371   gfc_expr *maskexpr;
2372   int n;
2373
2374   if (se->ss)
2375     {
2376       gfc_conv_intrinsic_funcall (se, expr);
2377       return;
2378     }
2379
2380   type = gfc_typenode_for_spec (&expr->ts);
2381   /* Initialize the result.  */
2382   limit = gfc_create_var (type, "limit");
2383   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2384   switch (expr->ts.type)
2385     {
2386     case BT_REAL:
2387       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
2388       break;
2389
2390     case BT_INTEGER:
2391       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2392       break;
2393
2394     default:
2395       gcc_unreachable ();
2396     }
2397
2398   /* We start with the most negative possible value for MAXVAL, and the most
2399      positive possible value for MINVAL. The most negative possible value is
2400      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2401      possible value is HUGE in both cases.  */
2402   if (op == GT_EXPR)
2403     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2404
2405   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2406     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2407                        tmp, build_int_cst (type, 1));
2408
2409   gfc_add_modify (&se->pre, limit, tmp);
2410
2411   /* Walk the arguments.  */
2412   actual = expr->value.function.actual;
2413   arrayexpr = actual->expr;
2414   arrayss = gfc_walk_expr (arrayexpr);
2415   gcc_assert (arrayss != gfc_ss_terminator);
2416
2417   actual = actual->next->next;
2418   gcc_assert (actual);
2419   maskexpr = actual->expr;
2420   if (maskexpr && maskexpr->rank != 0)
2421     {
2422       maskss = gfc_walk_expr (maskexpr);
2423       gcc_assert (maskss != gfc_ss_terminator);
2424     }
2425   else
2426     maskss = NULL;
2427
2428   /* Initialize the scalarizer.  */
2429   gfc_init_loopinfo (&loop);
2430   gfc_add_ss_to_loop (&loop, arrayss);
2431   if (maskss)
2432     gfc_add_ss_to_loop (&loop, maskss);
2433
2434   /* Initialize the loop.  */
2435   gfc_conv_ss_startstride (&loop);
2436   gfc_conv_loop_setup (&loop, &expr->where);
2437
2438   gfc_mark_ss_chain_used (arrayss, 1);
2439   if (maskss)
2440     gfc_mark_ss_chain_used (maskss, 1);
2441   /* Generate the loop body.  */
2442   gfc_start_scalarized_body (&loop, &body);
2443
2444   /* If we have a mask, only add this element if the mask is set.  */
2445   if (maskss)
2446     {
2447       gfc_init_se (&maskse, NULL);
2448       gfc_copy_loopinfo_to_se (&maskse, &loop);
2449       maskse.ss = maskss;
2450       gfc_conv_expr_val (&maskse, maskexpr);
2451       gfc_add_block_to_block (&body, &maskse.pre);
2452
2453       gfc_start_block (&block);
2454     }
2455   else
2456     gfc_init_block (&block);
2457
2458   /* Compare with the current limit.  */
2459   gfc_init_se (&arrayse, NULL);
2460   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2461   arrayse.ss = arrayss;
2462   gfc_conv_expr_val (&arrayse, arrayexpr);
2463   gfc_add_block_to_block (&block, &arrayse.pre);
2464
2465   /* Assign the value to the limit...  */
2466   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2467
2468   /* If it is a more extreme value.  */
2469   tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2470   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt (input_location));
2471   gfc_add_expr_to_block (&block, tmp);
2472   gfc_add_block_to_block (&block, &arrayse.post);
2473
2474   tmp = gfc_finish_block (&block);
2475   if (maskss)
2476     /* We enclose the above in if (mask) {...}.  */
2477     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2478                     build_empty_stmt (input_location));
2479   gfc_add_expr_to_block (&body, tmp);
2480
2481   gfc_trans_scalarizing_loops (&loop, &body);
2482
2483   /* For a scalar mask, enclose the loop in an if statement.  */
2484   if (maskexpr && maskss == NULL)
2485     {
2486       gfc_init_se (&maskse, NULL);
2487       gfc_conv_expr_val (&maskse, maskexpr);
2488       gfc_init_block (&block);
2489       gfc_add_block_to_block (&block, &loop.pre);
2490       gfc_add_block_to_block (&block, &loop.post);
2491       tmp = gfc_finish_block (&block);
2492
2493       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2494                       build_empty_stmt (input_location));
2495       gfc_add_expr_to_block (&block, tmp);
2496       gfc_add_block_to_block (&se->pre, &block);
2497     }
2498   else
2499     {
2500       gfc_add_block_to_block (&se->pre, &loop.pre);
2501       gfc_add_block_to_block (&se->pre, &loop.post);
2502     }
2503
2504   gfc_cleanup_loop (&loop);
2505
2506   se->expr = limit;
2507 }
2508
2509 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2510 static void
2511 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2512 {
2513   tree args[2];
2514   tree type;
2515   tree tmp;
2516
2517   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2518   type = TREE_TYPE (args[0]);
2519
2520   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2521   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2522   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2523                      build_int_cst (type, 0));
2524   type = gfc_typenode_for_spec (&expr->ts);
2525   se->expr = convert (type, tmp);
2526 }
2527
2528 /* Generate code to perform the specified operation.  */
2529 static void
2530 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
2531 {
2532   tree args[2];
2533
2534   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2535   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2536 }
2537
2538 /* Bitwise not.  */
2539 static void
2540 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2541 {
2542   tree arg;
2543
2544   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2545   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2546 }
2547
2548 /* Set or clear a single bit.  */
2549 static void
2550 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2551 {
2552   tree args[2];
2553   tree type;
2554   tree tmp;
2555   enum tree_code op;
2556
2557   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2558   type = TREE_TYPE (args[0]);
2559
2560   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2561   if (set)
2562     op = BIT_IOR_EXPR;
2563   else
2564     {
2565       op = BIT_AND_EXPR;
2566       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2567     }
2568   se->expr = fold_build2 (op, type, args[0], tmp);
2569 }
2570
2571 /* Extract a sequence of bits.
2572     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2573 static void
2574 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2575 {
2576   tree args[3];
2577   tree type;
2578   tree tmp;
2579   tree mask;
2580
2581   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2582   type = TREE_TYPE (args[0]);
2583
2584   mask = build_int_cst (type, -1);
2585   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2586   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2587
2588   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2589
2590   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2591 }
2592
2593 /* RSHIFT (I, SHIFT) = I >> SHIFT
2594    LSHIFT (I, SHIFT) = I << SHIFT  */
2595 static void
2596 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2597 {
2598   tree args[2];
2599
2600   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2601
2602   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2603                           TREE_TYPE (args[0]), args[0], args[1]);
2604 }
2605
2606 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2607                         ? 0
2608                         : ((shift >= 0) ? i << shift : i >> -shift)
2609    where all shifts are logical shifts.  */
2610 static void
2611 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2612 {
2613   tree args[2];
2614   tree type;
2615   tree utype;
2616   tree tmp;
2617   tree width;
2618   tree num_bits;
2619   tree cond;
2620   tree lshift;
2621   tree rshift;
2622
2623   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2624   type = TREE_TYPE (args[0]);
2625   utype = unsigned_type_for (type);
2626
2627   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2628
2629   /* Left shift if positive.  */
2630   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2631
2632   /* Right shift if negative.
2633      We convert to an unsigned type because we want a logical shift.
2634      The standard doesn't define the case of shifting negative
2635      numbers, and we try to be compatible with other compilers, most
2636      notably g77, here.  */
2637   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
2638                                             convert (utype, args[0]), width));
2639
2640   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2641                      build_int_cst (TREE_TYPE (args[1]), 0));
2642   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2643
2644   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2645      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2646      special case.  */
2647   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
2648   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2649
2650   se->expr = fold_build3 (COND_EXPR, type, cond,
2651                           build_int_cst (type, 0), tmp);
2652 }
2653
2654
2655 /* Circular shift.  AKA rotate or barrel shift.  */
2656
2657 static void
2658 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2659 {
2660   tree *args;
2661   tree type;
2662   tree tmp;
2663   tree lrot;
2664   tree rrot;
2665   tree zero;
2666   unsigned int num_args;
2667
2668   num_args = gfc_intrinsic_argument_list_length (expr);
2669   args = (tree *) alloca (sizeof (tree) * num_args);
2670
2671   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2672
2673   if (num_args == 3)
2674     {
2675       /* Use a library function for the 3 parameter version.  */
2676       tree int4type = gfc_get_int_type (4);
2677
2678       type = TREE_TYPE (args[0]);
2679       /* We convert the first argument to at least 4 bytes, and
2680          convert back afterwards.  This removes the need for library
2681          functions for all argument sizes, and function will be
2682          aligned to at least 32 bits, so there's no loss.  */
2683       if (expr->ts.kind < 4)
2684         args[0] = convert (int4type, args[0]);
2685
2686       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2687          need loads of library  functions.  They cannot have values >
2688          BIT_SIZE (I) so the conversion is safe.  */
2689       args[1] = convert (int4type, args[1]);
2690       args[2] = convert (int4type, args[2]);
2691
2692       switch (expr->ts.kind)
2693         {
2694         case 1:
2695         case 2:
2696         case 4:
2697           tmp = gfor_fndecl_math_ishftc4;
2698           break;
2699         case 8:
2700           tmp = gfor_fndecl_math_ishftc8;
2701           break;
2702         case 16:
2703           tmp = gfor_fndecl_math_ishftc16;
2704           break;
2705         default:
2706           gcc_unreachable ();
2707         }
2708       se->expr = build_call_expr_loc (input_location,
2709                                   tmp, 3, args[0], args[1], args[2]);
2710       /* Convert the result back to the original type, if we extended
2711          the first argument's width above.  */
2712       if (expr->ts.kind < 4)
2713         se->expr = convert (type, se->expr);
2714
2715       return;
2716     }
2717   type = TREE_TYPE (args[0]);
2718
2719   /* Rotate left if positive.  */
2720   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2721
2722   /* Rotate right if negative.  */
2723   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2724   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2725
2726   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2727   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2728   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2729
2730   /* Do nothing if shift == 0.  */
2731   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2732   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2733 }
2734
2735 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2736                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2737
2738    The conditional expression is necessary because the result of LEADZ(0)
2739    is defined, but the result of __builtin_clz(0) is undefined for most
2740    targets.
2741
2742    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2743    difference in bit size between the argument of LEADZ and the C int.  */
2744
2745 static void
2746 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
2747 {
2748   tree arg;
2749   tree arg_type;
2750   tree cond;
2751   tree result_type;
2752   tree leadz;
2753   tree bit_size;
2754   tree tmp;
2755   tree func;
2756   int s, argsize;
2757
2758   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2759   argsize = TYPE_PRECISION (TREE_TYPE (arg));
2760
2761   /* Which variant of __builtin_clz* should we call?  */
2762   if (argsize <= INT_TYPE_SIZE)
2763     {
2764       arg_type = unsigned_type_node;
2765       func = built_in_decls[BUILT_IN_CLZ];
2766     }
2767   else if (argsize <= LONG_TYPE_SIZE)
2768     {
2769       arg_type = long_unsigned_type_node;
2770       func = built_in_decls[BUILT_IN_CLZL];
2771     }
2772   else if (argsize <= LONG_LONG_TYPE_SIZE)
2773     {
2774       arg_type = long_long_unsigned_type_node;
2775       func = built_in_decls[BUILT_IN_CLZLL];
2776     }
2777   else
2778     {
2779       gcc_assert (argsize == 128);
2780       arg_type = gfc_build_uint_type (argsize);
2781       func = gfor_fndecl_clz128;
2782     }
2783
2784   /* Convert the actual argument twice: first, to the unsigned type of the
2785      same size; then, to the proper argument type for the built-in
2786      function.  But the return type is of the default INTEGER kind.  */
2787   arg = fold_convert (gfc_build_uint_type (argsize), arg);
2788   arg = fold_convert (arg_type, arg);
2789   result_type = gfc_get_int_type (gfc_default_integer_kind);
2790
2791   /* Compute LEADZ for the case i .ne. 0.  */
2792   s = TYPE_PRECISION (arg_type) - argsize;
2793   tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
2794   leadz = fold_build2 (MINUS_EXPR, result_type,
2795                        tmp, build_int_cst (result_type, s));
2796
2797   /* Build BIT_SIZE.  */
2798   bit_size = build_int_cst (result_type, argsize);
2799
2800   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2801                       arg, build_int_cst (arg_type, 0));
2802   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
2803 }
2804
2805 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2806
2807    The conditional expression is necessary because the result of TRAILZ(0)
2808    is defined, but the result of __builtin_ctz(0) is undefined for most
2809    targets.  */
2810
2811 static void
2812 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
2813 {
2814   tree arg;
2815   tree arg_type;
2816   tree cond;
2817   tree result_type;
2818   tree trailz;
2819   tree bit_size;
2820   tree func;
2821   int argsize;
2822
2823   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2824   argsize = TYPE_PRECISION (TREE_TYPE (arg));
2825
2826   /* Which variant of __builtin_ctz* should we call?  */
2827   if (argsize <= INT_TYPE_SIZE)
2828     {
2829       arg_type = unsigned_type_node;
2830       func = built_in_decls[BUILT_IN_CTZ];
2831     }
2832   else if (argsize <= LONG_TYPE_SIZE)
2833     {
2834       arg_type = long_unsigned_type_node;
2835       func = built_in_decls[BUILT_IN_CTZL];
2836     }
2837   else if (argsize <= LONG_LONG_TYPE_SIZE)
2838     {
2839       arg_type = long_long_unsigned_type_node;
2840       func = built_in_decls[BUILT_IN_CTZLL];
2841     }
2842   else
2843     {
2844       gcc_assert (argsize == 128);
2845       arg_type = gfc_build_uint_type (argsize);
2846       func = gfor_fndecl_ctz128;
2847     }
2848
2849   /* Convert the actual argument twice: first, to the unsigned type of the
2850      same size; then, to the proper argument type for the built-in
2851      function.  But the return type is of the default INTEGER kind.  */
2852   arg = fold_convert (gfc_build_uint_type (argsize), arg);
2853   arg = fold_convert (arg_type, arg);
2854   result_type = gfc_get_int_type (gfc_default_integer_kind);
2855
2856   /* Compute TRAILZ for the case i .ne. 0.  */
2857   trailz = fold_convert (result_type, build_call_expr_loc (input_location,
2858                                                        func, 1, arg));
2859
2860   /* Build BIT_SIZE.  */
2861   bit_size = build_int_cst (result_type, argsize);
2862
2863   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2864                       arg, build_int_cst (arg_type, 0));
2865   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
2866 }
2867
2868 /* Process an intrinsic with unspecified argument-types that has an optional
2869    argument (which could be of type character), e.g. EOSHIFT.  For those, we
2870    need to append the string length of the optional argument if it is not
2871    present and the type is really character.
2872    primary specifies the position (starting at 1) of the non-optional argument
2873    specifying the type and optional gives the position of the optional
2874    argument in the arglist.  */
2875
2876 static void
2877 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
2878                                      unsigned primary, unsigned optional)
2879 {
2880   gfc_actual_arglist* prim_arg;
2881   gfc_actual_arglist* opt_arg;
2882   unsigned cur_pos;
2883   gfc_actual_arglist* arg;
2884   gfc_symbol* sym;
2885   tree append_args;
2886
2887   /* Find the two arguments given as position.  */
2888   cur_pos = 0;
2889   prim_arg = NULL;
2890   opt_arg = NULL;
2891   for (arg = expr->value.function.actual; arg; arg = arg->next)
2892     {
2893       ++cur_pos;
2894
2895       if (cur_pos == primary)
2896         prim_arg = arg;
2897       if (cur_pos == optional)
2898         opt_arg = arg;
2899
2900       if (cur_pos >= primary && cur_pos >= optional)
2901         break;
2902     }
2903   gcc_assert (prim_arg);
2904   gcc_assert (prim_arg->expr);
2905   gcc_assert (opt_arg);
2906
2907   /* If we do have type CHARACTER and the optional argument is really absent,
2908      append a dummy 0 as string length.  */
2909   append_args = NULL_TREE;
2910   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
2911     {
2912       tree dummy;
2913
2914       dummy = build_int_cst (gfc_charlen_type_node, 0);
2915       append_args = gfc_chainon_list (append_args, dummy);
2916     }
2917
2918   /* Build the call itself.  */
2919   sym = gfc_get_symbol_for_expr (expr);
2920   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2921                           append_args);
2922   gfc_free (sym);
2923 }
2924
2925
2926 /* The length of a character string.  */
2927 static void
2928 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2929 {
2930   tree len;
2931   tree type;
2932   tree decl;
2933   gfc_symbol *sym;
2934   gfc_se argse;
2935   gfc_expr *arg;
2936   gfc_ss *ss;
2937
2938   gcc_assert (!se->ss);
2939
2940   arg = expr->value.function.actual->expr;
2941
2942   type = gfc_typenode_for_spec (&expr->ts);
2943   switch (arg->expr_type)
2944     {
2945     case EXPR_CONSTANT:
2946       len = build_int_cst (NULL_TREE, arg->value.character.length);
2947       break;
2948
2949     case EXPR_ARRAY:
2950       /* Obtain the string length from the function used by
2951          trans-array.c(gfc_trans_array_constructor).  */
2952       len = NULL_TREE;
2953       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2954       break;
2955
2956     case EXPR_VARIABLE:
2957       if (arg->ref == NULL
2958             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2959         {
2960           /* This doesn't catch all cases.
2961              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2962              and the surrounding thread.  */
2963           sym = arg->symtree->n.sym;
2964           decl = gfc_get_symbol_decl (sym);
2965           if (decl == current_function_decl && sym->attr.function
2966                 && (sym->result == sym))
2967             decl = gfc_get_fake_result_decl (sym, 0);
2968
2969           len = sym->ts.cl->backend_decl;
2970           gcc_assert (len);
2971           break;
2972         }
2973
2974       /* Otherwise fall through.  */
2975
2976     default:
2977       /* Anybody stupid enough to do this deserves inefficient code.  */
2978       ss = gfc_walk_expr (arg);
2979       gfc_init_se (&argse, se);
2980       if (ss == gfc_ss_terminator)
2981         gfc_conv_expr (&argse, arg);
2982       else
2983         gfc_conv_expr_descriptor (&argse, arg, ss);
2984       gfc_add_block_to_block (&se->pre, &argse.pre);
2985       gfc_add_block_to_block (&se->post, &argse.post);
2986       len = argse.string_length;
2987       break;
2988     }
2989   se->expr = convert (type, len);
2990 }
2991
2992 /* The length of a character string not including trailing blanks.  */
2993 static void
2994 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2995 {
2996   int kind = expr->value.function.actual->expr->ts.kind;
2997   tree args[2], type, fndecl;
2998
2999   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3000   type = gfc_typenode_for_spec (&expr->ts);
3001
3002   if (kind == 1)
3003     fndecl = gfor_fndecl_string_len_trim;
3004   else if (kind == 4)
3005     fndecl = gfor_fndecl_string_len_trim_char4;
3006   else
3007     gcc_unreachable ();
3008
3009   se->expr = build_call_expr_loc (input_location,
3010                               fndecl, 2, args[0], args[1]);
3011   se->expr = convert (type, se->expr);
3012 }
3013
3014
3015 /* Returns the starting position of a substring within a string.  */
3016
3017 static void
3018 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3019                                       tree function)
3020 {
3021   tree logical4_type_node = gfc_get_logical_type (4);
3022   tree type;
3023   tree fndecl;
3024   tree *args;
3025   unsigned int num_args;
3026
3027   args = (tree *) alloca (sizeof (tree) * 5);
3028
3029   /* Get number of arguments; characters count double due to the
3030      string length argument. Kind= is not passed to the library
3031      and thus ignored.  */
3032   if (expr->value.function.actual->next->next->expr == NULL)
3033     num_args = 4;
3034   else
3035     num_args = 5;
3036
3037   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3038   type = gfc_typenode_for_spec (&expr->ts);
3039
3040   if (num_args == 4)
3041     args[4] = build_int_cst (logical4_type_node, 0);
3042   else
3043     args[4] = convert (logical4_type_node, args[4]);
3044
3045   fndecl = build_addr (function, current_function_decl);
3046   se->expr = build_call_array_loc (input_location,
3047                                TREE_TYPE (TREE_TYPE (function)), fndecl,
3048                                5, args);
3049   se->expr = convert (type, se->expr);
3050
3051 }
3052
3053 /* The ascii value for a single character.  */
3054 static void
3055 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3056 {
3057   tree args[2], type, pchartype;
3058
3059   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3060   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3061   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3062   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3063   type = gfc_typenode_for_spec (&expr->ts);
3064
3065   se->expr = build_fold_indirect_ref_loc (input_location,
3066                                       args[1]);
3067   se->expr = convert (type, se->expr);
3068 }
3069
3070
3071 /* Intrinsic ISNAN calls __builtin_isnan.  */
3072
3073 static void
3074 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3075 {
3076   tree arg;
3077
3078   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3079   se->expr = build_call_expr_loc (input_location,
3080                               built_in_decls[BUILT_IN_ISNAN], 1, arg);
3081   STRIP_TYPE_NOPS (se->expr);
3082   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3083 }
3084
3085
3086 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3087    their argument against a constant integer value.  */
3088
3089 static void
3090 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3091 {
3092   tree arg;
3093
3094   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3095   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3096                           arg, build_int_cst (TREE_TYPE (arg), value));
3097 }
3098
3099
3100
3101 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3102
3103 static void
3104 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3105 {
3106   tree tsource;
3107   tree fsource;
3108   tree mask;
3109   tree type;
3110   tree len, len2;
3111   tree *args;
3112   unsigned int num_args;
3113
3114   num_args = gfc_intrinsic_argument_list_length (expr);
3115   args = (tree *) alloca (sizeof (tree) * num_args);
3116
3117   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3118   if (expr->ts.type != BT_CHARACTER)
3119     {
3120       tsource = args[0];
3121       fsource = args[1];
3122       mask = args[2];
3123     }
3124   else
3125     {
3126       /* We do the same as in the non-character case, but the argument
3127          list is different because of the string length arguments. We
3128          also have to set the string length for the result.  */
3129       len = args[0];
3130       tsource = args[1];
3131       len2 = args[2];
3132       fsource = args[3];
3133       mask = args[4];
3134
3135       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3136                                    &se->pre);
3137       se->string_length = len;
3138     }
3139   type = TREE_TYPE (tsource);
3140   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3141                           fold_convert (type, fsource));
3142 }
3143
3144
3145 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3146 static void
3147 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3148 {
3149   tree arg, type, tmp;
3150   int frexp;
3151
3152   switch (expr->ts.kind)
3153     {
3154       case 4:
3155         frexp = BUILT_IN_FREXPF;
3156         break;
3157       case 8:
3158         frexp = BUILT_IN_FREXP;
3159         break;
3160       case 10:
3161       case 16:
3162         frexp = BUILT_IN_FREXPL;
3163         break;
3164       default:
3165         gcc_unreachable ();
3166     }
3167
3168   type = gfc_typenode_for_spec (&expr->ts);
3169   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3170   tmp = gfc_create_var (integer_type_node, NULL);
3171   se->expr = build_call_expr_loc (input_location,
3172                               built_in_decls[frexp], 2,
3173                               fold_convert (type, arg),
3174                               gfc_build_addr_expr (NULL_TREE, tmp));
3175   se->expr = fold_convert (type, se->expr);
3176 }
3177
3178
3179 /* NEAREST (s, dir) is translated into
3180      tmp = copysign (HUGE_VAL, dir);
3181      return nextafter (s, tmp);
3182  */
3183 static void
3184 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3185 {
3186   tree args[2], type, tmp;
3187   int nextafter, copysign, huge_val;
3188
3189   switch (expr->ts.kind)
3190     {
3191       case 4:
3192         nextafter = BUILT_IN_NEXTAFTERF;
3193         copysign = BUILT_IN_COPYSIGNF;
3194         huge_val = BUILT_IN_HUGE_VALF;
3195         break;
3196       case 8:
3197         nextafter = BUILT_IN_NEXTAFTER;
3198         copysign = BUILT_IN_COPYSIGN;
3199         huge_val = BUILT_IN_HUGE_VAL;
3200         break;
3201       case 10:
3202       case 16:
3203         nextafter = BUILT_IN_NEXTAFTERL;
3204         copysign = BUILT_IN_COPYSIGNL;
3205         huge_val = BUILT_IN_HUGE_VALL;
3206         break;
3207       default:
3208         gcc_unreachable ();
3209     }
3210
3211   type = gfc_typenode_for_spec (&expr->ts);
3212   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3213   tmp = build_call_expr_loc (input_location,
3214                          built_in_decls[copysign], 2,
3215                          build_call_expr_loc (input_location,
3216                                           built_in_decls[huge_val], 0),
3217                          fold_convert (type, args[1]));
3218   se->expr = build_call_expr_loc (input_location,
3219                               built_in_decls[nextafter], 2,
3220                               fold_convert (type, args[0]), tmp);
3221   se->expr = fold_convert (type, se->expr);
3222 }
3223
3224
3225 /* SPACING (s) is translated into
3226     int e;
3227     if (s == 0)
3228       res = tiny;
3229     else
3230     {
3231       frexp (s, &e);
3232       e = e - prec;
3233       e = MAX_EXPR (e, emin);
3234       res = scalbn (1., e);
3235     }
3236     return res;
3237
3238  where prec is the precision of s, gfc_real_kinds[k].digits,
3239        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3240    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3241
3242 static void
3243 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3244 {
3245   tree arg, type, prec, emin, tiny, res, e;
3246   tree cond, tmp;
3247   int frexp, scalbn, k;
3248   stmtblock_t block;
3249
3250   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3251   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3252   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3253   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3254
3255   switch (expr->ts.kind)
3256     {
3257       case 4:
3258         frexp = BUILT_IN_FREXPF;
3259         scalbn = BUILT_IN_SCALBNF;
3260         break;
3261       case 8:
3262         frexp = BUILT_IN_FREXP;
3263         scalbn = BUILT_IN_SCALBN;
3264         break;
3265       case 10:
3266       case 16:
3267         frexp = BUILT_IN_FREXPL;
3268         scalbn = BUILT_IN_SCALBNL;
3269         break;
3270       default:
3271         gcc_unreachable ();
3272     }
3273
3274   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3275   arg = gfc_evaluate_now (arg, &se->pre);
3276
3277   type = gfc_typenode_for_spec (&expr->ts);
3278   e = gfc_create_var (integer_type_node, NULL);
3279   res = gfc_create_var (type, NULL);
3280
3281
3282   /* Build the block for s /= 0.  */
3283   gfc_start_block (&block);
3284   tmp = build_call_expr_loc (input_location,
3285                          built_in_decls[frexp], 2, arg,
3286                          gfc_build_addr_expr (NULL_TREE, e));
3287   gfc_add_expr_to_block (&block, tmp);
3288
3289   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3290   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3291                                           tmp, emin));
3292
3293   tmp = build_call_expr_loc (input_location,
3294                          built_in_decls[scalbn], 2,
3295                          build_real_from_int_cst (type, integer_one_node), e);
3296   gfc_add_modify (&block, res, tmp);
3297
3298   /* Finish by building the IF statement.  */
3299   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3300                       build_real_from_int_cst (type, integer_zero_node));
3301   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3302                   gfc_finish_block (&block));
3303
3304   gfc_add_expr_to_block (&se->pre, tmp);
3305   se->expr = res;
3306 }
3307
3308
3309 /* RRSPACING (s) is translated into
3310       int e;
3311       real x;
3312       x = fabs (s);
3313       if (x != 0)
3314       {
3315         frexp (s, &e);
3316         x = scalbn (x, precision - e);
3317       }
3318       return x;
3319
3320  where precision is gfc_real_kinds[k].digits.  */
3321
3322 static void
3323 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3324 {
3325   tree arg, type, e, x, cond, stmt, tmp;
3326   int frexp, scalbn, fabs, prec, k;
3327   stmtblock_t block;
3328
3329   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3330   prec = gfc_real_kinds[k].digits;
3331   switch (expr->ts.kind)
3332     {
3333       case 4:
3334         frexp = BUILT_IN_FREXPF;
3335         scalbn = BUILT_IN_SCALBNF;
3336         fabs = BUILT_IN_FABSF;
3337         break;
3338       case 8:
3339         frexp = BUILT_IN_FREXP;
3340         scalbn = BUILT_IN_SCALBN;
3341         fabs = BUILT_IN_FABS;
3342         break;
3343       case 10:
3344       case 16:
3345         frexp = BUILT_IN_FREXPL;
3346         scalbn = BUILT_IN_SCALBNL;
3347         fabs = BUILT_IN_FABSL;
3348         break;
3349       default:
3350         gcc_unreachable ();
3351     }
3352
3353   type = gfc_typenode_for_spec (&expr->ts);
3354   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3355   arg = gfc_evaluate_now (arg, &se->pre);
3356
3357   e = gfc_create_var (integer_type_node, NULL);
3358   x = gfc_create_var (type, NULL);
3359   gfc_add_modify (&se->pre, x,
3360                   build_call_expr_loc (input_location,
3361                                    built_in_decls[fabs], 1, arg));
3362
3363
3364   gfc_start_block (&block);
3365   tmp = build_call_expr_loc (input_location,
3366                          built_in_decls[frexp], 2, arg,
3367                          gfc_build_addr_expr (NULL_TREE, e));
3368   gfc_add_expr_to_block (&block, tmp);
3369
3370   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3371                      build_int_cst (NULL_TREE, prec), e);
3372   tmp = build_call_expr_loc (input_location,
3373                          built_in_decls[scalbn], 2, x, tmp);
3374   gfc_add_modify (&block, x, tmp);
3375   stmt = gfc_finish_block (&block);
3376
3377   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3378                       build_real_from_int_cst (type, integer_zero_node));
3379   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3380   gfc_add_expr_to_block (&se->pre, tmp);
3381
3382   se->expr = fold_convert (type, x);
3383 }
3384
3385
3386 /* SCALE (s, i) is translated into scalbn (s, i).  */
3387 static void
3388 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3389 {
3390   tree args[2], type;
3391   int scalbn;
3392
3393   switch (expr->ts.kind)
3394     {
3395       case 4:
3396         scalbn = BUILT_IN_SCALBNF;
3397         break;
3398       case 8:
3399         scalbn = BUILT_IN_SCALBN;
3400         break;
3401       case 10:
3402       case 16:
3403         scalbn = BUILT_IN_SCALBNL;
3404         break;
3405       default:
3406         gcc_unreachable ();
3407     }
3408
3409   type = gfc_typenode_for_spec (&expr->ts);
3410   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3411   se->expr = build_call_expr_loc (input_location,
3412                               built_in_decls[scalbn], 2,
3413                               fold_convert (type, args[0]),
3414                               fold_convert (integer_type_node, args[1]));
3415   se->expr = fold_convert (type, se->expr);
3416 }
3417
3418
3419 /* SET_EXPONENT (s, i) is translated into
3420    scalbn (frexp (s, &dummy_int), i).  */
3421 static void
3422 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3423 {
3424   tree args[2], type, tmp;
3425   int frexp, scalbn;
3426
3427   switch (expr->ts.kind)
3428     {
3429       case 4:
3430         frexp = BUILT_IN_FREXPF;
3431         scalbn = BUILT_IN_SCALBNF;
3432         break;
3433       case 8:
3434         frexp = BUILT_IN_FREXP;
3435         scalbn = BUILT_IN_SCALBN;
3436         break;
3437       case 10:
3438       case 16:
3439         frexp = BUILT_IN_FREXPL;
3440         scalbn = BUILT_IN_SCALBNL;
3441         break;
3442       default:
3443         gcc_unreachable ();
3444     }
3445
3446   type = gfc_typenode_for_spec (&expr->ts);
3447   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3448
3449   tmp = gfc_create_var (integer_type_node, NULL);
3450   tmp = build_call_expr_loc (input_location,
3451                          built_in_decls[frexp], 2,
3452                          fold_convert (type, args[0]),
3453                          gfc_build_addr_expr (NULL_TREE, tmp));
3454   se->expr = build_call_expr_loc (input_location,
3455                               built_in_decls[scalbn], 2, tmp,
3456                               fold_convert (integer_type_node, args[1]));
3457   se->expr = fold_convert (type, se->expr);
3458 }
3459
3460
3461 static void
3462 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3463 {
3464   gfc_actual_arglist *actual;
3465   tree arg1;
3466   tree type;
3467   tree fncall0;
3468   tree fncall1;
3469   gfc_se argse;
3470   gfc_ss *ss;
3471
3472   gfc_init_se (&argse, NULL);
3473   actual = expr->value.function.actual;
3474
3475   ss = gfc_walk_expr (actual->expr);
3476   gcc_assert (ss != gfc_ss_terminator);
3477   argse.want_pointer = 1;
3478   argse.data_not_needed = 1;
3479   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3480   gfc_add_block_to_block (&se->pre, &argse.pre);
3481   gfc_add_block_to_block (&se->post, &argse.post);
3482   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3483
3484   /* Build the call to size0.  */
3485   fncall0 = build_call_expr_loc (input_location,
3486                              gfor_fndecl_size0, 1, arg1);
3487
3488   actual = actual->next;
3489
3490   if (actual->expr)
3491     {
3492       gfc_init_se (&argse, NULL);
3493       gfc_conv_expr_type (&argse, actual->expr,
3494                           gfc_array_index_type);
3495       gfc_add_block_to_block (&se->pre, &argse.pre);
3496
3497       /* Unusually, for an intrinsic, size does not exclude
3498          an optional arg2, so we must test for it.  */
3499       if (actual->expr->expr_type == EXPR_VARIABLE
3500             && actual->expr->symtree->n.sym->attr.dummy
3501             && actual->expr->symtree->n.sym->attr.optional)
3502         {
3503           tree tmp;
3504           /* Build the call to size1.  */
3505           fncall1 = build_call_expr_loc (input_location,
3506                                      gfor_fndecl_size1, 2,
3507                                      arg1, argse.expr);
3508
3509           gfc_init_se (&argse, NULL);
3510           argse.want_pointer = 1;
3511           argse.data_not_needed = 1;
3512           gfc_conv_expr (&argse, actual->expr);
3513           gfc_add_block_to_block (&se->pre, &argse.pre);
3514           tmp = fold_build2 (NE_EXPR, boolean_type_node,
3515                              argse.expr, null_pointer_node);
3516           tmp = gfc_evaluate_now (tmp, &se->pre);
3517           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3518                                   tmp, fncall1, fncall0);
3519         }
3520       else
3521         {
3522           se->expr = NULL_TREE;
3523           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3524                                     argse.expr, gfc_index_one_node);
3525         }
3526     }
3527   else if (expr->value.function.actual->expr->rank == 1)
3528     {
3529       argse.expr = gfc_index_zero_node;
3530       se->expr = NULL_TREE;
3531     }
3532   else
3533     se->expr = fncall0;
3534
3535   if (se->expr == NULL_TREE)
3536     {
3537       tree ubound, lbound;
3538
3539       arg1 = build_fold_indirect_ref_loc (input_location,
3540                                       arg1);
3541       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
3542       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
3543       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3544                               ubound, lbound);
3545       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
3546                               gfc_index_one_node);
3547       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
3548                               gfc_index_zero_node);
3549     }
3550
3551   type = gfc_typenode_for_spec (&expr->ts);
3552   se->expr = convert (type, se->expr);
3553 }
3554
3555
3556 /* Helper function to compute the size of a character variable,
3557    excluding the terminating null characters.  The result has
3558    gfc_array_index_type type.  */
3559
3560 static tree
3561 size_of_string_in_bytes (int kind, tree string_length)
3562 {
3563   tree bytesize;
3564   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
3565
3566   bytesize = build_int_cst (gfc_array_index_type,
3567                             gfc_character_kinds[i].bit_size / 8);
3568
3569   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
3570                       fold_convert (gfc_array_index_type, string_length));
3571 }
3572
3573
3574 static void
3575 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3576 {
3577   gfc_expr *arg;
3578   gfc_ss *ss;
3579   gfc_se argse;
3580   tree source;
3581   tree source_bytes;
3582   tree type;
3583   tree tmp;
3584   tree lower;
3585   tree upper;
3586   int n;
3587
3588   arg = expr->value.function.actual->expr;
3589
3590   gfc_init_se (&argse, NULL);
3591   ss = gfc_walk_expr (arg);
3592
3593   if (ss == gfc_ss_terminator)
3594     {
3595       gfc_conv_expr_reference (&argse, arg);
3596       source = argse.expr;
3597
3598       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
3599                                                  argse.expr));
3600
3601       /* Obtain the source word length.  */
3602       if (arg->ts.type == BT_CHARACTER)
3603         se->expr = size_of_string_in_bytes (arg->ts.kind,
3604                                             argse.string_length);
3605       else
3606         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3607     }
3608   else
3609     {
3610       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3611       argse.want_pointer = 0;
3612       gfc_conv_expr_descriptor (&argse, arg, ss);
3613       source = gfc_conv_descriptor_data_get (argse.expr);
3614       type = gfc_get_element_type (TREE_TYPE (argse.expr));
3615
3616       /* Obtain the argument's word length.  */
3617       if (arg->ts.type == BT_CHARACTER)
3618         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3619       else
3620         tmp = fold_convert (gfc_array_index_type,
3621                             size_in_bytes (type));
3622       gfc_add_modify (&argse.pre, source_bytes, tmp);
3623
3624       /* Obtain the size of the array in bytes.  */
3625       for (n = 0; n < arg->rank; n++)
3626         {
3627           tree idx;
3628           idx = gfc_rank_cst[n];
3629           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
3630           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
3631           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3632                              upper, lower);
3633           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3634                              tmp, gfc_index_one_node);
3635           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3636                              tmp, source_bytes);
3637           gfc_add_modify (&argse.pre, source_bytes, tmp);
3638         }
3639       se->expr = source_bytes;
3640     }
3641
3642   gfc_add_block_to_block (&se->pre, &argse.pre);
3643 }
3644
3645
3646 /* Intrinsic string comparison functions.  */
3647
3648 static void
3649 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3650 {
3651   tree args[4];
3652
3653   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3654
3655   se->expr
3656     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3657                                 expr->value.function.actual->expr->ts.kind);
3658   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3659                           build_int_cst (TREE_TYPE (se->expr), 0));
3660 }
3661
3662 /* Generate a call to the adjustl/adjustr library function.  */
3663 static void
3664 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3665 {
3666   tree args[3];
3667   tree len;
3668   tree type;
3669   tree var;
3670   tree tmp;
3671
3672   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3673   len = args[1];
3674
3675   type = TREE_TYPE (args[2]);
3676   var = gfc_conv_string_tmp (se, type, len);
3677   args[0] = var;
3678
3679   tmp = build_call_expr_loc (input_location,
3680                          fndecl, 3, args[0], args[1], args[2]);
3681   gfc_add_expr_to_block (&se->pre, tmp);
3682   se->expr = var;
3683   se->string_length = len;
3684 }
3685
3686
3687 /* Generate code for the TRANSFER intrinsic:
3688         For scalar results:
3689           DEST = TRANSFER (SOURCE, MOLD)
3690         where:
3691           typeof<DEST> = typeof<MOLD>
3692         and:
3693           MOLD is scalar.
3694
3695         For array results:
3696           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3697         where:
3698           typeof<DEST> = typeof<MOLD>
3699         and:
3700           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3701               sizeof (DEST(0) * SIZE).  */
3702 static void
3703 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3704 {
3705   tree tmp;
3706   tree tmpdecl;
3707   tree ptr;
3708   tree extent;
3709   tree source;
3710   tree source_type;
3711   tree source_bytes;
3712   tree mold_type;
3713   tree dest_word_len;
3714   tree size_words;
3715   tree size_bytes;
3716   tree upper;
3717   tree lower;
3718   tree stride;
3719   tree stmt;
3720   gfc_actual_arglist *arg;
3721   gfc_se argse;
3722   gfc_ss *ss;
3723   gfc_ss_info *info;
3724   stmtblock_t block;
3725   int n;
3726   bool scalar_mold;
3727
3728   info = NULL;
3729   if (se->loop)
3730     info = &se->ss->data.info;
3731
3732   /* Convert SOURCE.  The output from this stage is:-
3733         source_bytes = length of the source in bytes
3734         source = pointer to the source data.  */
3735   arg = expr->value.function.actual;
3736
3737   /* Ensure double transfer through LOGICAL preserves all
3738      the needed bits.  */
3739   if (arg->expr->expr_type == EXPR_FUNCTION
3740         && arg->expr->value.function.esym == NULL
3741         && arg->expr->value.function.isym != NULL
3742         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
3743         && arg->expr->ts.type == BT_LOGICAL
3744         && expr->ts.type != arg->expr->ts.type)
3745     arg->expr->value.function.name = "__transfer_in_transfer";
3746
3747   gfc_init_se (&argse, NULL);
3748   ss = gfc_walk_expr (arg->expr);
3749
3750   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3751
3752   /* Obtain the pointer to source and the length of source in bytes.  */
3753   if (ss == gfc_ss_terminator)
3754     {
3755       gfc_conv_expr_reference (&argse, arg->expr);
3756       source = argse.expr;
3757
3758       source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
3759                                                         argse.expr));
3760
3761       /* Obtain the source word length.  */
3762       if (arg->expr->ts.type == BT_CHARACTER)
3763         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3764                                        argse.string_length);
3765       else
3766         tmp = fold_convert (gfc_array_index_type,
3767                             size_in_bytes (source_type));
3768     }
3769   else
3770     {
3771       argse.want_pointer = 0;
3772       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3773       source = gfc_conv_descriptor_data_get (argse.expr);
3774       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3775
3776       /* Repack the source if not a full variable array.  */
3777       if (arg->expr->expr_type == EXPR_VARIABLE
3778               && arg->expr->ref->u.ar.type != AR_FULL)
3779         {
3780           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
3781
3782           if (gfc_option.warn_array_temp)
3783             gfc_warning ("Creating array temporary at %L", &expr->where);
3784
3785           source = build_call_expr_loc (input_location,
3786                                     gfor_fndecl_in_pack, 1, tmp);
3787           source = gfc_evaluate_now (source, &argse.pre);
3788
3789           /* Free the temporary.  */
3790           gfc_start_block (&block);
3791           tmp = gfc_call_free (convert (pvoid_type_node, source));
3792           gfc_add_expr_to_block (&block, tmp);
3793           stmt = gfc_finish_block (&block);
3794
3795           /* Clean up if it was repacked.  */
3796           gfc_init_block (&block);
3797           tmp = gfc_conv_array_data (argse.expr);
3798           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3799           tmp = build3_v (COND_EXPR, tmp, stmt,
3800                           build_empty_stmt (input_location));
3801           gfc_add_expr_to_block (&block, tmp);
3802           gfc_add_block_to_block (&block, &se->post);
3803           gfc_init_block (&se->post);
3804           gfc_add_block_to_block (&se->post, &block);
3805         }
3806
3807       /* Obtain the source word length.  */
3808       if (arg->expr->ts.type == BT_CHARACTER)
3809         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3810                                        argse.string_length);
3811       else
3812         tmp = fold_convert (gfc_array_index_type,
3813                             size_in_bytes (source_type));
3814
3815       /* Obtain the size of the array in bytes.  */
3816       extent = gfc_create_var (gfc_array_index_type, NULL);
3817       for (n = 0; n < arg->expr->rank; n++)
3818         {
3819           tree idx;
3820           idx = gfc_rank_cst[n];
3821           gfc_add_modify (&argse.pre, source_bytes, tmp);
3822           stride = gfc_conv_descriptor_stride_get (argse.expr, idx);
3823           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
3824           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
3825           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3826                              upper, lower);
3827           gfc_add_modify (&argse.pre, extent, tmp);
3828           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3829                              extent, gfc_index_one_node);
3830           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3831                              tmp, source_bytes);
3832         }
3833     }
3834
3835   gfc_add_modify (&argse.pre, source_bytes, tmp);
3836   gfc_add_block_to_block (&se->pre, &argse.pre);
3837   gfc_add_block_to_block (&se->post, &argse.post);
3838
3839   /* Now convert MOLD.  The outputs are:
3840         mold_type = the TREE type of MOLD
3841         dest_word_len = destination word length in bytes.  */
3842   arg = arg->next;
3843
3844   gfc_init_se (&argse, NULL);
3845   ss = gfc_walk_expr (arg->expr);
3846
3847   scalar_mold = arg->expr->rank == 0;
3848
3849   if (ss == gfc_ss_terminator)
3850     {
3851       gfc_conv_expr_reference (&argse, arg->expr);
3852       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
3853                                                       argse.expr));
3854     }
3855   else
3856     {
3857       gfc_init_se (&argse, NULL);
3858       argse.want_pointer = 0;
3859       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3860       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3861     }
3862
3863   gfc_add_block_to_block (&se->pre, &argse.pre);
3864   gfc_add_block_to_block (&se->post, &argse.post);
3865
3866   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
3867     {
3868       /* If this TRANSFER is nested in another TRANSFER, use a type
3869          that preserves all bits.  */
3870       if (arg->expr->ts.type == BT_LOGICAL)
3871         mold_type = gfc_get_int_type (arg->expr->ts.kind);
3872     }
3873
3874   if (arg->expr->ts.type == BT_CHARACTER)
3875     {
3876       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
3877       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3878     }
3879   else
3880     tmp = fold_convert (gfc_array_index_type,
3881                         size_in_bytes (mold_type));
3882
3883   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3884   gfc_add_modify (&se->pre, dest_word_len, tmp);
3885
3886   /* Finally convert SIZE, if it is present.  */
3887   arg = arg->next;
3888   size_words = gfc_create_var (gfc_array_index_type, NULL);
3889
3890   if (arg->expr)
3891     {
3892       gfc_init_se (&argse, NULL);
3893       gfc_conv_expr_reference (&argse, arg->expr);
3894       tmp = convert (gfc_array_index_type,
3895                      build_fold_indirect_ref_loc (input_location,
3896                                               argse.expr));
3897       gfc_add_block_to_block (&se->pre, &argse.pre);
3898       gfc_add_block_to_block (&se->post, &argse.post);
3899     }
3900   else
3901     tmp = NULL_TREE;
3902
3903   /* Separate array and scalar results.  */
3904   if (scalar_mold && tmp == NULL_TREE)
3905     goto scalar_transfer;
3906
3907   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3908   if (tmp != NULL_TREE)
3909     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3910                        tmp, dest_word_len);
3911   else
3912     tmp = source_bytes;
3913
3914   gfc_add_modify (&se->pre, size_bytes, tmp);
3915   gfc_add_modify (&se->pre, size_words,
3916                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3917                                     size_bytes, dest_word_len));
3918
3919   /* Evaluate the bounds of the result.  If the loop range exists, we have
3920      to check if it is too large.  If so, we modify loop->to be consistent
3921      with min(size, size(source)).  Otherwise, size is made consistent with
3922      the loop range, so that the right number of bytes is transferred.*/
3923   n = se->loop->order[0];
3924   if (se->loop->to[n] != NULL_TREE)
3925     {
3926       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3927                          se->loop->to[n], se->loop->from[n]);
3928       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3929                          tmp, gfc_index_one_node);
3930       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3931                          tmp, size_words);
3932       gfc_add_modify (&se->pre, size_words, tmp);
3933       gfc_add_modify (&se->pre, size_bytes,
3934                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3935                                         size_words, dest_word_len));
3936       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3937                            size_words, se->loop->from[n]);
3938       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3939                            upper, gfc_index_one_node);
3940     }
3941   else
3942     {
3943       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3944                            size_words, gfc_index_one_node);
3945       se->loop->from[n] = gfc_index_zero_node;
3946     }
3947
3948   se->loop->to[n] = upper;
3949
3950   /* Build a destination descriptor, using the pointer, source, as the
3951      data field.  */
3952   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3953                                info, mold_type, NULL_TREE, false, true, false,
3954                                &expr->where);
3955
3956   /* Cast the pointer to the result.  */
3957   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3958   tmp = fold_convert (pvoid_type_node, tmp);
3959
3960   /* Use memcpy to do the transfer.  */
3961   tmp = build_call_expr_loc (input_location,
3962                          built_in_decls[BUILT_IN_MEMCPY],
3963                          3,
3964                          tmp,
3965                          fold_convert (pvoid_type_node, source),
3966                          fold_build2 (MIN_EXPR, gfc_array_index_type,
3967                                       size_bytes, source_bytes));
3968   gfc_add_expr_to_block (&se->pre, tmp);
3969
3970   se->expr = info->descriptor;
3971   if (expr->ts.type == BT_CHARACTER)
3972     se->string_length = dest_word_len;
3973
3974   return;
3975
3976 /* Deal with scalar results.  */
3977 scalar_transfer:
3978   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
3979                         dest_word_len, source_bytes);
3980
3981   if (expr->ts.type == BT_CHARACTER)
3982     {
3983       tree direct;
3984       tree indirect;
3985
3986       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
3987       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
3988                                 "transfer");
3989
3990       /* If source is longer than the destination, use a pointer to
3991          the source directly.  */
3992       gfc_init_block (&block);
3993       gfc_add_modify (&block, tmpdecl, ptr);
3994       direct = gfc_finish_block (&block);
3995
3996       /* Otherwise, allocate a string with the length of the destination
3997          and copy the source into it.  */
3998       gfc_init_block (&block);
3999       tmp = gfc_get_pchar_type (expr->ts.kind);
4000       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4001       gfc_add_modify (&block, tmpdecl,
4002                       fold_convert (TREE_TYPE (ptr), tmp));
4003       tmp = build_call_expr_loc (input_location,
4004                              built_in_decls[BUILT_IN_MEMCPY], 3,
4005                              fold_convert (pvoid_type_node, tmpdecl),
4006                              fold_convert (pvoid_type_node, ptr),
4007                              extent);
4008       gfc_add_expr_to_block (&block, tmp);
4009       indirect = gfc_finish_block (&block);
4010
4011       /* Wrap it up with the condition.  */
4012       tmp = fold_build2 (LE_EXPR, boolean_type_node,
4013                          dest_word_len, source_bytes);
4014       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4015       gfc_add_expr_to_block (&se->pre, tmp);
4016
4017       se->expr = tmpdecl;
4018       se->string_length = dest_word_len;
4019     }
4020   else
4021     {
4022       tmpdecl = gfc_create_var (mold_type, "transfer");
4023
4024       ptr = convert (build_pointer_type (mold_type), source);
4025
4026       /* Use memcpy to do the transfer.  */
4027       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4028       tmp = build_call_expr_loc (input_location,
4029                              built_in_decls[BUILT_IN_MEMCPY], 3,
4030                              fold_convert (pvoid_type_node, tmp),
4031                              fold_convert (pvoid_type_node, ptr),
4032                              extent);
4033       gfc_add_expr_to_block (&se->pre, tmp);
4034
4035       se->expr = tmpdecl;
4036     }
4037 }
4038
4039
4040 /* Generate code for the ALLOCATED intrinsic.
4041    Generate inline code that directly check the address of the argument.  */
4042
4043 static void
4044 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4045 {
4046   gfc_actual_arglist *arg1;
4047   gfc_se arg1se;
4048   gfc_ss *ss1;
4049   tree tmp;
4050
4051   gfc_init_se (&arg1se, NULL);
4052   arg1 = expr->value.function.actual;
4053   ss1 = gfc_walk_expr (arg1->expr);
4054   arg1se.descriptor_only = 1;
4055   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4056
4057   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4058   tmp = fold_build2 (NE_EXPR, boolean_type_node,
4059                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4060   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4061 }
4062
4063
4064 /* Generate code for the ASSOCIATED intrinsic.
4065    If both POINTER and TARGET are arrays, generate a call to library function
4066    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4067    In other cases, generate inline code that directly compare the address of
4068    POINTER with the address of TARGET.  */
4069
4070 static void
4071 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4072 {
4073   gfc_actual_arglist *arg1;
4074   gfc_actual_arglist *arg2;
4075   gfc_se arg1se;
4076   gfc_se arg2se;
4077   tree tmp2;
4078   tree tmp;
4079   tree nonzero_charlen;
4080   tree nonzero_arraylen;
4081   gfc_ss *ss1, *ss2;
4082
4083   gfc_init_se (&arg1se, NULL);
4084   gfc_init_se (&arg2se, NULL);
4085   arg1 = expr->value.function.actual;
4086   arg2 = arg1->next;
4087   ss1 = gfc_walk_expr (arg1->expr);
4088
4089   if (!arg2->expr)
4090     {
4091       /* No optional target.  */
4092       if (ss1 == gfc_ss_terminator)
4093         {
4094           /* A pointer to a scalar.  */
4095           arg1se.want_pointer = 1;
4096           gfc_conv_expr (&arg1se, arg1->expr);
4097           tmp2 = arg1se.expr;
4098         }
4099       else
4100         {
4101           /* A pointer to an array.  */
4102           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4103           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4104         }
4105       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4106       gfc_add_block_to_block (&se->post, &arg1se.post);
4107       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4108                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4109       se->expr = tmp;
4110     }
4111   else
4112     {
4113       /* An optional target.  */
4114       ss2 = gfc_walk_expr (arg2->expr);
4115
4116       nonzero_charlen = NULL_TREE;
4117       if (arg1->expr->ts.type == BT_CHARACTER)
4118         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4119                                        arg1->expr->ts.cl->backend_decl,
4120                                        integer_zero_node);
4121
4122       if (ss1 == gfc_ss_terminator)
4123         {
4124           /* A pointer to a scalar.  */
4125           gcc_assert (ss2 == gfc_ss_terminator);
4126           arg1se.want_pointer = 1;
4127           gfc_conv_expr (&arg1se, arg1->expr);
4128           arg2se.want_pointer = 1;
4129           gfc_conv_expr (&arg2se, arg2->expr);
4130           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4131           gfc_add_block_to_block (&se->post, &arg1se.post);
4132           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4133                              arg1se.expr, arg2se.expr);
4134           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4135                               arg1se.expr, null_pointer_node);
4136           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4137                                   tmp, tmp2);
4138         }
4139       else
4140         {
4141           /* An array pointer of zero length is not associated if target is
4142              present.  */
4143           arg1se.descriptor_only = 1;
4144           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4145           tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4146                                             gfc_rank_cst[arg1->expr->rank - 1]);
4147           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4148                                           build_int_cst (TREE_TYPE (tmp), 0));
4149
4150           /* A pointer to an array, call library function _gfor_associated.  */
4151           gcc_assert (ss2 != gfc_ss_terminator);
4152           arg1se.want_pointer = 1;
4153           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4154
4155           arg2se.want_pointer = 1;
4156           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4157           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4158           gfc_add_block_to_block (&se->post, &arg2se.post);
4159           se->expr = build_call_expr_loc (input_location,
4160                                       gfor_fndecl_associated, 2,
4161                                       arg1se.expr, arg2se.expr);
4162           se->expr = convert (boolean_type_node, se->expr);
4163           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4164                                   se->expr, nonzero_arraylen);
4165         }
4166
4167       /* If target is present zero character length pointers cannot
4168          be associated.  */
4169       if (nonzero_charlen != NULL_TREE)
4170         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4171                                 se->expr, nonzero_charlen);
4172     }
4173
4174   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4175 }
4176
4177
4178 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4179
4180 static void
4181 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4182 {
4183   tree args[2];
4184
4185   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4186   se->expr = build_call_expr_loc (input_location,
4187                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
4188   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4189 }
4190
4191
4192 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4193
4194 static void
4195 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4196 {
4197   tree arg, type;
4198
4199   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4200
4201   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4202   type = gfc_get_int_type (4);
4203   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4204
4205   /* Convert it to the required type.  */
4206   type = gfc_typenode_for_spec (&expr->ts);
4207   se->expr = build_call_expr_loc (input_location,
4208                               gfor_fndecl_si_kind, 1, arg);
4209   se->expr = fold_convert (type, se->expr);
4210 }
4211
4212
4213 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4214
4215 static void
4216 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4217 {
4218   gfc_actual_arglist *actual;
4219   tree args, type;
4220   gfc_se argse;
4221
4222   args = NULL_TREE;
4223   for (actual = expr->value.function.actual; actual; actual = actual->next)
4224     {
4225       gfc_init_se (&argse, se);
4226
4227       /* Pass a NULL pointer for an absent arg.  */
4228       if (actual->expr == NULL)
4229         argse.expr = null_pointer_node;
4230       else
4231         {
4232           gfc_typespec ts;
4233           gfc_clear_ts (&ts);
4234
4235           if (actual->expr->ts.kind != gfc_c_int_kind)
4236             {
4237               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4238               ts.type = BT_INTEGER;
4239               ts.kind = gfc_c_int_kind;
4240               gfc_convert_type (actual->expr, &ts, 2);
4241             }
4242           gfc_conv_expr_reference (&argse, actual->expr);
4243         }
4244
4245       gfc_add_block_to_block (&se->pre, &argse.pre);
4246       gfc_add_block_to_block (&se->post, &argse.post);
4247       args = gfc_chainon_list (args, argse.expr);
4248     }
4249
4250   /* Convert it to the required type.  */
4251   type = gfc_typenode_for_spec (&expr->ts);
4252   se->expr = build_function_call_expr (input_location,
4253                                        gfor_fndecl_sr_kind, args);
4254   se->expr = fold_convert (type, se->expr);
4255 }
4256
4257
4258 /* Generate code for TRIM (A) intrinsic function.  */
4259
4260 static void
4261 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4262 {
4263   tree var;
4264   tree len;
4265   tree addr;
4266   tree tmp;
4267   tree cond;
4268   tree fndecl;
4269   tree function;
4270   tree *args;
4271   unsigned int num_args;
4272
4273   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4274   args = (tree *) alloca (sizeof (tree) * num_args);
4275
4276   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4277   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4278   len = gfc_create_var (gfc_get_int_type (4), "len");
4279
4280   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4281   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4282   args[1] = addr;
4283
4284   if (expr->ts.kind == 1)
4285     function = gfor_fndecl_string_trim;
4286   else if (expr->ts.kind == 4)
4287     function = gfor_fndecl_string_trim_char4;
4288   else
4289     gcc_unreachable ();
4290
4291   fndecl = build_addr (function, current_function_decl);
4292   tmp = build_call_array_loc (input_location,
4293                           TREE_TYPE (TREE_TYPE (function)), fndecl,
4294                           num_args, args);
4295   gfc_add_expr_to_block (&se->pre, tmp);
4296
4297   /* Free the temporary afterwards, if necessary.  */
4298   cond = fold_build2 (GT_EXPR, boolean_type_node,
4299                       len, build_int_cst (TREE_TYPE (len), 0));
4300   tmp = gfc_call_free (var);
4301   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4302   gfc_add_expr_to_block (&se->post, tmp);
4303
4304   se->expr = var;
4305   se->string_length = len;
4306 }
4307
4308
4309 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4310
4311 static void
4312 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4313 {
4314   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4315   tree type, cond, tmp, count, exit_label, n, max, largest;
4316   tree size;
4317   stmtblock_t block, body;
4318   int i;
4319
4320   /* We store in charsize the size of a character.  */
4321   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4322   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4323
4324   /* Get the arguments.  */
4325   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4326   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4327   src = args[1];
4328   ncopies = gfc_evaluate_now (args[2], &se->pre);
4329   ncopies_type = TREE_TYPE (ncopies);
4330
4331   /* Check that NCOPIES is not negative.  */
4332   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4333                       build_int_cst (ncopies_type, 0));
4334   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4335                            "Argument NCOPIES of REPEAT intrinsic is negative "
4336                            "(its value is %lld)",
4337                            fold_convert (long_integer_type_node, ncopies));
4338
4339   /* If the source length is zero, any non negative value of NCOPIES
4340      is valid, and nothing happens.  */
4341   n = gfc_create_var (ncopies_type, "ncopies");
4342   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4343                       build_int_cst (size_type_node, 0));
4344   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4345                      build_int_cst (ncopies_type, 0), ncopies);
4346   gfc_add_modify (&se->pre, n, tmp);
4347   ncopies = n;
4348
4349   /* Check that ncopies is not too large: ncopies should be less than
4350      (or equal to) MAX / slen, where MAX is the maximal integer of
4351      the gfc_charlen_type_node type.  If slen == 0, we need a special
4352      case to avoid the division by zero.  */
4353   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4354   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4355   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4356                      fold_convert (size_type_node, max), slen);
4357   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4358               ? size_type_node : ncopies_type;
4359   cond = fold_build2 (GT_EXPR, boolean_type_node,
4360                       fold_convert (largest, ncopies),
4361                       fold_convert (largest, max));
4362   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4363                      build_int_cst (size_type_node, 0));
4364   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4365                       cond);
4366   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4367                            "Argument NCOPIES of REPEAT intrinsic is too large");
4368
4369   /* Compute the destination length.  */
4370   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4371                       fold_convert (gfc_charlen_type_node, slen),
4372                       fold_convert (gfc_charlen_type_node, ncopies));
4373   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
4374   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4375
4376   /* Generate the code to do the repeat operation:
4377        for (i = 0; i < ncopies; i++)
4378          memmove (dest + (i * slen * size), src, slen*size);  */
4379   gfc_start_block (&block);
4380   count = gfc_create_var (ncopies_type, "count");
4381   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4382   exit_label = gfc_build_label_decl (NULL_TREE);
4383
4384   /* Start the loop body.  */
4385   gfc_start_block (&body);
4386
4387   /* Exit the loop if count >= ncopies.  */
4388   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4389   tmp = build1_v (GOTO_EXPR, exit_label);
4390   TREE_USED (exit_label) = 1;
4391   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4392                      build_empty_stmt (input_location));
4393   gfc_add_expr_to_block (&body, tmp);
4394
4395   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4396   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4397                      fold_convert (gfc_charlen_type_node, slen),
4398                      fold_convert (gfc_charlen_type_node, count));
4399   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4400                      tmp, fold_convert (gfc_charlen_type_node, size));
4401   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4402                      fold_convert (pvoid_type_node, dest),
4403                      fold_convert (sizetype, tmp));
4404   tmp = build_call_expr_loc (input_location,
4405                          built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4406                          fold_build2 (MULT_EXPR, size_type_node, slen,
4407                                       fold_convert (size_type_node, size)));
4408   gfc_add_expr_to_block (&body, tmp);
4409
4410   /* Increment count.  */
4411   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4412                      count, build_int_cst (TREE_TYPE (count), 1));
4413   gfc_add_modify (&body, count, tmp);
4414
4415   /* Build the loop.  */
4416   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4417   gfc_add_expr_to_block (&block, tmp);
4418
4419   /* Add the exit label.  */
4420   tmp = build1_v (LABEL_EXPR, exit_label);
4421   gfc_add_expr_to_block (&block, tmp);
4422
4423   /* Finish the block.  */
4424   tmp = gfc_finish_block (&block);
4425   gfc_add_expr_to_block (&se->pre, tmp);
4426
4427   /* Set the result value.  */
4428   se->expr = dest;
4429   se->string_length = dlen;
4430 }
4431
4432
4433 /* Generate code for the IARGC intrinsic.  */
4434
4435 static void
4436 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4437 {
4438   tree tmp;
4439   tree fndecl;
4440   tree type;
4441
4442   /* Call the library function.  This always returns an INTEGER(4).  */
4443   fndecl = gfor_fndecl_iargc;
4444   tmp = build_call_expr_loc (input_location,
4445                          fndecl, 0);
4446
4447   /* Convert it to the required type.  */
4448   type = gfc_typenode_for_spec (&expr->ts);
4449   tmp = fold_convert (type, tmp);
4450
4451   se->expr = tmp;
4452 }
4453
4454
4455 /* The loc intrinsic returns the address of its argument as
4456    gfc_index_integer_kind integer.  */
4457
4458 static void
4459 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4460 {
4461   tree temp_var;
4462   gfc_expr *arg_expr;
4463   gfc_ss *ss;
4464
4465   gcc_assert (!se->ss);
4466
4467   arg_expr = expr->value.function.actual->expr;
4468   ss = gfc_walk_expr (arg_expr);
4469   if (ss == gfc_ss_terminator)
4470     gfc_conv_expr_reference (se, arg_expr);
4471   else
4472     gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
4473   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4474
4475   /* Create a temporary variable for loc return value.  Without this,
4476      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4477   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4478   gfc_add_modify (&se->pre, temp_var, se->expr);
4479   se->expr = temp_var;
4480 }
4481
4482 /* Generate code for an intrinsic function.  Some map directly to library
4483    calls, others get special handling.  In some cases the name of the function
4484    used depends on the type specifiers.  */
4485
4486 void
4487 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4488 {
4489   gfc_intrinsic_sym *isym;
4490   const char *name;
4491   int lib, kind;
4492   tree fndecl;
4493
4494   isym = expr->value.function.isym;
4495
4496   name = &expr->value.function.name[2];
4497
4498   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4499     {
4500       lib = gfc_is_intrinsic_libcall (expr);
4501       if (lib != 0)
4502         {
4503           if (lib == 1)
4504             se->ignore_optional = 1;
4505
4506           switch (expr->value.function.isym->id)
4507             {
4508             case GFC_ISYM_EOSHIFT:
4509             case GFC_ISYM_PACK:
4510             case GFC_ISYM_RESHAPE:
4511               /* For all of those the first argument specifies the type and the
4512                  third is optional.  */
4513               conv_generic_with_optional_char_arg (se, expr, 1, 3);
4514               break;
4515
4516             default:
4517               gfc_conv_intrinsic_funcall (se, expr);
4518               break;
4519             }
4520
4521           return;
4522         }
4523     }
4524
4525   switch (expr->value.function.isym->id)
4526     {
4527     case GFC_ISYM_NONE:
4528       gcc_unreachable ();
4529
4530     case GFC_ISYM_REPEAT:
4531       gfc_conv_intrinsic_repeat (se, expr);
4532       break;
4533
4534     case GFC_ISYM_TRIM:
4535       gfc_conv_intrinsic_trim (se, expr);
4536       break;
4537
4538     case GFC_ISYM_SC_KIND:
4539       gfc_conv_intrinsic_sc_kind (se, expr);
4540       break;
4541
4542     case GFC_ISYM_SI_KIND:
4543       gfc_conv_intrinsic_si_kind (se, expr);
4544       break;
4545
4546     case GFC_ISYM_SR_KIND:
4547       gfc_conv_intrinsic_sr_kind (se, expr);
4548       break;
4549
4550     case GFC_ISYM_EXPONENT:
4551       gfc_conv_intrinsic_exponent (se, expr);
4552       break;
4553
4554     case GFC_ISYM_SCAN:
4555       kind = expr->value.function.actual->expr->ts.kind;
4556       if (kind == 1)
4557        fndecl = gfor_fndecl_string_scan;
4558       else if (kind == 4)
4559        fndecl = gfor_fndecl_string_scan_char4;
4560       else
4561        gcc_unreachable ();
4562
4563       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4564       break;
4565
4566     case GFC_ISYM_VERIFY:
4567       kind = expr->value.function.actual->expr->ts.kind;
4568       if (kind == 1)
4569        fndecl = gfor_fndecl_string_verify;
4570       else if (kind == 4)
4571        fndecl = gfor_fndecl_string_verify_char4;
4572       else
4573        gcc_unreachable ();
4574
4575       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4576       break;
4577
4578     case GFC_ISYM_ALLOCATED:
4579       gfc_conv_allocated (se, expr);
4580       break;
4581
4582     case GFC_ISYM_ASSOCIATED:
4583       gfc_conv_associated(se, expr);
4584       break;
4585
4586     case GFC_ISYM_ABS:
4587       gfc_conv_intrinsic_abs (se, expr);
4588       break;
4589
4590     case GFC_ISYM_ADJUSTL:
4591       if (expr->ts.kind == 1)
4592        fndecl = gfor_fndecl_adjustl;
4593       else if (expr->ts.kind == 4)
4594        fndecl = gfor_fndecl_adjustl_char4;
4595       else
4596        gcc_unreachable ();
4597
4598       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4599       break;
4600
4601     case GFC_ISYM_ADJUSTR:
4602       if (expr->ts.kind == 1)
4603        fndecl = gfor_fndecl_adjustr;
4604       else if (expr->ts.kind == 4)
4605        fndecl = gfor_fndecl_adjustr_char4;
4606       else
4607        gcc_unreachable ();
4608
4609       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4610       break;
4611
4612     case GFC_ISYM_AIMAG:
4613       gfc_conv_intrinsic_imagpart (se, expr);
4614       break;
4615
4616     case GFC_ISYM_AINT:
4617       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4618       break;
4619
4620     case GFC_ISYM_ALL:
4621       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4622       break;
4623
4624     case GFC_ISYM_ANINT:
4625       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4626       break;
4627
4628     case GFC_ISYM_AND:
4629       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4630       break;
4631
4632     case GFC_ISYM_ANY:
4633       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4634       break;
4635
4636     case GFC_ISYM_BTEST:
4637       gfc_conv_intrinsic_btest (se, expr);
4638       break;
4639
4640     case GFC_ISYM_ACHAR:
4641     case GFC_ISYM_CHAR:
4642       gfc_conv_intrinsic_char (se, expr);
4643       break;
4644
4645     case GFC_ISYM_CONVERSION:
4646     case GFC_ISYM_REAL:
4647     case GFC_ISYM_LOGICAL:
4648     case GFC_ISYM_DBLE:
4649       gfc_conv_intrinsic_conversion (se, expr);
4650       break;
4651
4652       /* Integer conversions are handled separately to make sure we get the
4653          correct rounding mode.  */
4654     case GFC_ISYM_INT:
4655     case GFC_ISYM_INT2:
4656     case GFC_ISYM_INT8:
4657     case GFC_ISYM_LONG:
4658       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4659       break;
4660
4661     case GFC_ISYM_NINT:
4662       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4663       break;
4664
4665     case GFC_ISYM_CEILING:
4666       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4667       break;
4668
4669     case GFC_ISYM_FLOOR:
4670       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4671       break;
4672
4673     case GFC_ISYM_MOD:
4674       gfc_conv_intrinsic_mod (se, expr, 0);
4675       break;
4676
4677     case GFC_ISYM_MODULO:
4678       gfc_conv_intrinsic_mod (se, expr, 1);
4679       break;
4680
4681     case GFC_ISYM_CMPLX:
4682       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4683       break;
4684
4685     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4686       gfc_conv_intrinsic_iargc (se, expr);
4687       break;
4688
4689     case GFC_ISYM_COMPLEX:
4690       gfc_conv_intrinsic_cmplx (se, expr, 1);
4691       break;
4692
4693     case GFC_ISYM_CONJG:
4694       gfc_conv_intrinsic_conjg (se, expr);
4695       break;
4696
4697     case GFC_ISYM_COUNT:
4698       gfc_conv_intrinsic_count (se, expr);
4699       break;
4700
4701     case GFC_ISYM_CTIME:
4702       gfc_conv_intrinsic_ctime (se, expr);
4703       break;
4704
4705     case GFC_ISYM_DIM:
4706       gfc_conv_intrinsic_dim (se, expr);
4707       break;
4708
4709     case GFC_ISYM_DOT_PRODUCT:
4710       gfc_conv_intrinsic_dot_product (se, expr);
4711       break;
4712
4713     case GFC_ISYM_DPROD:
4714       gfc_conv_intrinsic_dprod (se, expr);
4715       break;
4716
4717     case GFC_ISYM_FDATE:
4718       gfc_conv_intrinsic_fdate (se, expr);
4719       break;
4720
4721     case GFC_ISYM_FRACTION:
4722       gfc_conv_intrinsic_fraction (se, expr);
4723       break;
4724
4725     case GFC_ISYM_IAND:
4726       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4727       break;
4728
4729     case GFC_ISYM_IBCLR:
4730       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4731       break;
4732
4733     case GFC_ISYM_IBITS:
4734       gfc_conv_intrinsic_ibits (se, expr);
4735       break;
4736
4737     case GFC_ISYM_IBSET:
4738       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4739       break;
4740
4741     case GFC_ISYM_IACHAR:
4742     case GFC_ISYM_ICHAR:
4743       /* We assume ASCII character sequence.  */
4744       gfc_conv_intrinsic_ichar (se, expr);
4745       break;
4746
4747     case GFC_ISYM_IARGC:
4748       gfc_conv_intrinsic_iargc (se, expr);
4749       break;
4750
4751     case GFC_ISYM_IEOR:
4752       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4753       break;
4754
4755     case GFC_ISYM_INDEX:
4756       kind = expr->value.function.actual->expr->ts.kind;
4757       if (kind == 1)
4758        fndecl = gfor_fndecl_string_index;
4759       else if (kind == 4)
4760        fndecl = gfor_fndecl_string_index_char4;
4761       else
4762        gcc_unreachable ();
4763
4764       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4765       break;
4766
4767     case GFC_ISYM_IOR:
4768       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4769       break;
4770
4771     case GFC_ISYM_IS_IOSTAT_END:
4772       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4773       break;
4774
4775     case GFC_ISYM_IS_IOSTAT_EOR:
4776       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4777       break;
4778
4779     case GFC_ISYM_ISNAN:
4780       gfc_conv_intrinsic_isnan (se, expr);
4781       break;
4782
4783     case GFC_ISYM_LSHIFT:
4784       gfc_conv_intrinsic_rlshift (se, expr, 0);
4785       break;
4786
4787     case GFC_ISYM_RSHIFT:
4788       gfc_conv_intrinsic_rlshift (se, expr, 1);
4789       break;
4790
4791     case GFC_ISYM_ISHFT:
4792       gfc_conv_intrinsic_ishft (se, expr);
4793       break;
4794
4795     case GFC_ISYM_ISHFTC:
4796       gfc_conv_intrinsic_ishftc (se, expr);
4797       break;
4798
4799     case GFC_ISYM_LEADZ:
4800       gfc_conv_intrinsic_leadz (se, expr);
4801       break;
4802
4803     case GFC_ISYM_TRAILZ:
4804       gfc_conv_intrinsic_trailz (se, expr);
4805       break;
4806
4807     case GFC_ISYM_LBOUND:
4808       gfc_conv_intrinsic_bound (se, expr, 0);
4809       break;
4810
4811     case GFC_ISYM_TRANSPOSE:
4812       if (se->ss && se->ss->useflags)
4813         {
4814           gfc_conv_tmp_array_ref (se);
4815           gfc_advance_se_ss_chain (se);
4816         }
4817       else
4818         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4819       break;
4820
4821     case GFC_ISYM_LEN:
4822       gfc_conv_intrinsic_len (se, expr);
4823       break;
4824
4825     case GFC_ISYM_LEN_TRIM:
4826       gfc_conv_intrinsic_len_trim (se, expr);
4827       break;
4828
4829     case GFC_ISYM_LGE:
4830       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4831       break;
4832
4833     case GFC_ISYM_LGT:
4834       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4835       break;
4836
4837     case GFC_ISYM_LLE:
4838       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4839       break;
4840
4841     case GFC_ISYM_LLT:
4842       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4843       break;
4844
4845     case GFC_ISYM_MAX:
4846       if (expr->ts.type == BT_CHARACTER)
4847         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4848       else
4849         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4850       break;
4851
4852     case GFC_ISYM_MAXLOC:
4853       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4854       break;
4855
4856     case GFC_ISYM_MAXVAL:
4857       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4858       break;
4859
4860     case GFC_ISYM_MERGE:
4861       gfc_conv_intrinsic_merge (se, expr);
4862       break;
4863
4864     case GFC_ISYM_MIN:
4865       if (expr->ts.type == BT_CHARACTER)
4866         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4867       else
4868         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4869       break;
4870
4871     case GFC_ISYM_MINLOC:
4872       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4873       break;
4874
4875     case GFC_ISYM_MINVAL:
4876       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4877       break;
4878
4879     case GFC_ISYM_NEAREST:
4880       gfc_conv_intrinsic_nearest (se, expr);
4881       break;
4882
4883     case GFC_ISYM_NOT:
4884       gfc_conv_intrinsic_not (se, expr);
4885       break;
4886
4887     case GFC_ISYM_OR:
4888       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4889       break;
4890
4891     case GFC_ISYM_PRESENT:
4892       gfc_conv_intrinsic_present (se, expr);
4893       break;
4894
4895     case GFC_ISYM_PRODUCT:
4896       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4897       break;
4898
4899     case GFC_ISYM_RRSPACING:
4900       gfc_conv_intrinsic_rrspacing (se, expr);
4901       break;
4902
4903     case GFC_ISYM_SET_EXPONENT:
4904       gfc_conv_intrinsic_set_exponent (se, expr);
4905       break;
4906
4907     case GFC_ISYM_SCALE:
4908       gfc_conv_intrinsic_scale (se, expr);
4909       break;
4910
4911     case GFC_ISYM_SIGN:
4912       gfc_conv_intrinsic_sign (se, expr);
4913       break;
4914
4915     case GFC_ISYM_SIZE:
4916       gfc_conv_intrinsic_size (se, expr);
4917       break;
4918
4919     case GFC_ISYM_SIZEOF:
4920       gfc_conv_intrinsic_sizeof (se, expr);
4921       break;
4922
4923     case GFC_ISYM_SPACING:
4924       gfc_conv_intrinsic_spacing (se, expr);
4925       break;
4926
4927     case GFC_ISYM_SUM:
4928       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4929       break;
4930
4931     case GFC_ISYM_TRANSFER:
4932       if (se->ss && se->ss->useflags)
4933         {
4934           /* Access the previously obtained result.  */
4935           gfc_conv_tmp_array_ref (se);
4936           gfc_advance_se_ss_chain (se);
4937         }
4938       else
4939         gfc_conv_intrinsic_transfer (se, expr);
4940       break;
4941
4942     case GFC_ISYM_TTYNAM:
4943       gfc_conv_intrinsic_ttynam (se, expr);
4944       break;
4945
4946     case GFC_ISYM_UBOUND:
4947       gfc_conv_intrinsic_bound (se, expr, 1);
4948       break;
4949
4950     case GFC_ISYM_XOR:
4951       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4952       break;
4953
4954     case GFC_ISYM_LOC:
4955       gfc_conv_intrinsic_loc (se, expr);
4956       break;
4957
4958     case GFC_ISYM_ACCESS:
4959     case GFC_ISYM_CHDIR:
4960     case GFC_ISYM_CHMOD:
4961     case GFC_ISYM_DTIME:
4962     case GFC_ISYM_ETIME:
4963     case GFC_ISYM_FGET:
4964     case GFC_ISYM_FGETC:
4965     case GFC_ISYM_FNUM:
4966     case GFC_ISYM_FPUT:
4967     case GFC_ISYM_FPUTC:
4968     case GFC_ISYM_FSTAT:
4969     case GFC_ISYM_FTELL:
4970     case GFC_ISYM_GETCWD:
4971     case GFC_ISYM_GETGID:
4972     case GFC_ISYM_GETPID:
4973     case GFC_ISYM_GETUID:
4974     case GFC_ISYM_HOSTNM:
4975     case GFC_ISYM_KILL:
4976     case GFC_ISYM_IERRNO:
4977     case GFC_ISYM_IRAND:
4978     case GFC_ISYM_ISATTY:
4979     case GFC_ISYM_LINK:
4980     case GFC_ISYM_LSTAT:
4981     case GFC_ISYM_MALLOC:
4982     case GFC_ISYM_MATMUL:
4983     case GFC_ISYM_MCLOCK:
4984     case GFC_ISYM_MCLOCK8:
4985     case GFC_ISYM_RAND:
4986     case GFC_ISYM_RENAME:
4987     case GFC_ISYM_SECOND:
4988     case GFC_ISYM_SECNDS:
4989     case GFC_ISYM_SIGNAL:
4990     case GFC_ISYM_STAT:
4991     case GFC_ISYM_SYMLNK:
4992     case GFC_ISYM_SYSTEM:
4993     case GFC_ISYM_TIME:
4994     case GFC_ISYM_TIME8:
4995     case GFC_ISYM_UMASK:
4996     case GFC_ISYM_UNLINK:
4997       gfc_conv_intrinsic_funcall (se, expr);
4998       break;
4999
5000     case GFC_ISYM_EOSHIFT:
5001     case GFC_ISYM_PACK:
5002     case GFC_ISYM_RESHAPE:
5003       /* For those, expr->rank should always be >0 and thus the if above the
5004          switch should have matched.  */
5005       gcc_unreachable ();
5006       break;
5007
5008     default:
5009       gfc_conv_intrinsic_lib_function (se, expr);
5010       break;
5011     }
5012 }
5013
5014
5015 /* This generates code to execute before entering the scalarization loop.
5016    Currently does nothing.  */
5017
5018 void
5019 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5020 {
5021   switch (ss->expr->value.function.isym->id)
5022     {
5023     case GFC_ISYM_UBOUND:
5024     case GFC_ISYM_LBOUND:
5025       break;
5026
5027     default:
5028       gcc_unreachable ();
5029     }
5030 }
5031
5032
5033 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5034    inside the scalarization loop.  */
5035
5036 static gfc_ss *
5037 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5038 {
5039   gfc_ss *newss;
5040
5041   /* The two argument version returns a scalar.  */
5042   if (expr->value.function.actual->next->expr)
5043     return ss;
5044
5045   newss = gfc_get_ss ();
5046   newss->type = GFC_SS_INTRINSIC;
5047   newss->expr = expr;
5048   newss->next = ss;
5049   newss->data.info.dimen = 1;
5050
5051   return newss;
5052 }
5053
5054
5055 /* Walk an intrinsic array libcall.  */
5056
5057 static gfc_ss *
5058 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5059 {
5060   gfc_ss *newss;
5061
5062   gcc_assert (expr->rank > 0);
5063
5064   newss = gfc_get_ss ();
5065   newss->type = GFC_SS_FUNCTION;
5066   newss->expr = expr;
5067   newss->next = ss;
5068   newss->data.info.dimen = expr->rank;
5069
5070   return newss;
5071 }
5072
5073
5074 /* Returns nonzero if the specified intrinsic function call maps directly to
5075    an external library call.  Should only be used for functions that return
5076    arrays.  */
5077
5078 int
5079 gfc_is_intrinsic_libcall (gfc_expr * expr)
5080 {
5081   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5082   gcc_assert (expr->rank > 0);
5083
5084   switch (expr->value.function.isym->id)
5085     {
5086     case GFC_ISYM_ALL:
5087     case GFC_ISYM_ANY:
5088     case GFC_ISYM_COUNT:
5089     case GFC_ISYM_MATMUL:
5090     case GFC_ISYM_MAXLOC:
5091     case GFC_ISYM_MAXVAL:
5092     case GFC_ISYM_MINLOC:
5093     case GFC_ISYM_MINVAL:
5094     case GFC_ISYM_PRODUCT:
5095     case GFC_ISYM_SUM:
5096     case GFC_ISYM_SHAPE:
5097     case GFC_ISYM_SPREAD:
5098     case GFC_ISYM_TRANSPOSE:
5099       /* Ignore absent optional parameters.  */
5100       return 1;
5101
5102     case GFC_ISYM_RESHAPE:
5103     case GFC_ISYM_CSHIFT:
5104     case GFC_ISYM_EOSHIFT:
5105     case GFC_ISYM_PACK:
5106     case GFC_ISYM_UNPACK:
5107       /* Pass absent optional parameters.  */
5108       return 2;
5109
5110     default:
5111       return 0;
5112     }
5113 }
5114
5115 /* Walk an intrinsic function.  */
5116 gfc_ss *
5117 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5118                              gfc_intrinsic_sym * isym)
5119 {
5120   gcc_assert (isym);
5121
5122   if (isym->elemental)
5123     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5124
5125   if (expr->rank == 0)
5126     return ss;
5127
5128   if (gfc_is_intrinsic_libcall (expr))
5129     return gfc_walk_intrinsic_libfunc (ss, expr);
5130
5131   /* Special cases.  */
5132   switch (isym->id)
5133     {
5134     case GFC_ISYM_LBOUND:
5135     case GFC_ISYM_UBOUND:
5136       return gfc_walk_intrinsic_bound (ss, expr);
5137
5138     case GFC_ISYM_TRANSFER:
5139       return gfc_walk_intrinsic_libfunc (ss, expr);
5140
5141     default:
5142       /* This probably meant someone forgot to add an intrinsic to the above
5143          list(s) when they implemented it, or something's gone horribly
5144          wrong.  */
5145       gcc_unreachable ();
5146     }
5147 }
5148
5149 #include "gt-fortran-trans-intrinsic.h"