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 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
2150    we need to handle.  For performance reasons we sometimes create two
2151    loops instead of one, where the second one is much simpler.
2152    Examples for minloc intrinsic:
2153    1) Result is an array, a call is generated
2154    2) Array mask is used and NaNs need to be supported:
2155       limit = Infinity;
2156       pos = 0;
2157       S = from;
2158       while (S <= to) {
2159         if (mask[S]) {
2160           if (pos == 0) pos = S + (1 - from);
2161           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2162         }
2163         S++;
2164       }
2165       goto lab2;
2166       lab1:;
2167       while (S <= to) {
2168         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2169         S++;
2170       }
2171       lab2:;
2172    3) NaNs need to be supported, but it is known at compile time or cheaply
2173       at runtime whether array is nonempty or not:
2174       limit = Infinity;
2175       pos = 0;
2176       S = from;
2177       while (S <= to) {
2178         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2179         S++;
2180       }
2181       if (from <= to) pos = 1;
2182       goto lab2;
2183       lab1:;
2184       while (S <= to) {
2185         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2186         S++;
2187       }
2188       lab2:;
2189    4) NaNs aren't supported, array mask is used:
2190       limit = infinities_supported ? Infinity : huge (limit);
2191       pos = 0;
2192       S = from;
2193       while (S <= to) {
2194         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2195         S++;
2196       }
2197       goto lab2;
2198       lab1:;
2199       while (S <= to) {
2200         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2201         S++;
2202       }
2203       lab2:;
2204    5) Same without array mask:
2205       limit = infinities_supported ? Infinity : huge (limit);
2206       pos = (from <= to) ? 1 : 0;
2207       S = from;
2208       while (S <= to) {
2209         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2210         S++;
2211       }
2212    For 3) and 5), if mask is scalar, this all goes into a conditional,
2213    setting pos = 0; in the else branch.  */
2214
2215 static void
2216 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2217 {
2218   stmtblock_t body;
2219   stmtblock_t block;
2220   stmtblock_t ifblock;
2221   stmtblock_t elseblock;
2222   tree limit;
2223   tree type;
2224   tree tmp;
2225   tree cond;
2226   tree elsetmp;
2227   tree ifbody;
2228   tree offset;
2229   tree nonempty;
2230   tree lab1, lab2;
2231   gfc_loopinfo loop;
2232   gfc_actual_arglist *actual;
2233   gfc_ss *arrayss;
2234   gfc_ss *maskss;
2235   gfc_se arrayse;
2236   gfc_se maskse;
2237   gfc_expr *arrayexpr;
2238   gfc_expr *maskexpr;
2239   tree pos;
2240   int n;
2241
2242   if (se->ss)
2243     {
2244       gfc_conv_intrinsic_funcall (se, expr);
2245       return;
2246     }
2247
2248   /* Initialize the result.  */
2249   pos = gfc_create_var (gfc_array_index_type, "pos");
2250   offset = gfc_create_var (gfc_array_index_type, "offset");
2251   type = gfc_typenode_for_spec (&expr->ts);
2252
2253   /* Walk the arguments.  */
2254   actual = expr->value.function.actual;
2255   arrayexpr = actual->expr;
2256   arrayss = gfc_walk_expr (arrayexpr);
2257   gcc_assert (arrayss != gfc_ss_terminator);
2258
2259   actual = actual->next->next;
2260   gcc_assert (actual);
2261   maskexpr = actual->expr;
2262   nonempty = NULL;
2263   if (maskexpr && maskexpr->rank != 0)
2264     {
2265       maskss = gfc_walk_expr (maskexpr);
2266       gcc_assert (maskss != gfc_ss_terminator);
2267     }
2268   else
2269     {
2270       mpz_t asize;
2271       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2272         {
2273           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2274           mpz_clear (asize);
2275           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2276                                   gfc_index_zero_node);
2277         }
2278       maskss = NULL;
2279     }
2280
2281   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2282   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2283   switch (arrayexpr->ts.type)
2284     {
2285     case BT_REAL:
2286       if (HONOR_INFINITIES (DECL_MODE (limit)))
2287         {
2288           REAL_VALUE_TYPE real;
2289           real_inf (&real);
2290           tmp = build_real (TREE_TYPE (limit), real);
2291         }
2292       else
2293         tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2294                                      arrayexpr->ts.kind, 0);
2295       break;
2296
2297     case BT_INTEGER:
2298       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2299                                   arrayexpr->ts.kind);
2300       break;
2301
2302     default:
2303       gcc_unreachable ();
2304     }
2305
2306   /* We start with the most negative possible value for MAXLOC, and the most
2307      positive possible value for MINLOC. The most negative possible value is
2308      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2309      possible value is HUGE in both cases.  */
2310   if (op == GT_EXPR)
2311     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2312   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2313     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2314                        build_int_cst (type, 1));
2315
2316   gfc_add_modify (&se->pre, limit, tmp);
2317
2318   /* Initialize the scalarizer.  */
2319   gfc_init_loopinfo (&loop);
2320   gfc_add_ss_to_loop (&loop, arrayss);
2321   if (maskss)
2322     gfc_add_ss_to_loop (&loop, maskss);
2323
2324   /* Initialize the loop.  */
2325   gfc_conv_ss_startstride (&loop);
2326   gfc_conv_loop_setup (&loop, &expr->where);
2327
2328   gcc_assert (loop.dimen == 1);
2329   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2330     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2331                             loop.to[0]);
2332
2333   lab1 = NULL;
2334   lab2 = NULL;
2335   /* Initialize the position to zero, following Fortran 2003.  We are free
2336      to do this because Fortran 95 allows the result of an entirely false
2337      mask to be processor dependent.  If we know at compile time the array
2338      is non-empty and no MASK is used, we can initialize to 1 to simplify
2339      the inner loop.  */
2340   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2341     gfc_add_modify (&loop.pre, pos,
2342                     fold_build3 (COND_EXPR, gfc_array_index_type,
2343                                  nonempty, gfc_index_one_node,
2344                                  gfc_index_zero_node));
2345   else
2346     {
2347       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2348       lab1 = gfc_build_label_decl (NULL_TREE);
2349       TREE_USED (lab1) = 1;
2350       lab2 = gfc_build_label_decl (NULL_TREE);
2351       TREE_USED (lab2) = 1;
2352     }
2353
2354   gfc_mark_ss_chain_used (arrayss, 1);
2355   if (maskss)
2356     gfc_mark_ss_chain_used (maskss, 1);
2357   /* Generate the loop body.  */
2358   gfc_start_scalarized_body (&loop, &body);
2359
2360   /* If we have a mask, only check this element if the mask is set.  */
2361   if (maskss)
2362     {
2363       gfc_init_se (&maskse, NULL);
2364       gfc_copy_loopinfo_to_se (&maskse, &loop);
2365       maskse.ss = maskss;
2366       gfc_conv_expr_val (&maskse, maskexpr);
2367       gfc_add_block_to_block (&body, &maskse.pre);
2368
2369       gfc_start_block (&block);
2370     }
2371   else
2372     gfc_init_block (&block);
2373
2374   /* Compare with the current limit.  */
2375   gfc_init_se (&arrayse, NULL);
2376   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2377   arrayse.ss = arrayss;
2378   gfc_conv_expr_val (&arrayse, arrayexpr);
2379   gfc_add_block_to_block (&block, &arrayse.pre);
2380
2381   /* We do the following if this is a more extreme value.  */
2382   gfc_start_block (&ifblock);
2383
2384   /* Assign the value to the limit...  */
2385   gfc_add_modify (&ifblock, limit, arrayse.expr);
2386
2387   /* Remember where we are.  An offset must be added to the loop
2388      counter to obtain the required position.  */
2389   if (loop.from[0])
2390     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2391                        gfc_index_one_node, loop.from[0]);
2392   else
2393     tmp = gfc_index_one_node;
2394
2395   gfc_add_modify (&block, offset, tmp);
2396
2397   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2398     {
2399       stmtblock_t ifblock2;
2400       tree ifbody2;
2401
2402       gfc_start_block (&ifblock2);
2403       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2404                          loop.loopvar[0], offset);
2405       gfc_add_modify (&ifblock2, pos, tmp);
2406       ifbody2 = gfc_finish_block (&ifblock2);
2407       cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2408                           gfc_index_zero_node);
2409       tmp = build3_v (COND_EXPR, cond, ifbody2,
2410                       build_empty_stmt (input_location));
2411       gfc_add_expr_to_block (&block, tmp);
2412     }
2413
2414   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2415                      loop.loopvar[0], offset);
2416   gfc_add_modify (&ifblock, pos, tmp);
2417
2418   if (lab1)
2419     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2420
2421   ifbody = gfc_finish_block (&ifblock);
2422
2423   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2424     {
2425       if (lab1)
2426         cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2427                             boolean_type_node, arrayse.expr, limit);
2428       else
2429         cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2430
2431       ifbody = build3_v (COND_EXPR, cond, ifbody,
2432                          build_empty_stmt (input_location));
2433     }
2434   gfc_add_expr_to_block (&block, ifbody);
2435
2436   if (maskss)
2437     {
2438       /* We enclose the above in if (mask) {...}.  */
2439       tmp = gfc_finish_block (&block);
2440
2441       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2442                       build_empty_stmt (input_location));
2443     }
2444   else
2445     tmp = gfc_finish_block (&block);
2446   gfc_add_expr_to_block (&body, tmp);
2447
2448   if (lab1)
2449     {
2450       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2451
2452       if (HONOR_NANS (DECL_MODE (limit)))
2453         {
2454           if (nonempty != NULL)
2455             {
2456               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2457               tmp = build3_v (COND_EXPR, nonempty, ifbody,
2458                               build_empty_stmt (input_location));
2459               gfc_add_expr_to_block (&loop.code[0], tmp);
2460             }
2461         }
2462
2463       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2464       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2465       gfc_start_block (&body);
2466
2467       /* If we have a mask, only check this element if the mask is set.  */
2468       if (maskss)
2469         {
2470           gfc_init_se (&maskse, NULL);
2471           gfc_copy_loopinfo_to_se (&maskse, &loop);
2472           maskse.ss = maskss;
2473           gfc_conv_expr_val (&maskse, maskexpr);
2474           gfc_add_block_to_block (&body, &maskse.pre);
2475
2476           gfc_start_block (&block);
2477         }
2478       else
2479         gfc_init_block (&block);
2480
2481       /* Compare with the current limit.  */
2482       gfc_init_se (&arrayse, NULL);
2483       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2484       arrayse.ss = arrayss;
2485       gfc_conv_expr_val (&arrayse, arrayexpr);
2486       gfc_add_block_to_block (&block, &arrayse.pre);
2487
2488       /* We do the following if this is a more extreme value.  */
2489       gfc_start_block (&ifblock);
2490
2491       /* Assign the value to the limit...  */
2492       gfc_add_modify (&ifblock, limit, arrayse.expr);
2493
2494       /* Remember where we are.  An offset must be added to the loop
2495          counter to obtain the required position.  */
2496       if (loop.from[0])
2497         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2498                            gfc_index_one_node, loop.from[0]);
2499       else
2500         tmp = gfc_index_one_node;
2501
2502       gfc_add_modify (&block, offset, tmp);
2503
2504       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2505                          loop.loopvar[0], offset);
2506       gfc_add_modify (&ifblock, pos, tmp);
2507
2508       ifbody = gfc_finish_block (&ifblock);
2509
2510       cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2511
2512       tmp = build3_v (COND_EXPR, cond, ifbody,
2513                       build_empty_stmt (input_location));
2514       gfc_add_expr_to_block (&block, tmp);
2515
2516       if (maskss)
2517         {
2518           /* We enclose the above in if (mask) {...}.  */
2519           tmp = gfc_finish_block (&block);
2520
2521           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2522                           build_empty_stmt (input_location));
2523         }
2524       else
2525         tmp = gfc_finish_block (&block);
2526       gfc_add_expr_to_block (&body, tmp);
2527       /* Avoid initializing loopvar[0] again, it should be left where
2528          it finished by the first loop.  */
2529       loop.from[0] = loop.loopvar[0];
2530     }
2531
2532   gfc_trans_scalarizing_loops (&loop, &body);
2533
2534   if (lab2)
2535     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2536
2537   /* For a scalar mask, enclose the loop in an if statement.  */
2538   if (maskexpr && maskss == NULL)
2539     {
2540       gfc_init_se (&maskse, NULL);
2541       gfc_conv_expr_val (&maskse, maskexpr);
2542       gfc_init_block (&block);
2543       gfc_add_block_to_block (&block, &loop.pre);
2544       gfc_add_block_to_block (&block, &loop.post);
2545       tmp = gfc_finish_block (&block);
2546
2547       /* For the else part of the scalar mask, just initialize
2548          the pos variable the same way as above.  */
2549
2550       gfc_init_block (&elseblock);
2551       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2552       elsetmp = gfc_finish_block (&elseblock);
2553
2554       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2555       gfc_add_expr_to_block (&block, tmp);
2556       gfc_add_block_to_block (&se->pre, &block);
2557     }
2558   else
2559     {
2560       gfc_add_block_to_block (&se->pre, &loop.pre);
2561       gfc_add_block_to_block (&se->pre, &loop.post);
2562     }
2563   gfc_cleanup_loop (&loop);
2564
2565   se->expr = convert (type, pos);
2566 }
2567
2568 /* Emit code for minval or maxval intrinsic.  There are many different cases
2569    we need to handle.  For performance reasons we sometimes create two
2570    loops instead of one, where the second one is much simpler.
2571    Examples for minval intrinsic:
2572    1) Result is an array, a call is generated
2573    2) Array mask is used and NaNs need to be supported, rank 1:
2574       limit = Infinity;
2575       nonempty = false;
2576       S = from;
2577       while (S <= to) {
2578         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2579         S++;
2580       }
2581       limit = nonempty ? NaN : huge (limit);
2582       lab:
2583       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2584    3) NaNs need to be supported, but it is known at compile time or cheaply
2585       at runtime whether array is nonempty or not, rank 1:
2586       limit = Infinity;
2587       S = from;
2588       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2589       limit = (from <= to) ? NaN : huge (limit);
2590       lab:
2591       while (S <= to) { limit = min (a[S], limit); S++; }
2592    4) Array mask is used and NaNs need to be supported, rank > 1:
2593       limit = Infinity;
2594       nonempty = false;
2595       fast = false;
2596       S1 = from1;
2597       while (S1 <= to1) {
2598         S2 = from2;
2599         while (S2 <= to2) {
2600           if (mask[S1][S2]) {
2601             if (fast) limit = min (a[S1][S2], limit);
2602             else {
2603               nonempty = true;
2604               if (a[S1][S2] <= limit) {
2605                 limit = a[S1][S2];
2606                 fast = true;
2607               }
2608             }
2609           }
2610           S2++;
2611         }
2612         S1++;
2613       }
2614       if (!fast)
2615         limit = nonempty ? NaN : huge (limit);
2616    5) NaNs need to be supported, but it is known at compile time or cheaply
2617       at runtime whether array is nonempty or not, rank > 1:
2618       limit = Infinity;
2619       fast = false;
2620       S1 = from1;
2621       while (S1 <= to1) {
2622         S2 = from2;
2623         while (S2 <= to2) {
2624           if (fast) limit = min (a[S1][S2], limit);
2625           else {
2626             if (a[S1][S2] <= limit) {
2627               limit = a[S1][S2];
2628               fast = true;
2629             }
2630           }
2631           S2++;
2632         }
2633         S1++;
2634       }
2635       if (!fast)
2636         limit = (nonempty_array) ? NaN : huge (limit);
2637    6) NaNs aren't supported, but infinities are.  Array mask is used:
2638       limit = Infinity;
2639       nonempty = false;
2640       S = from;
2641       while (S <= to) {
2642         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2643         S++;
2644       }
2645       limit = nonempty ? limit : huge (limit);
2646    7) Same without array mask:
2647       limit = Infinity;
2648       S = from;
2649       while (S <= to) { limit = min (a[S], limit); S++; }
2650       limit = (from <= to) ? limit : huge (limit);
2651    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2652       limit = huge (limit);
2653       S = from;
2654       while (S <= to) { limit = min (a[S], limit); S++); }
2655       (or
2656       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2657       with array mask instead).
2658    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2659    setting limit = huge (limit); in the else branch.  */
2660
2661 static void
2662 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2663 {
2664   tree limit;
2665   tree type;
2666   tree tmp;
2667   tree ifbody;
2668   tree nonempty;
2669   tree nonempty_var;
2670   tree lab;
2671   tree fast;
2672   tree huge_cst = NULL, nan_cst = NULL;
2673   stmtblock_t body;
2674   stmtblock_t block, block2;
2675   gfc_loopinfo loop;
2676   gfc_actual_arglist *actual;
2677   gfc_ss *arrayss;
2678   gfc_ss *maskss;
2679   gfc_se arrayse;
2680   gfc_se maskse;
2681   gfc_expr *arrayexpr;
2682   gfc_expr *maskexpr;
2683   int n;
2684
2685   if (se->ss)
2686     {
2687       gfc_conv_intrinsic_funcall (se, expr);
2688       return;
2689     }
2690
2691   type = gfc_typenode_for_spec (&expr->ts);
2692   /* Initialize the result.  */
2693   limit = gfc_create_var (type, "limit");
2694   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2695   switch (expr->ts.type)
2696     {
2697     case BT_REAL:
2698       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2699                                         expr->ts.kind, 0);
2700       if (HONOR_INFINITIES (DECL_MODE (limit)))
2701         {
2702           REAL_VALUE_TYPE real;
2703           real_inf (&real);
2704           tmp = build_real (type, real);
2705         }
2706       else
2707         tmp = huge_cst;
2708       if (HONOR_NANS (DECL_MODE (limit)))
2709         {
2710           REAL_VALUE_TYPE real;
2711           real_nan (&real, "", 1, DECL_MODE (limit));
2712           nan_cst = build_real (type, real);
2713         }
2714       break;
2715
2716     case BT_INTEGER:
2717       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2718       break;
2719
2720     default:
2721       gcc_unreachable ();
2722     }
2723
2724   /* We start with the most negative possible value for MAXVAL, and the most
2725      positive possible value for MINVAL. The most negative possible value is
2726      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2727      possible value is HUGE in both cases.  */
2728   if (op == GT_EXPR)
2729     {
2730       tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2731       if (huge_cst)
2732         huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2733     }
2734
2735   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2736     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2737                        tmp, build_int_cst (type, 1));
2738
2739   gfc_add_modify (&se->pre, limit, tmp);
2740
2741   /* Walk the arguments.  */
2742   actual = expr->value.function.actual;
2743   arrayexpr = actual->expr;
2744   arrayss = gfc_walk_expr (arrayexpr);
2745   gcc_assert (arrayss != gfc_ss_terminator);
2746
2747   actual = actual->next->next;
2748   gcc_assert (actual);
2749   maskexpr = actual->expr;
2750   nonempty = NULL;
2751   if (maskexpr && maskexpr->rank != 0)
2752     {
2753       maskss = gfc_walk_expr (maskexpr);
2754       gcc_assert (maskss != gfc_ss_terminator);
2755     }
2756   else
2757     {
2758       mpz_t asize;
2759       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2760         {
2761           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2762           mpz_clear (asize);
2763           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2764                                   gfc_index_zero_node);
2765         }
2766       maskss = NULL;
2767     }
2768
2769   /* Initialize the scalarizer.  */
2770   gfc_init_loopinfo (&loop);
2771   gfc_add_ss_to_loop (&loop, arrayss);
2772   if (maskss)
2773     gfc_add_ss_to_loop (&loop, maskss);
2774
2775   /* Initialize the loop.  */
2776   gfc_conv_ss_startstride (&loop);
2777   gfc_conv_loop_setup (&loop, &expr->where);
2778
2779   if (nonempty == NULL && maskss == NULL
2780       && loop.dimen == 1 && loop.from[0] && loop.to[0])
2781     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2782                             loop.to[0]);
2783   nonempty_var = NULL;
2784   if (nonempty == NULL
2785       && (HONOR_INFINITIES (DECL_MODE (limit))
2786           || HONOR_NANS (DECL_MODE (limit))))
2787     {
2788       nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2789       gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2790       nonempty = nonempty_var;
2791     }
2792   lab = NULL;
2793   fast = NULL;
2794   if (HONOR_NANS (DECL_MODE (limit)))
2795     {
2796       if (loop.dimen == 1)
2797         {
2798           lab = gfc_build_label_decl (NULL_TREE);
2799           TREE_USED (lab) = 1;
2800         }
2801       else
2802         {
2803           fast = gfc_create_var (boolean_type_node, "fast");
2804           gfc_add_modify (&se->pre, fast, boolean_false_node);
2805         }
2806     }
2807
2808   gfc_mark_ss_chain_used (arrayss, 1);
2809   if (maskss)
2810     gfc_mark_ss_chain_used (maskss, 1);
2811   /* Generate the loop body.  */
2812   gfc_start_scalarized_body (&loop, &body);
2813
2814   /* If we have a mask, only add this element if the mask is set.  */
2815   if (maskss)
2816     {
2817       gfc_init_se (&maskse, NULL);
2818       gfc_copy_loopinfo_to_se (&maskse, &loop);
2819       maskse.ss = maskss;
2820       gfc_conv_expr_val (&maskse, maskexpr);
2821       gfc_add_block_to_block (&body, &maskse.pre);
2822
2823       gfc_start_block (&block);
2824     }
2825   else
2826     gfc_init_block (&block);
2827
2828   /* Compare with the current limit.  */
2829   gfc_init_se (&arrayse, NULL);
2830   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2831   arrayse.ss = arrayss;
2832   gfc_conv_expr_val (&arrayse, arrayexpr);
2833   gfc_add_block_to_block (&block, &arrayse.pre);
2834
2835   gfc_init_block (&block2);
2836
2837   if (nonempty_var)
2838     gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2839
2840   if (HONOR_NANS (DECL_MODE (limit)))
2841     {
2842       tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2843                          boolean_type_node, arrayse.expr, limit);
2844       if (lab)
2845         ifbody = build1_v (GOTO_EXPR, lab);
2846       else
2847         {
2848           stmtblock_t ifblock;
2849
2850           gfc_init_block (&ifblock);
2851           gfc_add_modify (&ifblock, limit, arrayse.expr);
2852           gfc_add_modify (&ifblock, fast, boolean_true_node);
2853           ifbody = gfc_finish_block (&ifblock);
2854         }
2855       tmp = build3_v (COND_EXPR, tmp, ifbody,
2856                       build_empty_stmt (input_location));
2857       gfc_add_expr_to_block (&block2, tmp);
2858     }
2859   else
2860     {
2861       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2862          signed zeros.  */
2863       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2864         {
2865           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2866           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2867           tmp = build3_v (COND_EXPR, tmp, ifbody,
2868                           build_empty_stmt (input_location));
2869           gfc_add_expr_to_block (&block2, tmp);
2870         }
2871       else
2872         {
2873           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2874                              type, arrayse.expr, limit);
2875           gfc_add_modify (&block2, limit, tmp);
2876         }
2877     }
2878
2879   if (fast)
2880     {
2881       tree elsebody = gfc_finish_block (&block2);
2882
2883       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2884          signed zeros.  */
2885       if (HONOR_NANS (DECL_MODE (limit))
2886           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2887         {
2888           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2889           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2890           ifbody = build3_v (COND_EXPR, tmp, ifbody,
2891                              build_empty_stmt (input_location));
2892         }
2893       else
2894         {
2895           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2896                              type, arrayse.expr, limit);
2897           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2898         }
2899       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2900       gfc_add_expr_to_block (&block, tmp);
2901     }
2902   else
2903     gfc_add_block_to_block (&block, &block2);
2904
2905   gfc_add_block_to_block (&block, &arrayse.post);
2906
2907   tmp = gfc_finish_block (&block);
2908   if (maskss)
2909     /* We enclose the above in if (mask) {...}.  */
2910     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2911                     build_empty_stmt (input_location));
2912   gfc_add_expr_to_block (&body, tmp);
2913
2914   if (lab)
2915     {
2916       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2917
2918       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2919       gfc_add_modify (&loop.code[0], limit, tmp);
2920       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2921
2922       gfc_start_block (&body);
2923
2924       /* If we have a mask, only add this element if the mask is set.  */
2925       if (maskss)
2926         {
2927           gfc_init_se (&maskse, NULL);
2928           gfc_copy_loopinfo_to_se (&maskse, &loop);
2929           maskse.ss = maskss;
2930           gfc_conv_expr_val (&maskse, maskexpr);
2931           gfc_add_block_to_block (&body, &maskse.pre);
2932
2933           gfc_start_block (&block);
2934         }
2935       else
2936         gfc_init_block (&block);
2937
2938       /* Compare with the current limit.  */
2939       gfc_init_se (&arrayse, NULL);
2940       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2941       arrayse.ss = arrayss;
2942       gfc_conv_expr_val (&arrayse, arrayexpr);
2943       gfc_add_block_to_block (&block, &arrayse.pre);
2944
2945       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2946          signed zeros.  */
2947       if (HONOR_NANS (DECL_MODE (limit))
2948           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2949         {
2950           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2951           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2952           tmp = build3_v (COND_EXPR, tmp, ifbody,
2953                           build_empty_stmt (input_location));
2954           gfc_add_expr_to_block (&block, tmp);
2955         }
2956       else
2957         {
2958           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2959                              type, arrayse.expr, limit);
2960           gfc_add_modify (&block, limit, tmp);
2961         }
2962
2963       gfc_add_block_to_block (&block, &arrayse.post);
2964
2965       tmp = gfc_finish_block (&block);
2966       if (maskss)
2967         /* We enclose the above in if (mask) {...}.  */
2968         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2969                         build_empty_stmt (input_location));
2970       gfc_add_expr_to_block (&body, tmp);
2971       /* Avoid initializing loopvar[0] again, it should be left where
2972          it finished by the first loop.  */
2973       loop.from[0] = loop.loopvar[0];
2974     }
2975   gfc_trans_scalarizing_loops (&loop, &body);
2976
2977   if (fast)
2978     {
2979       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2980       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2981       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2982                       ifbody);
2983       gfc_add_expr_to_block (&loop.pre, tmp);
2984     }
2985   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2986     {
2987       tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2988       gfc_add_modify (&loop.pre, limit, tmp);
2989     }
2990
2991   /* For a scalar mask, enclose the loop in an if statement.  */
2992   if (maskexpr && maskss == NULL)
2993     {
2994       tree else_stmt;
2995
2996       gfc_init_se (&maskse, NULL);
2997       gfc_conv_expr_val (&maskse, maskexpr);
2998       gfc_init_block (&block);
2999       gfc_add_block_to_block (&block, &loop.pre);
3000       gfc_add_block_to_block (&block, &loop.post);
3001       tmp = gfc_finish_block (&block);
3002
3003       if (HONOR_INFINITIES (DECL_MODE (limit)))
3004         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3005       else
3006         else_stmt = build_empty_stmt (input_location);
3007       tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3008       gfc_add_expr_to_block (&block, tmp);
3009       gfc_add_block_to_block (&se->pre, &block);
3010     }
3011   else
3012     {
3013       gfc_add_block_to_block (&se->pre, &loop.pre);
3014       gfc_add_block_to_block (&se->pre, &loop.post);
3015     }
3016
3017   gfc_cleanup_loop (&loop);
3018
3019   se->expr = limit;
3020 }
3021
3022 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
3023 static void
3024 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3025 {
3026   tree args[2];
3027   tree type;
3028   tree tmp;
3029
3030   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3031   type = TREE_TYPE (args[0]);
3032
3033   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3034   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
3035   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
3036                      build_int_cst (type, 0));
3037   type = gfc_typenode_for_spec (&expr->ts);
3038   se->expr = convert (type, tmp);
3039 }
3040
3041 /* Generate code to perform the specified operation.  */
3042 static void
3043 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3044 {
3045   tree args[2];
3046
3047   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3048   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3049 }
3050
3051 /* Bitwise not.  */
3052 static void
3053 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3054 {
3055   tree arg;
3056
3057   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3058   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3059 }
3060
3061 /* Set or clear a single bit.  */
3062 static void
3063 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3064 {
3065   tree args[2];
3066   tree type;
3067   tree tmp;
3068   enum tree_code op;
3069
3070   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3071   type = TREE_TYPE (args[0]);
3072
3073   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3074   if (set)
3075     op = BIT_IOR_EXPR;
3076   else
3077     {
3078       op = BIT_AND_EXPR;
3079       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3080     }
3081   se->expr = fold_build2 (op, type, args[0], tmp);
3082 }
3083
3084 /* Extract a sequence of bits.
3085     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
3086 static void
3087 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3088 {
3089   tree args[3];
3090   tree type;
3091   tree tmp;
3092   tree mask;
3093
3094   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3095   type = TREE_TYPE (args[0]);
3096
3097   mask = build_int_cst (type, -1);
3098   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3099   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3100
3101   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3102
3103   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3104 }
3105
3106 /* RSHIFT (I, SHIFT) = I >> SHIFT
3107    LSHIFT (I, SHIFT) = I << SHIFT  */
3108 static void
3109 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3110 {
3111   tree args[2];
3112
3113   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3114
3115   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3116                           TREE_TYPE (args[0]), args[0], args[1]);
3117 }
3118
3119 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3120                         ? 0
3121                         : ((shift >= 0) ? i << shift : i >> -shift)
3122    where all shifts are logical shifts.  */
3123 static void
3124 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3125 {
3126   tree args[2];
3127   tree type;
3128   tree utype;
3129   tree tmp;
3130   tree width;
3131   tree num_bits;
3132   tree cond;
3133   tree lshift;
3134   tree rshift;
3135
3136   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3137   type = TREE_TYPE (args[0]);
3138   utype = unsigned_type_for (type);
3139
3140   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3141
3142   /* Left shift if positive.  */
3143   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3144
3145   /* Right shift if negative.
3146      We convert to an unsigned type because we want a logical shift.
3147      The standard doesn't define the case of shifting negative
3148      numbers, and we try to be compatible with other compilers, most
3149      notably g77, here.  */
3150   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3151                                             convert (utype, args[0]), width));
3152
3153   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3154                      build_int_cst (TREE_TYPE (args[1]), 0));
3155   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3156
3157   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3158      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3159      special case.  */
3160   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3161   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3162
3163   se->expr = fold_build3 (COND_EXPR, type, cond,
3164                           build_int_cst (type, 0), tmp);
3165 }
3166
3167
3168 /* Circular shift.  AKA rotate or barrel shift.  */
3169
3170 static void
3171 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3172 {
3173   tree *args;
3174   tree type;
3175   tree tmp;
3176   tree lrot;
3177   tree rrot;
3178   tree zero;
3179   unsigned int num_args;
3180
3181   num_args = gfc_intrinsic_argument_list_length (expr);
3182   args = (tree *) alloca (sizeof (tree) * num_args);
3183
3184   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3185
3186   if (num_args == 3)
3187     {
3188       /* Use a library function for the 3 parameter version.  */
3189       tree int4type = gfc_get_int_type (4);
3190
3191       type = TREE_TYPE (args[0]);
3192       /* We convert the first argument to at least 4 bytes, and
3193          convert back afterwards.  This removes the need for library
3194          functions for all argument sizes, and function will be
3195          aligned to at least 32 bits, so there's no loss.  */
3196       if (expr->ts.kind < 4)
3197         args[0] = convert (int4type, args[0]);
3198
3199       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3200          need loads of library  functions.  They cannot have values >
3201          BIT_SIZE (I) so the conversion is safe.  */
3202       args[1] = convert (int4type, args[1]);
3203       args[2] = convert (int4type, args[2]);
3204
3205       switch (expr->ts.kind)
3206         {
3207         case 1:
3208         case 2:
3209         case 4:
3210           tmp = gfor_fndecl_math_ishftc4;
3211           break;
3212         case 8:
3213           tmp = gfor_fndecl_math_ishftc8;
3214           break;
3215         case 16:
3216           tmp = gfor_fndecl_math_ishftc16;
3217           break;
3218         default:
3219           gcc_unreachable ();
3220         }
3221       se->expr = build_call_expr_loc (input_location,
3222                                   tmp, 3, args[0], args[1], args[2]);
3223       /* Convert the result back to the original type, if we extended
3224          the first argument's width above.  */
3225       if (expr->ts.kind < 4)
3226         se->expr = convert (type, se->expr);
3227
3228       return;
3229     }
3230   type = TREE_TYPE (args[0]);
3231
3232   /* Rotate left if positive.  */
3233   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3234
3235   /* Rotate right if negative.  */
3236   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3237   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3238
3239   zero = build_int_cst (TREE_TYPE (args[1]), 0);
3240   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3241   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3242
3243   /* Do nothing if shift == 0.  */
3244   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3245   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3246 }
3247
3248 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3249                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3250
3251    The conditional expression is necessary because the result of LEADZ(0)
3252    is defined, but the result of __builtin_clz(0) is undefined for most
3253    targets.
3254
3255    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3256    difference in bit size between the argument of LEADZ and the C int.  */
3257
3258 static void
3259 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3260 {
3261   tree arg;
3262   tree arg_type;
3263   tree cond;
3264   tree result_type;
3265   tree leadz;
3266   tree bit_size;
3267   tree tmp;
3268   tree func;
3269   int s, argsize;
3270
3271   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3272   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3273
3274   /* Which variant of __builtin_clz* should we call?  */
3275   if (argsize <= INT_TYPE_SIZE)
3276     {
3277       arg_type = unsigned_type_node;
3278       func = built_in_decls[BUILT_IN_CLZ];
3279     }
3280   else if (argsize <= LONG_TYPE_SIZE)
3281     {
3282       arg_type = long_unsigned_type_node;
3283       func = built_in_decls[BUILT_IN_CLZL];
3284     }
3285   else if (argsize <= LONG_LONG_TYPE_SIZE)
3286     {
3287       arg_type = long_long_unsigned_type_node;
3288       func = built_in_decls[BUILT_IN_CLZLL];
3289     }
3290   else
3291     {
3292       gcc_assert (argsize == 128);
3293       arg_type = gfc_build_uint_type (argsize);
3294       func = gfor_fndecl_clz128;
3295     }
3296
3297   /* Convert the actual argument twice: first, to the unsigned type of the
3298      same size; then, to the proper argument type for the built-in
3299      function.  But the return type is of the default INTEGER kind.  */
3300   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3301   arg = fold_convert (arg_type, arg);
3302   result_type = gfc_get_int_type (gfc_default_integer_kind);
3303
3304   /* Compute LEADZ for the case i .ne. 0.  */
3305   s = TYPE_PRECISION (arg_type) - argsize;
3306   tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3307   leadz = fold_build2 (MINUS_EXPR, result_type,
3308                        tmp, build_int_cst (result_type, s));
3309
3310   /* Build BIT_SIZE.  */
3311   bit_size = build_int_cst (result_type, argsize);
3312
3313   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3314                       arg, build_int_cst (arg_type, 0));
3315   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3316 }
3317
3318 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3319
3320    The conditional expression is necessary because the result of TRAILZ(0)
3321    is defined, but the result of __builtin_ctz(0) is undefined for most
3322    targets.  */
3323
3324 static void
3325 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3326 {
3327   tree arg;
3328   tree arg_type;
3329   tree cond;
3330   tree result_type;
3331   tree trailz;
3332   tree bit_size;
3333   tree func;
3334   int argsize;
3335
3336   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3337   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3338
3339   /* Which variant of __builtin_ctz* should we call?  */
3340   if (argsize <= INT_TYPE_SIZE)
3341     {
3342       arg_type = unsigned_type_node;
3343       func = built_in_decls[BUILT_IN_CTZ];
3344     }
3345   else if (argsize <= LONG_TYPE_SIZE)
3346     {
3347       arg_type = long_unsigned_type_node;
3348       func = built_in_decls[BUILT_IN_CTZL];
3349     }
3350   else if (argsize <= LONG_LONG_TYPE_SIZE)
3351     {
3352       arg_type = long_long_unsigned_type_node;
3353       func = built_in_decls[BUILT_IN_CTZLL];
3354     }
3355   else
3356     {
3357       gcc_assert (argsize == 128);
3358       arg_type = gfc_build_uint_type (argsize);
3359       func = gfor_fndecl_ctz128;
3360     }
3361
3362   /* Convert the actual argument twice: first, to the unsigned type of the
3363      same size; then, to the proper argument type for the built-in
3364      function.  But the return type is of the default INTEGER kind.  */
3365   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3366   arg = fold_convert (arg_type, arg);
3367   result_type = gfc_get_int_type (gfc_default_integer_kind);
3368
3369   /* Compute TRAILZ for the case i .ne. 0.  */
3370   trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3371                                                        func, 1, arg));
3372
3373   /* Build BIT_SIZE.  */
3374   bit_size = build_int_cst (result_type, argsize);
3375
3376   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3377                       arg, build_int_cst (arg_type, 0));
3378   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3379 }
3380
3381 /* Process an intrinsic with unspecified argument-types that has an optional
3382    argument (which could be of type character), e.g. EOSHIFT.  For those, we
3383    need to append the string length of the optional argument if it is not
3384    present and the type is really character.
3385    primary specifies the position (starting at 1) of the non-optional argument
3386    specifying the type and optional gives the position of the optional
3387    argument in the arglist.  */
3388
3389 static void
3390 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3391                                      unsigned primary, unsigned optional)
3392 {
3393   gfc_actual_arglist* prim_arg;
3394   gfc_actual_arglist* opt_arg;
3395   unsigned cur_pos;
3396   gfc_actual_arglist* arg;
3397   gfc_symbol* sym;
3398   tree append_args;
3399
3400   /* Find the two arguments given as position.  */
3401   cur_pos = 0;
3402   prim_arg = NULL;
3403   opt_arg = NULL;
3404   for (arg = expr->value.function.actual; arg; arg = arg->next)
3405     {
3406       ++cur_pos;
3407
3408       if (cur_pos == primary)
3409         prim_arg = arg;
3410       if (cur_pos == optional)
3411         opt_arg = arg;
3412
3413       if (cur_pos >= primary && cur_pos >= optional)
3414         break;
3415     }
3416   gcc_assert (prim_arg);
3417   gcc_assert (prim_arg->expr);
3418   gcc_assert (opt_arg);
3419
3420   /* If we do have type CHARACTER and the optional argument is really absent,
3421      append a dummy 0 as string length.  */
3422   append_args = NULL_TREE;
3423   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3424     {
3425       tree dummy;
3426
3427       dummy = build_int_cst (gfc_charlen_type_node, 0);
3428       append_args = gfc_chainon_list (append_args, dummy);
3429     }
3430
3431   /* Build the call itself.  */
3432   sym = gfc_get_symbol_for_expr (expr);
3433   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3434                           append_args);
3435   gfc_free (sym);
3436 }
3437
3438
3439 /* The length of a character string.  */
3440 static void
3441 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3442 {
3443   tree len;
3444   tree type;
3445   tree decl;
3446   gfc_symbol *sym;
3447   gfc_se argse;
3448   gfc_expr *arg;
3449   gfc_ss *ss;
3450
3451   gcc_assert (!se->ss);
3452
3453   arg = expr->value.function.actual->expr;
3454
3455   type = gfc_typenode_for_spec (&expr->ts);
3456   switch (arg->expr_type)
3457     {
3458     case EXPR_CONSTANT:
3459       len = build_int_cst (NULL_TREE, arg->value.character.length);
3460       break;
3461
3462     case EXPR_ARRAY:
3463       /* Obtain the string length from the function used by
3464          trans-array.c(gfc_trans_array_constructor).  */
3465       len = NULL_TREE;
3466       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3467       break;
3468
3469     case EXPR_VARIABLE:
3470       if (arg->ref == NULL
3471             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3472         {
3473           /* This doesn't catch all cases.
3474              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3475              and the surrounding thread.  */
3476           sym = arg->symtree->n.sym;
3477           decl = gfc_get_symbol_decl (sym);
3478           if (decl == current_function_decl && sym->attr.function
3479                 && (sym->result == sym))
3480             decl = gfc_get_fake_result_decl (sym, 0);
3481
3482           len = sym->ts.u.cl->backend_decl;
3483           gcc_assert (len);
3484           break;
3485         }
3486
3487       /* Otherwise fall through.  */
3488
3489     default:
3490       /* Anybody stupid enough to do this deserves inefficient code.  */
3491       ss = gfc_walk_expr (arg);
3492       gfc_init_se (&argse, se);
3493       if (ss == gfc_ss_terminator)
3494         gfc_conv_expr (&argse, arg);
3495       else
3496         gfc_conv_expr_descriptor (&argse, arg, ss);
3497       gfc_add_block_to_block (&se->pre, &argse.pre);
3498       gfc_add_block_to_block (&se->post, &argse.post);
3499       len = argse.string_length;
3500       break;
3501     }
3502   se->expr = convert (type, len);
3503 }
3504
3505 /* The length of a character string not including trailing blanks.  */
3506 static void
3507 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3508 {
3509   int kind = expr->value.function.actual->expr->ts.kind;
3510   tree args[2], type, fndecl;
3511
3512   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3513   type = gfc_typenode_for_spec (&expr->ts);
3514
3515   if (kind == 1)
3516     fndecl = gfor_fndecl_string_len_trim;
3517   else if (kind == 4)
3518     fndecl = gfor_fndecl_string_len_trim_char4;
3519   else
3520     gcc_unreachable ();
3521
3522   se->expr = build_call_expr_loc (input_location,
3523                               fndecl, 2, args[0], args[1]);
3524   se->expr = convert (type, se->expr);
3525 }
3526
3527
3528 /* Returns the starting position of a substring within a string.  */
3529
3530 static void
3531 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3532                                       tree function)
3533 {
3534   tree logical4_type_node = gfc_get_logical_type (4);
3535   tree type;
3536   tree fndecl;
3537   tree *args;
3538   unsigned int num_args;
3539
3540   args = (tree *) alloca (sizeof (tree) * 5);
3541
3542   /* Get number of arguments; characters count double due to the
3543      string length argument. Kind= is not passed to the library
3544      and thus ignored.  */
3545   if (expr->value.function.actual->next->next->expr == NULL)
3546     num_args = 4;
3547   else
3548     num_args = 5;
3549
3550   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3551   type = gfc_typenode_for_spec (&expr->ts);
3552
3553   if (num_args == 4)
3554     args[4] = build_int_cst (logical4_type_node, 0);
3555   else
3556     args[4] = convert (logical4_type_node, args[4]);
3557
3558   fndecl = build_addr (function, current_function_decl);
3559   se->expr = build_call_array_loc (input_location,
3560                                TREE_TYPE (TREE_TYPE (function)), fndecl,
3561                                5, args);
3562   se->expr = convert (type, se->expr);
3563
3564 }
3565
3566 /* The ascii value for a single character.  */
3567 static void
3568 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3569 {
3570   tree args[2], type, pchartype;
3571
3572   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3573   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3574   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3575   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3576   type = gfc_typenode_for_spec (&expr->ts);
3577
3578   se->expr = build_fold_indirect_ref_loc (input_location,
3579                                       args[1]);
3580   se->expr = convert (type, se->expr);
3581 }
3582
3583
3584 /* Intrinsic ISNAN calls __builtin_isnan.  */
3585
3586 static void
3587 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3588 {
3589   tree arg;
3590
3591   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3592   se->expr = build_call_expr_loc (input_location,
3593                               built_in_decls[BUILT_IN_ISNAN], 1, arg);
3594   STRIP_TYPE_NOPS (se->expr);
3595   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3596 }
3597
3598
3599 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3600    their argument against a constant integer value.  */
3601
3602 static void
3603 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3604 {
3605   tree arg;
3606
3607   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3608   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3609                           arg, build_int_cst (TREE_TYPE (arg), value));
3610 }
3611
3612
3613
3614 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3615
3616 static void
3617 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3618 {
3619   tree tsource;
3620   tree fsource;
3621   tree mask;
3622   tree type;
3623   tree len, len2;
3624   tree *args;
3625   unsigned int num_args;
3626
3627   num_args = gfc_intrinsic_argument_list_length (expr);
3628   args = (tree *) alloca (sizeof (tree) * num_args);
3629
3630   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3631   if (expr->ts.type != BT_CHARACTER)
3632     {
3633       tsource = args[0];
3634       fsource = args[1];
3635       mask = args[2];
3636     }
3637   else
3638     {
3639       /* We do the same as in the non-character case, but the argument
3640          list is different because of the string length arguments. We
3641          also have to set the string length for the result.  */
3642       len = args[0];
3643       tsource = args[1];
3644       len2 = args[2];
3645       fsource = args[3];
3646       mask = args[4];
3647
3648       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3649                                    &se->pre);
3650       se->string_length = len;
3651     }
3652   type = TREE_TYPE (tsource);
3653   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3654                           fold_convert (type, fsource));
3655 }
3656
3657
3658 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3659 static void
3660 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3661 {
3662   tree arg, type, tmp;
3663   int frexp;
3664
3665   switch (expr->ts.kind)
3666     {
3667       case 4:
3668         frexp = BUILT_IN_FREXPF;
3669         break;
3670       case 8:
3671         frexp = BUILT_IN_FREXP;
3672         break;
3673       case 10:
3674       case 16:
3675         frexp = BUILT_IN_FREXPL;
3676         break;
3677       default:
3678         gcc_unreachable ();
3679     }
3680
3681   type = gfc_typenode_for_spec (&expr->ts);
3682   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3683   tmp = gfc_create_var (integer_type_node, NULL);
3684   se->expr = build_call_expr_loc (input_location,
3685                               built_in_decls[frexp], 2,
3686                               fold_convert (type, arg),
3687                               gfc_build_addr_expr (NULL_TREE, tmp));
3688   se->expr = fold_convert (type, se->expr);
3689 }
3690
3691
3692 /* NEAREST (s, dir) is translated into
3693      tmp = copysign (HUGE_VAL, dir);
3694      return nextafter (s, tmp);
3695  */
3696 static void
3697 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3698 {
3699   tree args[2], type, tmp;
3700   int nextafter, copysign, huge_val;
3701
3702   switch (expr->ts.kind)
3703     {
3704       case 4:
3705         nextafter = BUILT_IN_NEXTAFTERF;
3706         copysign = BUILT_IN_COPYSIGNF;
3707         huge_val = BUILT_IN_HUGE_VALF;
3708         break;
3709       case 8:
3710         nextafter = BUILT_IN_NEXTAFTER;
3711         copysign = BUILT_IN_COPYSIGN;
3712         huge_val = BUILT_IN_HUGE_VAL;
3713         break;
3714       case 10:
3715       case 16:
3716         nextafter = BUILT_IN_NEXTAFTERL;
3717         copysign = BUILT_IN_COPYSIGNL;
3718         huge_val = BUILT_IN_HUGE_VALL;
3719         break;
3720       default:
3721         gcc_unreachable ();
3722     }
3723
3724   type = gfc_typenode_for_spec (&expr->ts);
3725   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3726   tmp = build_call_expr_loc (input_location,
3727                          built_in_decls[copysign], 2,
3728                          build_call_expr_loc (input_location,
3729                                           built_in_decls[huge_val], 0),
3730                          fold_convert (type, args[1]));
3731   se->expr = build_call_expr_loc (input_location,
3732                               built_in_decls[nextafter], 2,
3733                               fold_convert (type, args[0]), tmp);
3734   se->expr = fold_convert (type, se->expr);
3735 }
3736
3737
3738 /* SPACING (s) is translated into
3739     int e;
3740     if (s == 0)
3741       res = tiny;
3742     else
3743     {
3744       frexp (s, &e);
3745       e = e - prec;
3746       e = MAX_EXPR (e, emin);
3747       res = scalbn (1., e);
3748     }
3749     return res;
3750
3751  where prec is the precision of s, gfc_real_kinds[k].digits,
3752        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3753    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3754
3755 static void
3756 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3757 {
3758   tree arg, type, prec, emin, tiny, res, e;
3759   tree cond, tmp;
3760   int frexp, scalbn, k;
3761   stmtblock_t block;
3762
3763   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3764   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3765   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3766   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3767
3768   switch (expr->ts.kind)
3769     {
3770       case 4:
3771         frexp = BUILT_IN_FREXPF;
3772         scalbn = BUILT_IN_SCALBNF;
3773         break;
3774       case 8:
3775         frexp = BUILT_IN_FREXP;
3776         scalbn = BUILT_IN_SCALBN;
3777         break;
3778       case 10:
3779       case 16:
3780         frexp = BUILT_IN_FREXPL;
3781         scalbn = BUILT_IN_SCALBNL;
3782         break;
3783       default:
3784         gcc_unreachable ();
3785     }
3786
3787   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3788   arg = gfc_evaluate_now (arg, &se->pre);
3789
3790   type = gfc_typenode_for_spec (&expr->ts);
3791   e = gfc_create_var (integer_type_node, NULL);
3792   res = gfc_create_var (type, NULL);
3793
3794
3795   /* Build the block for s /= 0.  */
3796   gfc_start_block (&block);
3797   tmp = build_call_expr_loc (input_location,
3798                          built_in_decls[frexp], 2, arg,
3799                          gfc_build_addr_expr (NULL_TREE, e));
3800   gfc_add_expr_to_block (&block, tmp);
3801
3802   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3803   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3804                                           tmp, emin));
3805
3806   tmp = build_call_expr_loc (input_location,
3807                          built_in_decls[scalbn], 2,
3808                          build_real_from_int_cst (type, integer_one_node), e);
3809   gfc_add_modify (&block, res, tmp);
3810
3811   /* Finish by building the IF statement.  */
3812   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3813                       build_real_from_int_cst (type, integer_zero_node));
3814   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3815                   gfc_finish_block (&block));
3816
3817   gfc_add_expr_to_block (&se->pre, tmp);
3818   se->expr = res;
3819 }
3820
3821
3822 /* RRSPACING (s) is translated into
3823       int e;
3824       real x;
3825       x = fabs (s);
3826       if (x != 0)
3827       {
3828         frexp (s, &e);
3829         x = scalbn (x, precision - e);
3830       }
3831       return x;
3832
3833  where precision is gfc_real_kinds[k].digits.  */
3834
3835 static void
3836 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3837 {
3838   tree arg, type, e, x, cond, stmt, tmp;
3839   int frexp, scalbn, fabs, prec, k;
3840   stmtblock_t block;
3841
3842   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3843   prec = gfc_real_kinds[k].digits;
3844   switch (expr->ts.kind)
3845     {
3846       case 4:
3847         frexp = BUILT_IN_FREXPF;
3848         scalbn = BUILT_IN_SCALBNF;
3849         fabs = BUILT_IN_FABSF;
3850         break;
3851       case 8:
3852         frexp = BUILT_IN_FREXP;
3853         scalbn = BUILT_IN_SCALBN;
3854         fabs = BUILT_IN_FABS;
3855         break;
3856       case 10:
3857       case 16:
3858         frexp = BUILT_IN_FREXPL;
3859         scalbn = BUILT_IN_SCALBNL;
3860         fabs = BUILT_IN_FABSL;
3861         break;
3862       default:
3863         gcc_unreachable ();
3864     }
3865
3866   type = gfc_typenode_for_spec (&expr->ts);
3867   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3868   arg = gfc_evaluate_now (arg, &se->pre);
3869
3870   e = gfc_create_var (integer_type_node, NULL);
3871   x = gfc_create_var (type, NULL);
3872   gfc_add_modify (&se->pre, x,
3873                   build_call_expr_loc (input_location,
3874                                    built_in_decls[fabs], 1, arg));
3875
3876
3877   gfc_start_block (&block);
3878   tmp = build_call_expr_loc (input_location,
3879                          built_in_decls[frexp], 2, arg,
3880                          gfc_build_addr_expr (NULL_TREE, e));
3881   gfc_add_expr_to_block (&block, tmp);
3882
3883   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3884                      build_int_cst (NULL_TREE, prec), e);
3885   tmp = build_call_expr_loc (input_location,
3886                          built_in_decls[scalbn], 2, x, tmp);
3887   gfc_add_modify (&block, x, tmp);
3888   stmt = gfc_finish_block (&block);
3889
3890   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3891                       build_real_from_int_cst (type, integer_zero_node));
3892   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3893   gfc_add_expr_to_block (&se->pre, tmp);
3894
3895   se->expr = fold_convert (type, x);
3896 }
3897
3898
3899 /* SCALE (s, i) is translated into scalbn (s, i).  */
3900 static void
3901 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3902 {
3903   tree args[2], type;
3904   int scalbn;
3905
3906   switch (expr->ts.kind)
3907     {
3908       case 4:
3909         scalbn = BUILT_IN_SCALBNF;
3910         break;
3911       case 8:
3912         scalbn = BUILT_IN_SCALBN;
3913         break;
3914       case 10:
3915       case 16:
3916         scalbn = BUILT_IN_SCALBNL;
3917         break;
3918       default:
3919         gcc_unreachable ();
3920     }
3921
3922   type = gfc_typenode_for_spec (&expr->ts);
3923   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3924   se->expr = build_call_expr_loc (input_location,
3925                               built_in_decls[scalbn], 2,
3926                               fold_convert (type, args[0]),
3927                               fold_convert (integer_type_node, args[1]));
3928   se->expr = fold_convert (type, se->expr);
3929 }
3930
3931
3932 /* SET_EXPONENT (s, i) is translated into
3933    scalbn (frexp (s, &dummy_int), i).  */
3934 static void
3935 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3936 {
3937   tree args[2], type, tmp;
3938   int frexp, scalbn;
3939
3940   switch (expr->ts.kind)
3941     {
3942       case 4:
3943         frexp = BUILT_IN_FREXPF;
3944         scalbn = BUILT_IN_SCALBNF;
3945         break;
3946       case 8:
3947         frexp = BUILT_IN_FREXP;
3948         scalbn = BUILT_IN_SCALBN;
3949         break;
3950       case 10:
3951       case 16:
3952         frexp = BUILT_IN_FREXPL;
3953         scalbn = BUILT_IN_SCALBNL;
3954         break;
3955       default:
3956         gcc_unreachable ();
3957     }
3958
3959   type = gfc_typenode_for_spec (&expr->ts);
3960   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3961
3962   tmp = gfc_create_var (integer_type_node, NULL);
3963   tmp = build_call_expr_loc (input_location,
3964                          built_in_decls[frexp], 2,
3965                          fold_convert (type, args[0]),
3966                          gfc_build_addr_expr (NULL_TREE, tmp));
3967   se->expr = build_call_expr_loc (input_location,
3968                               built_in_decls[scalbn], 2, tmp,
3969                               fold_convert (integer_type_node, args[1]));
3970   se->expr = fold_convert (type, se->expr);
3971 }
3972
3973
3974 static void
3975 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3976 {
3977   gfc_actual_arglist *actual;
3978   tree arg1;
3979   tree type;
3980   tree fncall0;
3981   tree fncall1;
3982   gfc_se argse;
3983   gfc_ss *ss;
3984
3985   gfc_init_se (&argse, NULL);
3986   actual = expr->value.function.actual;
3987
3988   ss = gfc_walk_expr (actual->expr);
3989   gcc_assert (ss != gfc_ss_terminator);
3990   argse.want_pointer = 1;
3991   argse.data_not_needed = 1;
3992   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3993   gfc_add_block_to_block (&se->pre, &argse.pre);
3994   gfc_add_block_to_block (&se->post, &argse.post);
3995   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3996
3997   /* Build the call to size0.  */
3998   fncall0 = build_call_expr_loc (input_location,
3999                              gfor_fndecl_size0, 1, arg1);
4000
4001   actual = actual->next;
4002
4003   if (actual->expr)
4004     {
4005       gfc_init_se (&argse, NULL);
4006       gfc_conv_expr_type (&argse, actual->expr,
4007                           gfc_array_index_type);
4008       gfc_add_block_to_block (&se->pre, &argse.pre);
4009
4010       /* Unusually, for an intrinsic, size does not exclude
4011          an optional arg2, so we must test for it.  */
4012       if (actual->expr->expr_type == EXPR_VARIABLE
4013             && actual->expr->symtree->n.sym->attr.dummy
4014             && actual->expr->symtree->n.sym->attr.optional)
4015         {
4016           tree tmp;
4017           /* Build the call to size1.  */
4018           fncall1 = build_call_expr_loc (input_location,
4019                                      gfor_fndecl_size1, 2,
4020                                      arg1, argse.expr);
4021
4022           gfc_init_se (&argse, NULL);
4023           argse.want_pointer = 1;
4024           argse.data_not_needed = 1;
4025           gfc_conv_expr (&argse, actual->expr);
4026           gfc_add_block_to_block (&se->pre, &argse.pre);
4027           tmp = fold_build2 (NE_EXPR, boolean_type_node,
4028                              argse.expr, null_pointer_node);
4029           tmp = gfc_evaluate_now (tmp, &se->pre);
4030           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
4031                                   tmp, fncall1, fncall0);
4032         }
4033       else
4034         {
4035           se->expr = NULL_TREE;
4036           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4037                                     argse.expr, gfc_index_one_node);
4038         }
4039     }
4040   else if (expr->value.function.actual->expr->rank == 1)
4041     {
4042       argse.expr = gfc_index_zero_node;
4043       se->expr = NULL_TREE;
4044     }
4045   else
4046     se->expr = fncall0;
4047
4048   if (se->expr == NULL_TREE)
4049     {
4050       tree ubound, lbound;
4051
4052       arg1 = build_fold_indirect_ref_loc (input_location,
4053                                       arg1);
4054       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4055       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4056       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4057                               ubound, lbound);
4058       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
4059                               gfc_index_one_node);
4060       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
4061                               gfc_index_zero_node);
4062     }
4063
4064   type = gfc_typenode_for_spec (&expr->ts);
4065   se->expr = convert (type, se->expr);
4066 }
4067
4068
4069 /* Helper function to compute the size of a character variable,
4070    excluding the terminating null characters.  The result has
4071    gfc_array_index_type type.  */
4072
4073 static tree
4074 size_of_string_in_bytes (int kind, tree string_length)
4075 {
4076   tree bytesize;
4077   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4078
4079   bytesize = build_int_cst (gfc_array_index_type,
4080                             gfc_character_kinds[i].bit_size / 8);
4081
4082   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
4083                       fold_convert (gfc_array_index_type, string_length));
4084 }
4085
4086
4087 static void
4088 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4089 {
4090   gfc_expr *arg;
4091   gfc_ss *ss;
4092   gfc_se argse;
4093   tree source;
4094   tree source_bytes;
4095   tree type;
4096   tree tmp;
4097   tree lower;
4098   tree upper;
4099   int n;
4100
4101   arg = expr->value.function.actual->expr;
4102
4103   gfc_init_se (&argse, NULL);
4104   ss = gfc_walk_expr (arg);
4105
4106   if (ss == gfc_ss_terminator)
4107     {
4108       gfc_conv_expr_reference (&argse, arg);
4109       source = argse.expr;
4110
4111       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4112                                                  argse.expr));
4113
4114       /* Obtain the source word length.  */
4115       if (arg->ts.type == BT_CHARACTER)
4116         se->expr = size_of_string_in_bytes (arg->ts.kind,
4117                                             argse.string_length);
4118       else
4119         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4120     }
4121   else
4122     {
4123       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4124       argse.want_pointer = 0;
4125       gfc_conv_expr_descriptor (&argse, arg, ss);
4126       source = gfc_conv_descriptor_data_get (argse.expr);
4127       type = gfc_get_element_type (TREE_TYPE (argse.expr));
4128
4129       /* Obtain the argument's word length.  */
4130       if (arg->ts.type == BT_CHARACTER)
4131         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4132       else
4133         tmp = fold_convert (gfc_array_index_type,
4134                             size_in_bytes (type));
4135       gfc_add_modify (&argse.pre, source_bytes, tmp);
4136
4137       /* Obtain the size of the array in bytes.  */
4138       for (n = 0; n < arg->rank; n++)
4139         {
4140           tree idx;
4141           idx = gfc_rank_cst[n];
4142           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4143           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4144           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4145                              upper, lower);
4146           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4147                              tmp, gfc_index_one_node);
4148           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4149                              tmp, source_bytes);
4150           gfc_add_modify (&argse.pre, source_bytes, tmp);
4151         }
4152       se->expr = source_bytes;
4153     }
4154
4155   gfc_add_block_to_block (&se->pre, &argse.pre);
4156 }
4157
4158
4159 /* Intrinsic string comparison functions.  */
4160
4161 static void
4162 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4163 {
4164   tree args[4];
4165
4166   gfc_conv_intrinsic_function_args (se, expr, args, 4);
4167
4168   se->expr
4169     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4170                                 expr->value.function.actual->expr->ts.kind);
4171   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
4172                           build_int_cst (TREE_TYPE (se->expr), 0));
4173 }
4174
4175 /* Generate a call to the adjustl/adjustr library function.  */
4176 static void
4177 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4178 {
4179   tree args[3];
4180   tree len;
4181   tree type;
4182   tree var;
4183   tree tmp;
4184
4185   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4186   len = args[1];
4187
4188   type = TREE_TYPE (args[2]);
4189   var = gfc_conv_string_tmp (se, type, len);
4190   args[0] = var;
4191
4192   tmp = build_call_expr_loc (input_location,
4193                          fndecl, 3, args[0], args[1], args[2]);
4194   gfc_add_expr_to_block (&se->pre, tmp);
4195   se->expr = var;
4196   se->string_length = len;
4197 }
4198
4199
4200 /* Generate code for the TRANSFER intrinsic:
4201         For scalar results:
4202           DEST = TRANSFER (SOURCE, MOLD)
4203         where:
4204           typeof<DEST> = typeof<MOLD>
4205         and:
4206           MOLD is scalar.
4207
4208         For array results:
4209           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4210         where:
4211           typeof<DEST> = typeof<MOLD>
4212         and:
4213           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4214               sizeof (DEST(0) * SIZE).  */
4215 static void
4216 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4217 {
4218   tree tmp;
4219   tree tmpdecl;
4220   tree ptr;
4221   tree extent;
4222   tree source;
4223   tree source_type;
4224   tree source_bytes;
4225   tree mold_type;
4226   tree dest_word_len;
4227   tree size_words;
4228   tree size_bytes;
4229   tree upper;
4230   tree lower;
4231   tree stride;
4232   tree stmt;
4233   gfc_actual_arglist *arg;
4234   gfc_se argse;
4235   gfc_ss *ss;
4236   gfc_ss_info *info;
4237   stmtblock_t block;
4238   int n;
4239   bool scalar_mold;
4240
4241   info = NULL;
4242   if (se->loop)
4243     info = &se->ss->data.info;
4244
4245   /* Convert SOURCE.  The output from this stage is:-
4246         source_bytes = length of the source in bytes
4247         source = pointer to the source data.  */
4248   arg = expr->value.function.actual;
4249
4250   /* Ensure double transfer through LOGICAL preserves all
4251      the needed bits.  */
4252   if (arg->expr->expr_type == EXPR_FUNCTION
4253         && arg->expr->value.function.esym == NULL
4254         && arg->expr->value.function.isym != NULL
4255         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4256         && arg->expr->ts.type == BT_LOGICAL
4257         && expr->ts.type != arg->expr->ts.type)
4258     arg->expr->value.function.name = "__transfer_in_transfer";
4259
4260   gfc_init_se (&argse, NULL);
4261   ss = gfc_walk_expr (arg->expr);
4262
4263   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4264
4265   /* Obtain the pointer to source and the length of source in bytes.  */
4266   if (ss == gfc_ss_terminator)
4267     {
4268       gfc_conv_expr_reference (&argse, arg->expr);
4269       source = argse.expr;
4270
4271       source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4272                                                         argse.expr));
4273
4274       /* Obtain the source word length.  */
4275       if (arg->expr->ts.type == BT_CHARACTER)
4276         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4277                                        argse.string_length);
4278       else
4279         tmp = fold_convert (gfc_array_index_type,
4280                             size_in_bytes (source_type));
4281     }
4282   else
4283     {
4284       argse.want_pointer = 0;
4285       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4286       source = gfc_conv_descriptor_data_get (argse.expr);
4287       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4288
4289       /* Repack the source if not a full variable array.  */
4290       if (arg->expr->expr_type == EXPR_VARIABLE
4291               && arg->expr->ref->u.ar.type != AR_FULL)
4292         {
4293           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4294
4295           if (gfc_option.warn_array_temp)
4296             gfc_warning ("Creating array temporary at %L", &expr->where);
4297
4298           source = build_call_expr_loc (input_location,
4299                                     gfor_fndecl_in_pack, 1, tmp);
4300           source = gfc_evaluate_now (source, &argse.pre);
4301
4302           /* Free the temporary.  */
4303           gfc_start_block (&block);
4304           tmp = gfc_call_free (convert (pvoid_type_node, source));
4305           gfc_add_expr_to_block (&block, tmp);
4306           stmt = gfc_finish_block (&block);
4307
4308           /* Clean up if it was repacked.  */
4309           gfc_init_block (&block);
4310           tmp = gfc_conv_array_data (argse.expr);
4311           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4312           tmp = build3_v (COND_EXPR, tmp, stmt,
4313                           build_empty_stmt (input_location));
4314           gfc_add_expr_to_block (&block, tmp);
4315           gfc_add_block_to_block (&block, &se->post);
4316           gfc_init_block (&se->post);
4317           gfc_add_block_to_block (&se->post, &block);
4318         }
4319
4320       /* Obtain the source word length.  */
4321       if (arg->expr->ts.type == BT_CHARACTER)
4322         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4323                                        argse.string_length);
4324       else
4325         tmp = fold_convert (gfc_array_index_type,
4326                             size_in_bytes (source_type));
4327
4328       /* Obtain the size of the array in bytes.  */
4329       extent = gfc_create_var (gfc_array_index_type, NULL);
4330       for (n = 0; n < arg->expr->rank; n++)
4331         {
4332           tree idx;
4333           idx = gfc_rank_cst[n];
4334           gfc_add_modify (&argse.pre, source_bytes, tmp);
4335           stride = gfc_conv_descriptor_stride_get (argse.expr, idx);
4336           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4337           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4338           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4339                              upper, lower);
4340           gfc_add_modify (&argse.pre, extent, tmp);
4341           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4342                              extent, gfc_index_one_node);
4343           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4344                              tmp, source_bytes);
4345         }
4346     }
4347
4348   gfc_add_modify (&argse.pre, source_bytes, tmp);
4349   gfc_add_block_to_block (&se->pre, &argse.pre);
4350   gfc_add_block_to_block (&se->post, &argse.post);
4351
4352   /* Now convert MOLD.  The outputs are:
4353         mold_type = the TREE type of MOLD
4354         dest_word_len = destination word length in bytes.  */
4355   arg = arg->next;
4356
4357   gfc_init_se (&argse, NULL);
4358   ss = gfc_walk_expr (arg->expr);
4359
4360   scalar_mold = arg->expr->rank == 0;
4361
4362   if (ss == gfc_ss_terminator)
4363     {
4364       gfc_conv_expr_reference (&argse, arg->expr);
4365       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4366                                                       argse.expr));
4367     }
4368   else
4369     {
4370       gfc_init_se (&argse, NULL);
4371       argse.want_pointer = 0;
4372       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4373       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4374     }
4375
4376   gfc_add_block_to_block (&se->pre, &argse.pre);
4377   gfc_add_block_to_block (&se->post, &argse.post);
4378
4379   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4380     {
4381       /* If this TRANSFER is nested in another TRANSFER, use a type
4382          that preserves all bits.  */
4383       if (arg->expr->ts.type == BT_LOGICAL)
4384         mold_type = gfc_get_int_type (arg->expr->ts.kind);
4385     }
4386
4387   if (arg->expr->ts.type == BT_CHARACTER)
4388     {
4389       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4390       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4391     }
4392   else
4393     tmp = fold_convert (gfc_array_index_type,
4394                         size_in_bytes (mold_type));
4395
4396   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4397   gfc_add_modify (&se->pre, dest_word_len, tmp);
4398
4399   /* Finally convert SIZE, if it is present.  */
4400   arg = arg->next;
4401   size_words = gfc_create_var (gfc_array_index_type, NULL);
4402
4403   if (arg->expr)
4404     {
4405       gfc_init_se (&argse, NULL);
4406       gfc_conv_expr_reference (&argse, arg->expr);
4407       tmp = convert (gfc_array_index_type,
4408                      build_fold_indirect_ref_loc (input_location,
4409                                               argse.expr));
4410       gfc_add_block_to_block (&se->pre, &argse.pre);
4411       gfc_add_block_to_block (&se->post, &argse.post);
4412     }
4413   else
4414     tmp = NULL_TREE;
4415
4416   /* Separate array and scalar results.  */
4417   if (scalar_mold && tmp == NULL_TREE)
4418     goto scalar_transfer;
4419
4420   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4421   if (tmp != NULL_TREE)
4422     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4423                        tmp, dest_word_len);
4424   else
4425     tmp = source_bytes;
4426
4427   gfc_add_modify (&se->pre, size_bytes, tmp);
4428   gfc_add_modify (&se->pre, size_words,
4429                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4430                                     size_bytes, dest_word_len));
4431
4432   /* Evaluate the bounds of the result.  If the loop range exists, we have
4433      to check if it is too large.  If so, we modify loop->to be consistent
4434      with min(size, size(source)).  Otherwise, size is made consistent with
4435      the loop range, so that the right number of bytes is transferred.*/
4436   n = se->loop->order[0];
4437   if (se->loop->to[n] != NULL_TREE)
4438     {
4439       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4440                          se->loop->to[n], se->loop->from[n]);
4441       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4442                          tmp, gfc_index_one_node);
4443       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4444                          tmp, size_words);
4445       gfc_add_modify (&se->pre, size_words, tmp);
4446       gfc_add_modify (&se->pre, size_bytes,
4447                            fold_build2 (MULT_EXPR, gfc_array_index_type,
4448                                         size_words, dest_word_len));
4449       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4450                            size_words, se->loop->from[n]);
4451       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4452                            upper, gfc_index_one_node);
4453     }
4454   else
4455     {
4456       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4457                            size_words, gfc_index_one_node);
4458       se->loop->from[n] = gfc_index_zero_node;
4459     }
4460
4461   se->loop->to[n] = upper;
4462
4463   /* Build a destination descriptor, using the pointer, source, as the
4464      data field.  */
4465   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4466                                info, mold_type, NULL_TREE, false, true, false,
4467                                &expr->where);
4468
4469   /* Cast the pointer to the result.  */
4470   tmp = gfc_conv_descriptor_data_get (info->descriptor);
4471   tmp = fold_convert (pvoid_type_node, tmp);
4472
4473   /* Use memcpy to do the transfer.  */
4474   tmp = build_call_expr_loc (input_location,
4475                          built_in_decls[BUILT_IN_MEMCPY],
4476                          3,
4477                          tmp,
4478                          fold_convert (pvoid_type_node, source),
4479                          fold_build2 (MIN_EXPR, gfc_array_index_type,
4480                                       size_bytes, source_bytes));
4481   gfc_add_expr_to_block (&se->pre, tmp);
4482
4483   se->expr = info->descriptor;
4484   if (expr->ts.type == BT_CHARACTER)
4485     se->string_length = dest_word_len;
4486
4487   return;
4488
4489 /* Deal with scalar results.  */
4490 scalar_transfer:
4491   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4492                         dest_word_len, source_bytes);
4493   extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4494                         extent, gfc_index_zero_node);
4495
4496   if (expr->ts.type == BT_CHARACTER)
4497     {
4498       tree direct;
4499       tree indirect;
4500
4501       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4502       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4503                                 "transfer");
4504
4505       /* If source is longer than the destination, use a pointer to
4506          the source directly.  */
4507       gfc_init_block (&block);
4508       gfc_add_modify (&block, tmpdecl, ptr);
4509       direct = gfc_finish_block (&block);
4510
4511       /* Otherwise, allocate a string with the length of the destination
4512          and copy the source into it.  */
4513       gfc_init_block (&block);
4514       tmp = gfc_get_pchar_type (expr->ts.kind);
4515       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4516       gfc_add_modify (&block, tmpdecl,
4517                       fold_convert (TREE_TYPE (ptr), tmp));
4518       tmp = build_call_expr_loc (input_location,
4519                              built_in_decls[BUILT_IN_MEMCPY], 3,
4520                              fold_convert (pvoid_type_node, tmpdecl),
4521                              fold_convert (pvoid_type_node, ptr),
4522                              extent);
4523       gfc_add_expr_to_block (&block, tmp);
4524       indirect = gfc_finish_block (&block);
4525
4526       /* Wrap it up with the condition.  */
4527       tmp = fold_build2 (LE_EXPR, boolean_type_node,
4528                          dest_word_len, source_bytes);
4529       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4530       gfc_add_expr_to_block (&se->pre, tmp);
4531
4532       se->expr = tmpdecl;
4533       se->string_length = dest_word_len;
4534     }
4535   else
4536     {
4537       tmpdecl = gfc_create_var (mold_type, "transfer");
4538
4539       ptr = convert (build_pointer_type (mold_type), source);
4540
4541       /* Use memcpy to do the transfer.  */
4542       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4543       tmp = build_call_expr_loc (input_location,
4544                              built_in_decls[BUILT_IN_MEMCPY], 3,
4545                              fold_convert (pvoid_type_node, tmp),
4546                              fold_convert (pvoid_type_node, ptr),
4547                              extent);
4548       gfc_add_expr_to_block (&se->pre, tmp);
4549
4550       se->expr = tmpdecl;
4551     }
4552 }
4553
4554
4555 /* Generate code for the ALLOCATED intrinsic.
4556    Generate inline code that directly check the address of the argument.  */
4557
4558 static void
4559 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4560 {
4561   gfc_actual_arglist *arg1;
4562   gfc_se arg1se;
4563   gfc_ss *ss1;
4564   tree tmp;
4565
4566   gfc_init_se (&arg1se, NULL);
4567   arg1 = expr->value.function.actual;
4568   ss1 = gfc_walk_expr (arg1->expr);
4569
4570   if (ss1 == gfc_ss_terminator)
4571     {
4572       /* Allocatable scalar.  */
4573       arg1se.want_pointer = 1;
4574       gfc_conv_expr (&arg1se, arg1->expr);
4575       tmp = arg1se.expr;
4576     }
4577   else
4578     {
4579       /* Allocatable array.  */
4580       arg1se.descriptor_only = 1;
4581       gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4582       tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4583     }
4584
4585   tmp = fold_build2 (NE_EXPR, boolean_type_node,
4586                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4587   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4588 }
4589
4590
4591 /* Generate code for the ASSOCIATED intrinsic.
4592    If both POINTER and TARGET are arrays, generate a call to library function
4593    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4594    In other cases, generate inline code that directly compare the address of
4595    POINTER with the address of TARGET.  */
4596
4597 static void
4598 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4599 {
4600   gfc_actual_arglist *arg1;
4601   gfc_actual_arglist *arg2;
4602   gfc_se arg1se;
4603   gfc_se arg2se;
4604   tree tmp2;
4605   tree tmp;
4606   tree nonzero_charlen;
4607   tree nonzero_arraylen;
4608   gfc_ss *ss1, *ss2;
4609
4610   gfc_init_se (&arg1se, NULL);
4611   gfc_init_se (&arg2se, NULL);
4612   arg1 = expr->value.function.actual;
4613   if (arg1->expr->ts.type == BT_CLASS)
4614     gfc_add_component_ref (arg1->expr, "$data");
4615   arg2 = arg1->next;
4616   ss1 = gfc_walk_expr (arg1->expr);
4617
4618   if (!arg2->expr)
4619     {
4620       /* No optional target.  */
4621       if (ss1 == gfc_ss_terminator)
4622         {
4623           /* A pointer to a scalar.  */
4624           arg1se.want_pointer = 1;
4625           gfc_conv_expr (&arg1se, arg1->expr);
4626           tmp2 = arg1se.expr;
4627         }
4628       else
4629         {
4630           /* A pointer to an array.  */
4631           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4632           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4633         }
4634       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4635       gfc_add_block_to_block (&se->post, &arg1se.post);
4636       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4637                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4638       se->expr = tmp;
4639     }
4640   else
4641     {
4642       /* An optional target.  */
4643       ss2 = gfc_walk_expr (arg2->expr);
4644
4645       nonzero_charlen = NULL_TREE;
4646       if (arg1->expr->ts.type == BT_CHARACTER)
4647         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4648                                        arg1->expr->ts.u.cl->backend_decl,
4649                                        integer_zero_node);
4650
4651       if (ss1 == gfc_ss_terminator)
4652         {
4653           /* A pointer to a scalar.  */
4654           gcc_assert (ss2 == gfc_ss_terminator);
4655           arg1se.want_pointer = 1;
4656           gfc_conv_expr (&arg1se, arg1->expr);
4657           arg2se.want_pointer = 1;
4658           gfc_conv_expr (&arg2se, arg2->expr);
4659           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4660           gfc_add_block_to_block (&se->post, &arg1se.post);
4661           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4662                              arg1se.expr, arg2se.expr);
4663           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4664                               arg1se.expr, null_pointer_node);
4665           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4666                                   tmp, tmp2);
4667         }
4668       else
4669         {
4670           /* An array pointer of zero length is not associated if target is
4671              present.  */
4672           arg1se.descriptor_only = 1;
4673           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4674           tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4675                                             gfc_rank_cst[arg1->expr->rank - 1]);
4676           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4677                                           build_int_cst (TREE_TYPE (tmp), 0));
4678
4679           /* A pointer to an array, call library function _gfor_associated.  */
4680           gcc_assert (ss2 != gfc_ss_terminator);
4681           arg1se.want_pointer = 1;
4682           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4683
4684           arg2se.want_pointer = 1;
4685           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4686           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4687           gfc_add_block_to_block (&se->post, &arg2se.post);
4688           se->expr = build_call_expr_loc (input_location,
4689                                       gfor_fndecl_associated, 2,
4690                                       arg1se.expr, arg2se.expr);
4691           se->expr = convert (boolean_type_node, se->expr);
4692           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4693                                   se->expr, nonzero_arraylen);
4694         }
4695
4696       /* If target is present zero character length pointers cannot
4697          be associated.  */
4698       if (nonzero_charlen != NULL_TREE)
4699         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4700                                 se->expr, nonzero_charlen);
4701     }
4702
4703   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4704 }
4705
4706
4707 /* Generate code for the SAME_TYPE_AS intrinsic.
4708    Generate inline code that directly checks the vindices.  */
4709
4710 static void
4711 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4712 {
4713   gfc_expr *a, *b;
4714   gfc_se se1, se2;
4715   tree tmp;
4716
4717   gfc_init_se (&se1, NULL);
4718   gfc_init_se (&se2, NULL);
4719
4720   a = expr->value.function.actual->expr;
4721   b = expr->value.function.actual->next->expr;
4722
4723   if (a->ts.type == BT_CLASS)
4724     gfc_add_component_ref (a, "$vindex");
4725   else if (a->ts.type == BT_DERIVED)
4726     a = gfc_int_expr (a->ts.u.derived->vindex);
4727
4728   if (b->ts.type == BT_CLASS)
4729     gfc_add_component_ref (b, "$vindex");
4730   else if (b->ts.type == BT_DERIVED)
4731     b = gfc_int_expr (b->ts.u.derived->vindex);
4732
4733   gfc_conv_expr (&se1, a);
4734   gfc_conv_expr (&se2, b);
4735
4736   tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4737                      se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4738   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4739 }
4740
4741
4742 /* Generate code for the EXTENDS_TYPE_OF intrinsic.  */
4743
4744 static void
4745 gfc_conv_extends_type_of (gfc_se *se, gfc_expr *expr)
4746 {
4747   gfc_expr *e;
4748   /* TODO: Implement EXTENDS_TYPE_OF.  */
4749   gfc_error ("Intrinsic EXTENDS_TYPE_OF at %L not yet implemented",
4750              &expr->where);
4751   /* Just return 'false' for now.  */
4752   e = gfc_logical_expr (false, &expr->where);
4753   gfc_conv_expr (se, e);
4754 }
4755
4756
4757 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4758
4759 static void
4760 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4761 {
4762   tree args[2];
4763
4764   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4765   se->expr = build_call_expr_loc (input_location,
4766                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
4767   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4768 }
4769
4770
4771 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4772
4773 static void
4774 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4775 {
4776   tree arg, type;
4777
4778   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4779
4780   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4781   type = gfc_get_int_type (4);
4782   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4783
4784   /* Convert it to the required type.  */
4785   type = gfc_typenode_for_spec (&expr->ts);
4786   se->expr = build_call_expr_loc (input_location,
4787                               gfor_fndecl_si_kind, 1, arg);
4788   se->expr = fold_convert (type, se->expr);
4789 }
4790
4791
4792 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4793
4794 static void
4795 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4796 {
4797   gfc_actual_arglist *actual;
4798   tree args, type;
4799   gfc_se argse;
4800
4801   args = NULL_TREE;
4802   for (actual = expr->value.function.actual; actual; actual = actual->next)
4803     {
4804       gfc_init_se (&argse, se);
4805
4806       /* Pass a NULL pointer for an absent arg.  */
4807       if (actual->expr == NULL)
4808         argse.expr = null_pointer_node;
4809       else
4810         {
4811           gfc_typespec ts;
4812           gfc_clear_ts (&ts);
4813
4814           if (actual->expr->ts.kind != gfc_c_int_kind)
4815             {
4816               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4817               ts.type = BT_INTEGER;
4818               ts.kind = gfc_c_int_kind;
4819               gfc_convert_type (actual->expr, &ts, 2);
4820             }
4821           gfc_conv_expr_reference (&argse, actual->expr);
4822         }
4823
4824       gfc_add_block_to_block (&se->pre, &argse.pre);
4825       gfc_add_block_to_block (&se->post, &argse.post);
4826       args = gfc_chainon_list (args, argse.expr);
4827     }
4828
4829   /* Convert it to the required type.  */
4830   type = gfc_typenode_for_spec (&expr->ts);
4831   se->expr = build_function_call_expr (input_location,
4832                                        gfor_fndecl_sr_kind, args);
4833   se->expr = fold_convert (type, se->expr);
4834 }
4835
4836
4837 /* Generate code for TRIM (A) intrinsic function.  */
4838
4839 static void
4840 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4841 {
4842   tree var;
4843   tree len;
4844   tree addr;
4845   tree tmp;
4846   tree cond;
4847   tree fndecl;
4848   tree function;
4849   tree *args;
4850   unsigned int num_args;
4851
4852   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4853   args = (tree *) alloca (sizeof (tree) * num_args);
4854
4855   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4856   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4857   len = gfc_create_var (gfc_get_int_type (4), "len");
4858
4859   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4860   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4861   args[1] = addr;
4862
4863   if (expr->ts.kind == 1)
4864     function = gfor_fndecl_string_trim;
4865   else if (expr->ts.kind == 4)
4866     function = gfor_fndecl_string_trim_char4;
4867   else
4868     gcc_unreachable ();
4869
4870   fndecl = build_addr (function, current_function_decl);
4871   tmp = build_call_array_loc (input_location,
4872                           TREE_TYPE (TREE_TYPE (function)), fndecl,
4873                           num_args, args);
4874   gfc_add_expr_to_block (&se->pre, tmp);
4875
4876   /* Free the temporary afterwards, if necessary.  */
4877   cond = fold_build2 (GT_EXPR, boolean_type_node,
4878                       len, build_int_cst (TREE_TYPE (len), 0));
4879   tmp = gfc_call_free (var);
4880   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4881   gfc_add_expr_to_block (&se->post, tmp);
4882
4883   se->expr = var;
4884   se->string_length = len;
4885 }
4886
4887
4888 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4889
4890 static void
4891 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4892 {
4893   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4894   tree type, cond, tmp, count, exit_label, n, max, largest;
4895   tree size;
4896   stmtblock_t block, body;
4897   int i;
4898
4899   /* We store in charsize the size of a character.  */
4900   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4901   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4902
4903   /* Get the arguments.  */
4904   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4905   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4906   src = args[1];
4907   ncopies = gfc_evaluate_now (args[2], &se->pre);
4908   ncopies_type = TREE_TYPE (ncopies);
4909
4910   /* Check that NCOPIES is not negative.  */
4911   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4912                       build_int_cst (ncopies_type, 0));
4913   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4914                            "Argument NCOPIES of REPEAT intrinsic is negative "
4915                            "(its value is %lld)",
4916                            fold_convert (long_integer_type_node, ncopies));
4917
4918   /* If the source length is zero, any non negative value of NCOPIES
4919      is valid, and nothing happens.  */
4920   n = gfc_create_var (ncopies_type, "ncopies");
4921   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4922                       build_int_cst (size_type_node, 0));
4923   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4924                      build_int_cst (ncopies_type, 0), ncopies);
4925   gfc_add_modify (&se->pre, n, tmp);
4926   ncopies = n;
4927
4928   /* Check that ncopies is not too large: ncopies should be less than
4929      (or equal to) MAX / slen, where MAX is the maximal integer of
4930      the gfc_charlen_type_node type.  If slen == 0, we need a special
4931      case to avoid the division by zero.  */
4932   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4933   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4934   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4935                      fold_convert (size_type_node, max), slen);
4936   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4937               ? size_type_node : ncopies_type;
4938   cond = fold_build2 (GT_EXPR, boolean_type_node,
4939                       fold_convert (largest, ncopies),
4940                       fold_convert (largest, max));
4941   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4942                      build_int_cst (size_type_node, 0));
4943   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4944                       cond);
4945   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4946                            "Argument NCOPIES of REPEAT intrinsic is too large");
4947
4948   /* Compute the destination length.  */
4949   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4950                       fold_convert (gfc_charlen_type_node, slen),
4951                       fold_convert (gfc_charlen_type_node, ncopies));
4952   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4953   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4954
4955   /* Generate the code to do the repeat operation:
4956        for (i = 0; i < ncopies; i++)
4957          memmove (dest + (i * slen * size), src, slen*size);  */
4958   gfc_start_block (&block);
4959   count = gfc_create_var (ncopies_type, "count");
4960   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4961   exit_label = gfc_build_label_decl (NULL_TREE);
4962
4963   /* Start the loop body.  */
4964   gfc_start_block (&body);
4965
4966   /* Exit the loop if count >= ncopies.  */
4967   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4968   tmp = build1_v (GOTO_EXPR, exit_label);
4969   TREE_USED (exit_label) = 1;
4970   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4971                      build_empty_stmt (input_location));
4972   gfc_add_expr_to_block (&body, tmp);
4973
4974   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4975   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4976                      fold_convert (gfc_charlen_type_node, slen),
4977                      fold_convert (gfc_charlen_type_node, count));
4978   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4979                      tmp, fold_convert (gfc_charlen_type_node, size));
4980   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4981                      fold_convert (pvoid_type_node, dest),
4982                      fold_convert (sizetype, tmp));
4983   tmp = build_call_expr_loc (input_location,
4984                          built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4985                          fold_build2 (MULT_EXPR, size_type_node, slen,
4986                                       fold_convert (size_type_node, size)));
4987   gfc_add_expr_to_block (&body, tmp);
4988
4989   /* Increment count.  */
4990   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4991                      count, build_int_cst (TREE_TYPE (count), 1));
4992   gfc_add_modify (&body, count, tmp);
4993
4994   /* Build the loop.  */
4995   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4996   gfc_add_expr_to_block (&block, tmp);
4997
4998   /* Add the exit label.  */
4999   tmp = build1_v (LABEL_EXPR, exit_label);
5000   gfc_add_expr_to_block (&block, tmp);
5001
5002   /* Finish the block.  */
5003   tmp = gfc_finish_block (&block);
5004   gfc_add_expr_to_block (&se->pre, tmp);
5005
5006   /* Set the result value.  */
5007   se->expr = dest;
5008   se->string_length = dlen;
5009 }
5010
5011
5012 /* Generate code for the IARGC intrinsic.  */
5013
5014 static void
5015 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
5016 {
5017   tree tmp;
5018   tree fndecl;
5019   tree type;
5020
5021   /* Call the library function.  This always returns an INTEGER(4).  */
5022   fndecl = gfor_fndecl_iargc;
5023   tmp = build_call_expr_loc (input_location,
5024                          fndecl, 0);
5025
5026   /* Convert it to the required type.  */
5027   type = gfc_typenode_for_spec (&expr->ts);
5028   tmp = fold_convert (type, tmp);
5029
5030   se->expr = tmp;
5031 }
5032
5033
5034 /* The loc intrinsic returns the address of its argument as
5035    gfc_index_integer_kind integer.  */
5036
5037 static void
5038 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
5039 {
5040   tree temp_var;
5041   gfc_expr *arg_expr;
5042   gfc_ss *ss;
5043
5044   gcc_assert (!se->ss);
5045
5046   arg_expr = expr->value.function.actual->expr;
5047   ss = gfc_walk_expr (arg_expr);
5048   if (ss == gfc_ss_terminator)
5049     gfc_conv_expr_reference (se, arg_expr);
5050   else
5051     gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
5052   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
5053
5054   /* Create a temporary variable for loc return value.  Without this,
5055      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
5056   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
5057   gfc_add_modify (&se->pre, temp_var, se->expr);
5058   se->expr = temp_var;
5059 }
5060
5061 /* Generate code for an intrinsic function.  Some map directly to library
5062    calls, others get special handling.  In some cases the name of the function
5063    used depends on the type specifiers.  */
5064
5065 void
5066 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5067 {
5068   gfc_intrinsic_sym *isym;
5069   const char *name;
5070   int lib, kind;
5071   tree fndecl;
5072
5073   isym = expr->value.function.isym;
5074
5075   name = &expr->value.function.name[2];
5076
5077   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5078     {
5079       lib = gfc_is_intrinsic_libcall (expr);
5080       if (lib != 0)
5081         {
5082           if (lib == 1)
5083             se->ignore_optional = 1;
5084
5085           switch (expr->value.function.isym->id)
5086             {
5087             case GFC_ISYM_EOSHIFT:
5088             case GFC_ISYM_PACK:
5089             case GFC_ISYM_RESHAPE:
5090               /* For all of those the first argument specifies the type and the
5091                  third is optional.  */
5092               conv_generic_with_optional_char_arg (se, expr, 1, 3);
5093               break;
5094
5095             default:
5096               gfc_conv_intrinsic_funcall (se, expr);
5097               break;
5098             }
5099
5100           return;
5101         }
5102     }
5103
5104   switch (expr->value.function.isym->id)
5105     {
5106     case GFC_ISYM_NONE:
5107       gcc_unreachable ();
5108
5109     case GFC_ISYM_REPEAT:
5110       gfc_conv_intrinsic_repeat (se, expr);
5111       break;
5112
5113     case GFC_ISYM_TRIM:
5114       gfc_conv_intrinsic_trim (se, expr);
5115       break;
5116
5117     case GFC_ISYM_SC_KIND:
5118       gfc_conv_intrinsic_sc_kind (se, expr);
5119       break;
5120
5121     case GFC_ISYM_SI_KIND:
5122       gfc_conv_intrinsic_si_kind (se, expr);
5123       break;
5124
5125     case GFC_ISYM_SR_KIND:
5126       gfc_conv_intrinsic_sr_kind (se, expr);
5127       break;
5128
5129     case GFC_ISYM_EXPONENT:
5130       gfc_conv_intrinsic_exponent (se, expr);
5131       break;
5132
5133     case GFC_ISYM_SCAN:
5134       kind = expr->value.function.actual->expr->ts.kind;
5135       if (kind == 1)
5136        fndecl = gfor_fndecl_string_scan;
5137       else if (kind == 4)
5138        fndecl = gfor_fndecl_string_scan_char4;
5139       else
5140        gcc_unreachable ();
5141
5142       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5143       break;
5144
5145     case GFC_ISYM_VERIFY:
5146       kind = expr->value.function.actual->expr->ts.kind;
5147       if (kind == 1)
5148        fndecl = gfor_fndecl_string_verify;
5149       else if (kind == 4)
5150        fndecl = gfor_fndecl_string_verify_char4;
5151       else
5152        gcc_unreachable ();
5153
5154       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5155       break;
5156
5157     case GFC_ISYM_ALLOCATED:
5158       gfc_conv_allocated (se, expr);
5159       break;
5160
5161     case GFC_ISYM_ASSOCIATED:
5162       gfc_conv_associated(se, expr);
5163       break;
5164
5165     case GFC_ISYM_SAME_TYPE_AS:
5166       gfc_conv_same_type_as (se, expr);
5167       break;
5168
5169     case GFC_ISYM_EXTENDS_TYPE_OF:
5170       gfc_conv_extends_type_of (se, expr);
5171       break;
5172
5173     case GFC_ISYM_ABS:
5174       gfc_conv_intrinsic_abs (se, expr);
5175       break;
5176
5177     case GFC_ISYM_ADJUSTL:
5178       if (expr->ts.kind == 1)
5179        fndecl = gfor_fndecl_adjustl;
5180       else if (expr->ts.kind == 4)
5181        fndecl = gfor_fndecl_adjustl_char4;
5182       else
5183        gcc_unreachable ();
5184
5185       gfc_conv_intrinsic_adjust (se, expr, fndecl);
5186       break;
5187
5188     case GFC_ISYM_ADJUSTR:
5189       if (expr->ts.kind == 1)
5190        fndecl = gfor_fndecl_adjustr;
5191       else if (expr->ts.kind == 4)
5192        fndecl = gfor_fndecl_adjustr_char4;
5193       else
5194        gcc_unreachable ();
5195
5196       gfc_conv_intrinsic_adjust (se, expr, fndecl);
5197       break;
5198
5199     case GFC_ISYM_AIMAG:
5200       gfc_conv_intrinsic_imagpart (se, expr);
5201       break;
5202
5203     case GFC_ISYM_AINT:
5204       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5205       break;
5206
5207     case GFC_ISYM_ALL:
5208       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5209       break;
5210
5211     case GFC_ISYM_ANINT:
5212       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5213       break;
5214
5215     case GFC_ISYM_AND:
5216       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5217       break;
5218
5219     case GFC_ISYM_ANY:
5220       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5221       break;
5222
5223     case GFC_ISYM_BTEST:
5224       gfc_conv_intrinsic_btest (se, expr);
5225       break;
5226
5227     case GFC_ISYM_ACHAR:
5228     case GFC_ISYM_CHAR:
5229       gfc_conv_intrinsic_char (se, expr);
5230       break;
5231
5232     case GFC_ISYM_CONVERSION:
5233     case GFC_ISYM_REAL:
5234     case GFC_ISYM_LOGICAL:
5235     case GFC_ISYM_DBLE:
5236       gfc_conv_intrinsic_conversion (se, expr);
5237       break;
5238
5239       /* Integer conversions are handled separately to make sure we get the
5240          correct rounding mode.  */
5241     case GFC_ISYM_INT:
5242     case GFC_ISYM_INT2:
5243     case GFC_ISYM_INT8:
5244     case GFC_ISYM_LONG:
5245       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5246       break;
5247
5248     case GFC_ISYM_NINT:
5249       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5250       break;
5251
5252     case GFC_ISYM_CEILING:
5253       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5254       break;
5255
5256     case GFC_ISYM_FLOOR:
5257       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5258       break;
5259
5260     case GFC_ISYM_MOD:
5261       gfc_conv_intrinsic_mod (se, expr, 0);
5262       break;
5263
5264     case GFC_ISYM_MODULO:
5265       gfc_conv_intrinsic_mod (se, expr, 1);
5266       break;
5267
5268     case GFC_ISYM_CMPLX:
5269       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5270       break;
5271
5272     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5273       gfc_conv_intrinsic_iargc (se, expr);
5274       break;
5275
5276     case GFC_ISYM_COMPLEX:
5277       gfc_conv_intrinsic_cmplx (se, expr, 1);
5278       break;
5279
5280     case GFC_ISYM_CONJG:
5281       gfc_conv_intrinsic_conjg (se, expr);
5282       break;
5283
5284     case GFC_ISYM_COUNT:
5285       gfc_conv_intrinsic_count (se, expr);
5286       break;
5287
5288     case GFC_ISYM_CTIME:
5289       gfc_conv_intrinsic_ctime (se, expr);
5290       break;
5291
5292     case GFC_ISYM_DIM:
5293       gfc_conv_intrinsic_dim (se, expr);
5294       break;
5295
5296     case GFC_ISYM_DOT_PRODUCT:
5297       gfc_conv_intrinsic_dot_product (se, expr);
5298       break;
5299
5300     case GFC_ISYM_DPROD:
5301       gfc_conv_intrinsic_dprod (se, expr);
5302       break;
5303
5304     case GFC_ISYM_FDATE:
5305       gfc_conv_intrinsic_fdate (se, expr);
5306       break;
5307
5308     case GFC_ISYM_FRACTION:
5309       gfc_conv_intrinsic_fraction (se, expr);
5310       break;
5311
5312     case GFC_ISYM_IAND:
5313       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5314       break;
5315
5316     case GFC_ISYM_IBCLR:
5317       gfc_conv_intrinsic_singlebitop (se, expr, 0);
5318       break;
5319
5320     case GFC_ISYM_IBITS:
5321       gfc_conv_intrinsic_ibits (se, expr);
5322       break;
5323
5324     case GFC_ISYM_IBSET:
5325       gfc_conv_intrinsic_singlebitop (se, expr, 1);
5326       break;
5327
5328     case GFC_ISYM_IACHAR:
5329     case GFC_ISYM_ICHAR:
5330       /* We assume ASCII character sequence.  */
5331       gfc_conv_intrinsic_ichar (se, expr);
5332       break;
5333
5334     case GFC_ISYM_IARGC:
5335       gfc_conv_intrinsic_iargc (se, expr);
5336       break;
5337
5338     case GFC_ISYM_IEOR:
5339       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5340       break;
5341
5342     case GFC_ISYM_INDEX:
5343       kind = expr->value.function.actual->expr->ts.kind;
5344       if (kind == 1)
5345        fndecl = gfor_fndecl_string_index;
5346       else if (kind == 4)
5347        fndecl = gfor_fndecl_string_index_char4;
5348       else
5349        gcc_unreachable ();
5350
5351       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5352       break;
5353
5354     case GFC_ISYM_IOR:
5355       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5356       break;
5357
5358     case GFC_ISYM_IS_IOSTAT_END:
5359       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5360       break;
5361
5362     case GFC_ISYM_IS_IOSTAT_EOR:
5363       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5364       break;
5365
5366     case GFC_ISYM_ISNAN:
5367       gfc_conv_intrinsic_isnan (se, expr);
5368       break;
5369
5370     case GFC_ISYM_LSHIFT:
5371       gfc_conv_intrinsic_rlshift (se, expr, 0);
5372       break;
5373
5374     case GFC_ISYM_RSHIFT:
5375       gfc_conv_intrinsic_rlshift (se, expr, 1);
5376       break;
5377
5378     case GFC_ISYM_ISHFT:
5379       gfc_conv_intrinsic_ishft (se, expr);
5380       break;
5381
5382     case GFC_ISYM_ISHFTC:
5383       gfc_conv_intrinsic_ishftc (se, expr);
5384       break;
5385
5386     case GFC_ISYM_LEADZ:
5387       gfc_conv_intrinsic_leadz (se, expr);
5388       break;
5389
5390     case GFC_ISYM_TRAILZ:
5391       gfc_conv_intrinsic_trailz (se, expr);
5392       break;
5393
5394     case GFC_ISYM_LBOUND:
5395       gfc_conv_intrinsic_bound (se, expr, 0);
5396       break;
5397
5398     case GFC_ISYM_TRANSPOSE:
5399       if (se->ss && se->ss->useflags)
5400         {
5401           gfc_conv_tmp_array_ref (se);
5402           gfc_advance_se_ss_chain (se);
5403         }
5404       else
5405         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5406       break;
5407
5408     case GFC_ISYM_LEN:
5409       gfc_conv_intrinsic_len (se, expr);
5410       break;
5411
5412     case GFC_ISYM_LEN_TRIM:
5413       gfc_conv_intrinsic_len_trim (se, expr);
5414       break;
5415
5416     case GFC_ISYM_LGE:
5417       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5418       break;
5419
5420     case GFC_ISYM_LGT:
5421       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5422       break;
5423
5424     case GFC_ISYM_LLE:
5425       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5426       break;
5427
5428     case GFC_ISYM_LLT:
5429       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5430       break;
5431
5432     case GFC_ISYM_MAX:
5433       if (expr->ts.type == BT_CHARACTER)
5434         gfc_conv_intrinsic_minmax_char (se, expr, 1);
5435       else
5436         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5437       break;
5438
5439     case GFC_ISYM_MAXLOC:
5440       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5441       break;
5442
5443     case GFC_ISYM_MAXVAL:
5444       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5445       break;
5446
5447     case GFC_ISYM_MERGE:
5448       gfc_conv_intrinsic_merge (se, expr);
5449       break;
5450
5451     case GFC_ISYM_MIN:
5452       if (expr->ts.type == BT_CHARACTER)
5453         gfc_conv_intrinsic_minmax_char (se, expr, -1);
5454       else
5455         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5456       break;
5457
5458     case GFC_ISYM_MINLOC:
5459       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5460       break;
5461
5462     case GFC_ISYM_MINVAL:
5463       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5464       break;
5465
5466     case GFC_ISYM_NEAREST:
5467       gfc_conv_intrinsic_nearest (se, expr);
5468       break;
5469
5470     case GFC_ISYM_NOT:
5471       gfc_conv_intrinsic_not (se, expr);
5472       break;
5473
5474     case GFC_ISYM_OR:
5475       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5476       break;
5477
5478     case GFC_ISYM_PRESENT:
5479       gfc_conv_intrinsic_present (se, expr);
5480       break;
5481
5482     case GFC_ISYM_PRODUCT:
5483       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5484       break;
5485
5486     case GFC_ISYM_RRSPACING:
5487       gfc_conv_intrinsic_rrspacing (se, expr);
5488       break;
5489
5490     case GFC_ISYM_SET_EXPONENT:
5491       gfc_conv_intrinsic_set_exponent (se, expr);
5492       break;
5493
5494     case GFC_ISYM_SCALE:
5495       gfc_conv_intrinsic_scale (se, expr);
5496       break;
5497
5498     case GFC_ISYM_SIGN:
5499       gfc_conv_intrinsic_sign (se, expr);
5500       break;
5501
5502     case GFC_ISYM_SIZE:
5503       gfc_conv_intrinsic_size (se, expr);
5504       break;
5505
5506     case GFC_ISYM_SIZEOF:
5507       gfc_conv_intrinsic_sizeof (se, expr);
5508       break;
5509
5510     case GFC_ISYM_SPACING:
5511       gfc_conv_intrinsic_spacing (se, expr);
5512       break;
5513
5514     case GFC_ISYM_SUM:
5515       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5516       break;
5517
5518     case GFC_ISYM_TRANSFER:
5519       if (se->ss && se->ss->useflags)
5520         {
5521           /* Access the previously obtained result.  */
5522           gfc_conv_tmp_array_ref (se);
5523           gfc_advance_se_ss_chain (se);
5524         }
5525       else
5526         gfc_conv_intrinsic_transfer (se, expr);
5527       break;
5528
5529     case GFC_ISYM_TTYNAM:
5530       gfc_conv_intrinsic_ttynam (se, expr);
5531       break;
5532
5533     case GFC_ISYM_UBOUND:
5534       gfc_conv_intrinsic_bound (se, expr, 1);
5535       break;
5536
5537     case GFC_ISYM_XOR:
5538       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5539       break;
5540
5541     case GFC_ISYM_LOC:
5542       gfc_conv_intrinsic_loc (se, expr);
5543       break;
5544
5545     case GFC_ISYM_ACCESS:
5546     case GFC_ISYM_CHDIR:
5547     case GFC_ISYM_CHMOD:
5548     case GFC_ISYM_DTIME:
5549     case GFC_ISYM_ETIME:
5550     case GFC_ISYM_FGET:
5551     case GFC_ISYM_FGETC:
5552     case GFC_ISYM_FNUM:
5553     case GFC_ISYM_FPUT:
5554     case GFC_ISYM_FPUTC:
5555     case GFC_ISYM_FSTAT:
5556     case GFC_ISYM_FTELL:
5557     case GFC_ISYM_GETCWD:
5558     case GFC_ISYM_GETGID:
5559     case GFC_ISYM_GETPID:
5560     case GFC_ISYM_GETUID:
5561     case GFC_ISYM_HOSTNM:
5562     case GFC_ISYM_KILL:
5563     case GFC_ISYM_IERRNO:
5564     case GFC_ISYM_IRAND:
5565     case GFC_ISYM_ISATTY:
5566     case GFC_ISYM_LINK:
5567     case GFC_ISYM_LSTAT:
5568     case GFC_ISYM_MALLOC:
5569     case GFC_ISYM_MATMUL:
5570     case GFC_ISYM_MCLOCK:
5571     case GFC_ISYM_MCLOCK8:
5572     case GFC_ISYM_RAND:
5573     case GFC_ISYM_RENAME:
5574     case GFC_ISYM_SECOND:
5575     case GFC_ISYM_SECNDS:
5576     case GFC_ISYM_SIGNAL:
5577     case GFC_ISYM_STAT:
5578     case GFC_ISYM_SYMLNK:
5579     case GFC_ISYM_SYSTEM:
5580     case GFC_ISYM_TIME:
5581     case GFC_ISYM_TIME8:
5582     case GFC_ISYM_UMASK:
5583     case GFC_ISYM_UNLINK:
5584       gfc_conv_intrinsic_funcall (se, expr);
5585       break;
5586
5587     case GFC_ISYM_EOSHIFT:
5588     case GFC_ISYM_PACK:
5589     case GFC_ISYM_RESHAPE:
5590       /* For those, expr->rank should always be >0 and thus the if above the
5591          switch should have matched.  */
5592       gcc_unreachable ();
5593       break;
5594
5595     default:
5596       gfc_conv_intrinsic_lib_function (se, expr);
5597       break;
5598     }
5599 }
5600
5601
5602 /* This generates code to execute before entering the scalarization loop.
5603    Currently does nothing.  */
5604
5605 void
5606 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5607 {
5608   switch (ss->expr->value.function.isym->id)
5609     {
5610     case GFC_ISYM_UBOUND:
5611     case GFC_ISYM_LBOUND:
5612       break;
5613
5614     default:
5615       gcc_unreachable ();
5616     }
5617 }
5618
5619
5620 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5621    inside the scalarization loop.  */
5622
5623 static gfc_ss *
5624 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5625 {
5626   gfc_ss *newss;
5627
5628   /* The two argument version returns a scalar.  */
5629   if (expr->value.function.actual->next->expr)
5630     return ss;
5631
5632   newss = gfc_get_ss ();
5633   newss->type = GFC_SS_INTRINSIC;
5634   newss->expr = expr;
5635   newss->next = ss;
5636   newss->data.info.dimen = 1;
5637
5638   return newss;
5639 }
5640
5641
5642 /* Walk an intrinsic array libcall.  */
5643
5644 static gfc_ss *
5645 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5646 {
5647   gfc_ss *newss;
5648
5649   gcc_assert (expr->rank > 0);
5650
5651   newss = gfc_get_ss ();
5652   newss->type = GFC_SS_FUNCTION;
5653   newss->expr = expr;
5654   newss->next = ss;
5655   newss->data.info.dimen = expr->rank;
5656
5657   return newss;
5658 }
5659
5660
5661 /* Returns nonzero if the specified intrinsic function call maps directly to
5662    an external library call.  Should only be used for functions that return
5663    arrays.  */
5664
5665 int
5666 gfc_is_intrinsic_libcall (gfc_expr * expr)
5667 {
5668   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5669   gcc_assert (expr->rank > 0);
5670
5671   switch (expr->value.function.isym->id)
5672     {
5673     case GFC_ISYM_ALL:
5674     case GFC_ISYM_ANY:
5675     case GFC_ISYM_COUNT:
5676     case GFC_ISYM_MATMUL:
5677     case GFC_ISYM_MAXLOC:
5678     case GFC_ISYM_MAXVAL:
5679     case GFC_ISYM_MINLOC:
5680     case GFC_ISYM_MINVAL:
5681     case GFC_ISYM_PRODUCT:
5682     case GFC_ISYM_SUM:
5683     case GFC_ISYM_SHAPE:
5684     case GFC_ISYM_SPREAD:
5685     case GFC_ISYM_TRANSPOSE:
5686       /* Ignore absent optional parameters.  */
5687       return 1;
5688
5689     case GFC_ISYM_RESHAPE:
5690     case GFC_ISYM_CSHIFT:
5691     case GFC_ISYM_EOSHIFT:
5692     case GFC_ISYM_PACK:
5693     case GFC_ISYM_UNPACK:
5694       /* Pass absent optional parameters.  */
5695       return 2;
5696
5697     default:
5698       return 0;
5699     }
5700 }
5701
5702 /* Walk an intrinsic function.  */
5703 gfc_ss *
5704 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5705                              gfc_intrinsic_sym * isym)
5706 {
5707   gcc_assert (isym);
5708
5709   if (isym->elemental)
5710     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5711
5712   if (expr->rank == 0)
5713     return ss;
5714
5715   if (gfc_is_intrinsic_libcall (expr))
5716     return gfc_walk_intrinsic_libfunc (ss, expr);
5717
5718   /* Special cases.  */
5719   switch (isym->id)
5720     {
5721     case GFC_ISYM_LBOUND:
5722     case GFC_ISYM_UBOUND:
5723       return gfc_walk_intrinsic_bound (ss, expr);
5724
5725     case GFC_ISYM_TRANSFER:
5726       return gfc_walk_intrinsic_libfunc (ss, expr);
5727
5728     default:
5729       /* This probably meant someone forgot to add an intrinsic to the above
5730          list(s) when they implemented it, or something's gone horribly
5731          wrong.  */
5732       gcc_unreachable ();
5733     }
5734 }
5735
5736 #include "gt-fortran-trans-intrinsic.h"