gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct GTY(()) gfc_intrinsic_map_t {
  49   /* The explicit enum is required to work around inadequacies in the
  50      garbage collection/gengtype parsing mechanism.  */
  51   enum gfc_isym_id id;
  52
  53   /* Enum value from the "language-independent", aka C-centric, part
  54      of gcc, or END_BUILTINS of no such value set.  */
  55   enum built_in_function code_r4;
  56   enum built_in_function code_r8;
  57   enum built_in_function code_r10;
  58   enum built_in_function code_r16;
  59   enum built_in_function code_c4;
  60   enum built_in_function code_c8;
  61   enum built_in_function code_c10;
  62   enum built_in_function code_c16;
  63
  64   /* True if the naming pattern is to prepend "c" for complex and
  65      append "f" for kind=4.  False if the naming pattern is to
  66      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  67   bool libm_name;
  68
  69   /* True if a complex version of the function exists.  */
  70   bool complex_available;
  71
  72   /* True if the function should be marked const.  */
  73   bool is_constant;
  74
  75   /* The base library name of this function.  */
  76   const char *name;
  77
  78   /* Cache decls created for the various operand types.  */
  79   tree real4_decl;
  80   tree real8_decl;
  81   tree real10_decl;
  82   tree real16_decl;
  83   tree complex4_decl;
  84   tree complex8_decl;
  85   tree complex10_decl;
  86   tree complex16_decl;
  87 }
  88 gfc_intrinsic_map_t;
  89
  90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  91    defines complex variants of all of the entries in mathbuiltins.def
  92    except for atan2.  */
  93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  94   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  95     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, (enum built_in_function) 0, \
  96     (enum built_in_function) 0, (enum built_in_function) 0, \
  97     (enum built_in_function) 0, true, false, true, NAME, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  99     NULL_TREE},
 100
 101 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 102   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 103     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 104     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 105     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 106     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 107
 108 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 109   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 111     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 112     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 113
 114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 115 {
 116   /* Functions built into gcc itself.  */
 117 #include "mathbuiltins.def"
 118
 119   /* Functions in libgfortran.  */
 120   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
 121
 122   /* End the list.  */
 123   LIB_FUNCTION (NONE, NULL, false)
 124
 125 };
 126 #undef LIB_FUNCTION
 127 #undef DEFINE_MATH_BUILTIN
 128 #undef DEFINE_MATH_BUILTIN_C
 129
 130 /* Structure for storing components of a floating number to be used by
 131    elemental functions to manipulate reals.  */
 132 typedef struct
 133 {
 134   tree arg;     /* Variable tree to view convert to integer.  */
 135   tree expn;    /* Variable tree to save exponent.  */
 136   tree frac;    /* Variable tree to save fraction.  */
 137   tree smask;   /* Constant tree of sign's mask.  */
 138   tree emask;   /* Constant tree of exponent's mask.  */
 139   tree fmask;   /* Constant tree of fraction's mask.  */
 140   tree edigits; /* Constant tree of the number of exponent bits.  */
 141   tree fdigits; /* Constant tree of the number of fraction bits.  */
 142   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 143   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 144   tree type;    /* Type tree of arg1.  */
 145   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 146 }
 147 real_compnt_info;
 148
 149 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 150
 151 /* Evaluate the arguments to an intrinsic function.  The value
 152    of NARGS may be less than the actual number of arguments in EXPR
 153    to allow optional "KIND" arguments that are not included in the
 154    generated code to be ignored.  */
 155
 156 static void
 157 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 158                                   tree *argarray, int nargs)
 159 {
 160   gfc_actual_arglist *actual;
 161   gfc_expr *e;
 162   gfc_intrinsic_arg  *formal;
 163   gfc_se argse;
 164   int curr_arg;
 165
 166   formal = expr->value.function.isym->formal;
 167   actual = expr->value.function.actual;
 168
 169    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 170         actual = actual->next,
 171         formal = formal ? formal->next : NULL)
 172     {
 173       gcc_assert (actual);
 174       e = actual->expr;
 175       /* Skip omitted optional arguments.  */
 176       if (!e)
 177         {
 178           --curr_arg;
 179           continue;
 180         }
 181
 182       /* Evaluate the parameter.  This will substitute scalarized
 183          references automatically.  */
 184       gfc_init_se (&argse, se);
 185
 186       if (e->ts.type == BT_CHARACTER)
 187         {
 188           gfc_conv_expr (&argse, e);
 189           gfc_conv_string_parameter (&argse);
 190           argarray[curr_arg++] = argse.string_length;
 191           gcc_assert (curr_arg < nargs);
 192         }
 193       else
 194         gfc_conv_expr_val (&argse, e);
 195
 196       /* If an optional argument is itself an optional dummy argument,
 197          check its presence and substitute a null if absent.  */
 198       if (e->expr_type == EXPR_VARIABLE
 199             && e->symtree->n.sym->attr.optional
 200             && formal
 201             && formal->optional)
 202         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
 203
 204       gfc_add_block_to_block (&se->pre, &argse.pre);
 205       gfc_add_block_to_block (&se->post, &argse.post);
 206       argarray[curr_arg] = argse.expr;
 207     }
 208 }
 209
 210 /* Count the number of actual arguments to the intrinsic function EXPR
 211    including any "hidden" string length arguments.  */
 212
 213 static unsigned int
 214 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 215 {
 216   int n = 0;
 217   gfc_actual_arglist *actual;
 218
 219   for (actual = expr->value.function.actual; actual; actual = actual->next)
 220     {
 221       if (!actual->expr)
 222         continue;
 223
 224       if (actual->expr->ts.type == BT_CHARACTER)
 225         n += 2;
 226       else
 227         n++;
 228     }
 229
 230   return n;
 231 }
 232
 233
 234 /* Conversions between different types are output by the frontend as
 235    intrinsic functions.  We implement these directly with inline code.  */
 236
 237 static void
 238 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 239 {
 240   tree type;
 241   tree *args;
 242   int nargs;
 243
 244   nargs = gfc_intrinsic_argument_list_length (expr);
 245   args = (tree *) alloca (sizeof (tree) * nargs);
 246
 247   /* Evaluate all the arguments passed. Whilst we're only interested in the
 248      first one here, there are other parts of the front-end that assume this
 249      and will trigger an ICE if it's not the case.  */
 250   type = gfc_typenode_for_spec (&expr->ts);
 251   gcc_assert (expr->value.function.actual->expr);
 252   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 253
 254   /* Conversion between character kinds involves a call to a library
 255      function.  */
 256   if (expr->ts.type == BT_CHARACTER)
 257     {
 258       tree fndecl, var, addr, tmp;
 259
 260       if (expr->ts.kind == 1
 261           && expr->value.function.actual->expr->ts.kind == 4)
 262         fndecl = gfor_fndecl_convert_char4_to_char1;
 263       else if (expr->ts.kind == 4
 264                && expr->value.function.actual->expr->ts.kind == 1)
 265         fndecl = gfor_fndecl_convert_char1_to_char4;
 266       else
 267         gcc_unreachable ();
 268
 269       /* Create the variable storing the converted value.  */
 270       type = gfc_get_pchar_type (expr->ts.kind);
 271       var = gfc_create_var (type, "str");
 272       addr = gfc_build_addr_expr (build_pointer_type (type), var);
 273
 274       /* Call the library function that will perform the conversion.  */
 275       gcc_assert (nargs >= 2);
 276       tmp = build_call_expr_loc (input_location,
 277                              fndecl, 3, addr, args[0], args[1]);
 278       gfc_add_expr_to_block (&se->pre, tmp);
 279
 280       /* Free the temporary afterwards.  */
 281       tmp = gfc_call_free (var);
 282       gfc_add_expr_to_block (&se->post, tmp);
 283
 284       se->expr = var;
 285       se->string_length = args[0];
 286
 287       return;
 288     }
 289
 290   /* Conversion from complex to non-complex involves taking the real
 291      component of the value.  */
 292   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 293       && expr->ts.type != BT_COMPLEX)
 294     {
 295       tree artype;
 296
 297       artype = TREE_TYPE (TREE_TYPE (args[0]));
 298       args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 299     }
 300
 301   se->expr = convert (type, args[0]);
 302 }
 303
 304 /* This is needed because the gcc backend only implements
 305    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 306    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 307    Similarly for CEILING.  */
 308
 309 static tree
 310 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 311 {
 312   tree tmp;
 313   tree cond;
 314   tree argtype;
 315   tree intval;
 316
 317   argtype = TREE_TYPE (arg);
 318   arg = gfc_evaluate_now (arg, pblock);
 319
 320   intval = convert (type, arg);
 321   intval = gfc_evaluate_now (intval, pblock);
 322
 323   tmp = convert (argtype, intval);
 324   cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 325
 326   tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 327                      build_int_cst (type, 1));
 328   tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
 329   return tmp;
 330 }
 331
 332
 333 /* Round to nearest integer, away from zero.  */
 334
 335 static tree
 336 build_round_expr (tree arg, tree restype)
 337 {
 338   tree argtype;
 339   tree fn;
 340   bool longlong;
 341   int argprec, resprec;
 342
 343   argtype = TREE_TYPE (arg);
 344   argprec = TYPE_PRECISION (argtype);
 345   resprec = TYPE_PRECISION (restype);
 346
 347   /* Depending on the type of the result, choose the long int intrinsic
 348      (lround family) or long long intrinsic (llround).  We might also
 349      need to convert the result afterwards.  */
 350   if (resprec <= LONG_TYPE_SIZE)
 351     longlong = false;
 352   else if (resprec <= LONG_LONG_TYPE_SIZE)
 353     longlong = true;
 354   else
 355     gcc_unreachable ();
 356
 357   /* Now, depending on the argument type, we choose between intrinsics.  */
 358   if (argprec == TYPE_PRECISION (float_type_node))
 359     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
 360   else if (argprec == TYPE_PRECISION (double_type_node))
 361     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
 362   else if (argprec == TYPE_PRECISION (long_double_type_node))
 363     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
 364   else
 365     gcc_unreachable ();
 366
 367   return fold_convert (restype, build_call_expr_loc (input_location,
 368                                                  fn, 1, arg));
 369 }
 370
 371
 372 /* Convert a real to an integer using a specific rounding mode.
 373    Ideally we would just build the corresponding GENERIC node,
 374    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 375
 376 static tree
 377 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 378                enum rounding_mode op)
 379 {
 380   switch (op)
 381     {
 382     case RND_FLOOR:
 383       return build_fixbound_expr (pblock, arg, type, 0);
 384       break;
 385
 386     case RND_CEIL:
 387       return build_fixbound_expr (pblock, arg, type, 1);
 388       break;
 389
 390     case RND_ROUND:
 391       return build_round_expr (arg, type);
 392       break;
 393
 394     case RND_TRUNC:
 395       return fold_build1 (FIX_TRUNC_EXPR, type, arg);
 396       break;
 397
 398     default:
 399       gcc_unreachable ();
 400     }
 401 }
 402
 403
 404 /* Round a real value using the specified rounding mode.
 405    We use a temporary integer of that same kind size as the result.
 406    Values larger than those that can be represented by this kind are
 407    unchanged, as they will not be accurate enough to represent the
 408    rounding.
 409     huge = HUGE (KIND (a))
 410     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 411    */
 412
 413 static void
 414 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 415 {
 416   tree type;
 417   tree itype;
 418   tree arg[2];
 419   tree tmp;
 420   tree cond;
 421   mpfr_t huge;
 422   int n, nargs;
 423   int kind;
 424
 425   kind = expr->ts.kind;
 426   nargs =  gfc_intrinsic_argument_list_length (expr);
 427
 428   n = END_BUILTINS;
 429   /* We have builtin functions for some cases.  */
 430   switch (op)
 431     {
 432     case RND_ROUND:
 433       switch (kind)
 434         {
 435         case 4:
 436           n = BUILT_IN_ROUNDF;
 437           break;
 438
 439         case 8:
 440           n = BUILT_IN_ROUND;
 441           break;
 442
 443         case 10:
 444         case 16:
 445           n = BUILT_IN_ROUNDL;
 446           break;
 447         }
 448       break;
 449
 450     case RND_TRUNC:
 451       switch (kind)
 452         {
 453         case 4:
 454           n = BUILT_IN_TRUNCF;
 455           break;
 456
 457         case 8:
 458           n = BUILT_IN_TRUNC;
 459           break;
 460
 461         case 10:
 462         case 16:
 463           n = BUILT_IN_TRUNCL;
 464           break;
 465         }
 466       break;
 467
 468     default:
 469       gcc_unreachable ();
 470     }
 471
 472   /* Evaluate the argument.  */
 473   gcc_assert (expr->value.function.actual->expr);
 474   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
 475
 476   /* Use a builtin function if one exists.  */
 477   if (n != END_BUILTINS)
 478     {
 479       tmp = built_in_decls[n];
 480       se->expr = build_call_expr_loc (input_location,
 481                                   tmp, 1, arg[0]);
 482       return;
 483     }
 484
 485   /* This code is probably redundant, but we'll keep it lying around just
 486      in case.  */
 487   type = gfc_typenode_for_spec (&expr->ts);
 488   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
 489
 490   /* Test if the value is too large to handle sensibly.  */
 491   gfc_set_model_kind (kind);
 492   mpfr_init (huge);
 493   n = gfc_validate_kind (BT_INTEGER, kind, false);
 494   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 495   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 496   cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
 497
 498   mpfr_neg (huge, huge, GFC_RND_MODE);
 499   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 500   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
 501   cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 502   itype = gfc_get_int_type (kind);
 503
 504   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
 505   tmp = convert (type, tmp);
 506   se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
 507   mpfr_clear (huge);
 508 }
 509
 510
 511 /* Convert to an integer using the specified rounding mode.  */
 512
 513 static void
 514 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 515 {
 516   tree type;
 517   tree *args;
 518   int nargs;
 519
 520   nargs = gfc_intrinsic_argument_list_length (expr);
 521   args = (tree *) alloca (sizeof (tree) * nargs);
 522
 523   /* Evaluate the argument, we process all arguments even though we only
 524      use the first one for code generation purposes.  */
 525   type = gfc_typenode_for_spec (&expr->ts);
 526   gcc_assert (expr->value.function.actual->expr);
 527   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 528
 529   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 530     {
 531       /* Conversion to a different integer kind.  */
 532       se->expr = convert (type, args[0]);
 533     }
 534   else
 535     {
 536       /* Conversion from complex to non-complex involves taking the real
 537          component of the value.  */
 538       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 539           && expr->ts.type != BT_COMPLEX)
 540         {
 541           tree artype;
 542
 543           artype = TREE_TYPE (TREE_TYPE (args[0]));
 544           args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 545         }
 546
 547       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 548     }
 549 }
 550
 551
 552 /* Get the imaginary component of a value.  */
 553
 554 static void
 555 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 556 {
 557   tree arg;
 558
 559   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 560   se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 561 }
 562
 563
 564 /* Get the complex conjugate of a value.  */
 565
 566 static void
 567 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 568 {
 569   tree arg;
 570
 571   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 572   se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 573 }
 574
 575
 576 /* Initialize function decls for library functions.  The external functions
 577    are created as required.  Builtin functions are added here.  */
 578
 579 void
 580 gfc_build_intrinsic_lib_fndecls (void)
 581 {
 582   gfc_intrinsic_map_t *m;
 583
 584   /* Add GCC builtin functions.  */
 585   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 586     {
 587       if (m->code_r4 != END_BUILTINS)
 588         m->real4_decl = built_in_decls[m->code_r4];
 589       if (m->code_r8 != END_BUILTINS)
 590         m->real8_decl = built_in_decls[m->code_r8];
 591       if (m->code_r10 != END_BUILTINS)
 592         m->real10_decl = built_in_decls[m->code_r10];
 593       if (m->code_r16 != END_BUILTINS)
 594         m->real16_decl = built_in_decls[m->code_r16];
 595       if (m->code_c4 != END_BUILTINS)
 596         m->complex4_decl = built_in_decls[m->code_c4];
 597       if (m->code_c8 != END_BUILTINS)
 598         m->complex8_decl = built_in_decls[m->code_c8];
 599       if (m->code_c10 != END_BUILTINS)
 600         m->complex10_decl = built_in_decls[m->code_c10];
 601       if (m->code_c16 != END_BUILTINS)
 602         m->complex16_decl = built_in_decls[m->code_c16];
 603     }
 604 }
 605
 606
 607 /* Create a fndecl for a simple intrinsic library function.  */
 608
 609 static tree
 610 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 611 {
 612   tree type;
 613   tree argtypes;
 614   tree fndecl;
 615   gfc_actual_arglist *actual;
 616   tree *pdecl;
 617   gfc_typespec *ts;
 618   char name[GFC_MAX_SYMBOL_LEN + 3];
 619
 620   ts = &expr->ts;
 621   if (ts->type == BT_REAL)
 622     {
 623       switch (ts->kind)
 624         {
 625         case 4:
 626           pdecl = &m->real4_decl;
 627           break;
 628         case 8:
 629           pdecl = &m->real8_decl;
 630           break;
 631         case 10:
 632           pdecl = &m->real10_decl;
 633           break;
 634         case 16:
 635           pdecl = &m->real16_decl;
 636           break;
 637         default:
 638           gcc_unreachable ();
 639         }
 640     }
 641   else if (ts->type == BT_COMPLEX)
 642     {
 643       gcc_assert (m->complex_available);
 644
 645       switch (ts->kind)
 646         {
 647         case 4:
 648           pdecl = &m->complex4_decl;
 649           break;
 650         case 8:
 651           pdecl = &m->complex8_decl;
 652           break;
 653         case 10:
 654           pdecl = &m->complex10_decl;
 655           break;
 656         case 16:
 657           pdecl = &m->complex16_decl;
 658           break;
 659         default:
 660           gcc_unreachable ();
 661         }
 662     }
 663   else
 664     gcc_unreachable ();
 665
 666   if (*pdecl)
 667     return *pdecl;
 668
 669   if (m->libm_name)
 670     {
 671       if (ts->kind == 4)
 672         snprintf (name, sizeof (name), "%s%s%s",
 673                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 674       else if (ts->kind == 8)
 675         snprintf (name, sizeof (name), "%s%s",
 676                 ts->type == BT_COMPLEX ? "c" : "", m->name);
 677       else
 678         {
 679           gcc_assert (ts->kind == 10 || ts->kind == 16);
 680           snprintf (name, sizeof (name), "%s%s%s",
 681                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 682         }
 683     }
 684   else
 685     {
 686       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 687                 ts->type == BT_COMPLEX ? 'c' : 'r',
 688                 ts->kind);
 689     }
 690
 691   argtypes = NULL_TREE;
 692   for (actual = expr->value.function.actual; actual; actual = actual->next)
 693     {
 694       type = gfc_typenode_for_spec (&actual->expr->ts);
 695       argtypes = gfc_chainon_list (argtypes, type);
 696     }
 697   argtypes = gfc_chainon_list (argtypes, void_type_node);
 698   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 699   fndecl = build_decl (input_location,
 700                        FUNCTION_DECL, get_identifier (name), type);
 701
 702   /* Mark the decl as external.  */
 703   DECL_EXTERNAL (fndecl) = 1;
 704   TREE_PUBLIC (fndecl) = 1;
 705
 706   /* Mark it __attribute__((const)), if possible.  */
 707   TREE_READONLY (fndecl) = m->is_constant;
 708
 709   rest_of_decl_compilation (fndecl, 1, 0);
 710
 711   (*pdecl) = fndecl;
 712   return fndecl;
 713 }
 714
 715
 716 /* Convert an intrinsic function into an external or builtin call.  */
 717
 718 static void
 719 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 720 {
 721   gfc_intrinsic_map_t *m;
 722   tree fndecl;
 723   tree rettype;
 724   tree *args;
 725   unsigned int num_args;
 726   gfc_isym_id id;
 727
 728   id = expr->value.function.isym->id;
 729   /* Find the entry for this function.  */
 730   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 731     {
 732       if (id == m->id)
 733         break;
 734     }
 735
 736   if (m->id == GFC_ISYM_NONE)
 737     {
 738       internal_error ("Intrinsic function %s(%d) not recognized",
 739                       expr->value.function.name, id);
 740     }
 741
 742   /* Get the decl and generate the call.  */
 743   num_args = gfc_intrinsic_argument_list_length (expr);
 744   args = (tree *) alloca (sizeof (tree) * num_args);
 745
 746   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 747   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 748   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 749
 750   fndecl = build_addr (fndecl, current_function_decl);
 751   se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
 752 }
 753
 754
 755 /* If bounds-checking is enabled, create code to verify at runtime that the
 756    string lengths for both expressions are the same (needed for e.g. MERGE).
 757    If bounds-checking is not enabled, does nothing.  */
 758
 759 void
 760 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
 761                              tree a, tree b, stmtblock_t* target)
 762 {
 763   tree cond;
 764   tree name;
 765
 766   /* If bounds-checking is disabled, do nothing.  */
 767   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
 768     return;
 769
 770   /* Compare the two string lengths.  */
 771   cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
 772
 773   /* Output the runtime-check.  */
 774   name = gfc_build_cstring_const (intr_name);
 775   name = gfc_build_addr_expr (pchar_type_node, name);
 776   gfc_trans_runtime_check (true, false, cond, target, where,
 777                            "Unequal character lengths (%ld/%ld) in %s",
 778                            fold_convert (long_integer_type_node, a),
 779                            fold_convert (long_integer_type_node, b), name);
 780 }
 781
 782
 783 /* The EXPONENT(s) intrinsic function is translated into
 784        int ret;
 785        frexp (s, &ret);
 786        return ret;
 787  */
 788
 789 static void
 790 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 791 {
 792   tree arg, type, res, tmp;
 793   int frexp;
 794
 795   switch (expr->value.function.actual->expr->ts.kind)
 796     {
 797     case 4:
 798       frexp = BUILT_IN_FREXPF;
 799       break;
 800     case 8:
 801       frexp = BUILT_IN_FREXP;
 802       break;
 803     case 10:
 804     case 16:
 805       frexp = BUILT_IN_FREXPL;
 806       break;
 807     default:
 808       gcc_unreachable ();
 809     }
 810
 811   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 812
 813   res = gfc_create_var (integer_type_node, NULL);
 814   tmp = build_call_expr_loc (input_location,
 815                          built_in_decls[frexp], 2, arg,
 816                          gfc_build_addr_expr (NULL_TREE, res));
 817   gfc_add_expr_to_block (&se->pre, tmp);
 818
 819   type = gfc_typenode_for_spec (&expr->ts);
 820   se->expr = fold_convert (type, res);
 821 }
 822
 823 /* Evaluate a single upper or lower bound.  */
 824 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 825
 826 static void
 827 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 828 {
 829   gfc_actual_arglist *arg;
 830   gfc_actual_arglist *arg2;
 831   tree desc;
 832   tree type;
 833   tree bound;
 834   tree tmp;
 835   tree cond, cond1, cond3, cond4, size;
 836   tree ubound;
 837   tree lbound;
 838   gfc_se argse;
 839   gfc_ss *ss;
 840   gfc_array_spec * as;
 841
 842   arg = expr->value.function.actual;
 843   arg2 = arg->next;
 844
 845   if (se->ss)
 846     {
 847       /* Create an implicit second parameter from the loop variable.  */
 848       gcc_assert (!arg2->expr);
 849       gcc_assert (se->loop->dimen == 1);
 850       gcc_assert (se->ss->expr == expr);
 851       gfc_advance_se_ss_chain (se);
 852       bound = se->loop->loopvar[0];
 853       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 854                            se->loop->from[0]);
 855     }
 856   else
 857     {
 858       /* use the passed argument.  */
 859       gcc_assert (arg->next->expr);
 860       gfc_init_se (&argse, NULL);
 861       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 862       gfc_add_block_to_block (&se->pre, &argse.pre);
 863       bound = argse.expr;
 864       /* Convert from one based to zero based.  */
 865       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 866                            gfc_index_one_node);
 867     }
 868
 869   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 870   /* Get a descriptor for the first parameter.  */
 871   ss = gfc_walk_expr (arg->expr);
 872   gcc_assert (ss != gfc_ss_terminator);
 873   gfc_init_se (&argse, NULL);
 874   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 875   gfc_add_block_to_block (&se->pre, &argse.pre);
 876   gfc_add_block_to_block (&se->post, &argse.post);
 877
 878   desc = argse.expr;
 879
 880   if (INTEGER_CST_P (bound))
 881     {
 882       int hi, low;
 883
 884       hi = TREE_INT_CST_HIGH (bound);
 885       low = TREE_INT_CST_LOW (bound);
 886       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 887         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 888                    "dimension index", upper ? "UBOUND" : "LBOUND",
 889                    &expr->where);
 890     }
 891   else
 892     {
 893       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 894         {
 895           bound = gfc_evaluate_now (bound, &se->pre);
 896           cond = fold_build2 (LT_EXPR, boolean_type_node,
 897                               bound, build_int_cst (TREE_TYPE (bound), 0));
 898           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 899           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 900           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 901           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
 902                                    gfc_msg_fault);
 903         }
 904     }
 905
 906   ubound = gfc_conv_descriptor_ubound_get (desc, bound);
 907   lbound = gfc_conv_descriptor_lbound_get (desc, bound);
 908
 909   as = gfc_get_full_arrayspec_from_expr (arg->expr);
 910
 911   /* 13.14.53: Result value for LBOUND
 912
 913      Case (i): For an array section or for an array expression other than a
 914                whole array or array structure component, LBOUND(ARRAY, DIM)
 915                has the value 1.  For a whole array or array structure
 916                component, LBOUND(ARRAY, DIM) has the value:
 917                  (a) equal to the lower bound for subscript DIM of ARRAY if
 918                      dimension DIM of ARRAY does not have extent zero
 919                      or if ARRAY is an assumed-size array of rank DIM,
 920               or (b) 1 otherwise.
 921
 922      13.14.113: Result value for UBOUND
 923
 924      Case (i): For an array section or for an array expression other than a
 925                whole array or array structure component, UBOUND(ARRAY, DIM)
 926                has the value equal to the number of elements in the given
 927                dimension; otherwise, it has a value equal to the upper bound
 928                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 929                not have size zero and has value zero if dimension DIM has
 930                size zero.  */
 931
 932   if (as)
 933     {
 934       tree stride = gfc_conv_descriptor_stride_get (desc, bound);
 935
 936       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 937
 938       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 939                            gfc_index_zero_node);
 940       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 941
 942       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 943                            gfc_index_zero_node);
 944
 945       if (upper)
 946         {
 947           tree cond5;
 948           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 949
 950           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
 951           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
 952
 953           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
 954
 955           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 956                                   ubound, gfc_index_zero_node);
 957         }
 958       else
 959         {
 960           if (as->type == AS_ASSUMED_SIZE)
 961             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 962                                 build_int_cst (TREE_TYPE (bound),
 963                                                arg->expr->rank - 1));
 964           else
 965             cond = boolean_false_node;
 966
 967           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 968           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 969
 970           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 971                                   lbound, gfc_index_one_node);
 972         }
 973     }
 974   else
 975     {
 976       if (upper)
 977         {
 978           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
 979           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 980                                   gfc_index_one_node);
 981           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
 982                                   gfc_index_zero_node);
 983         }
 984       else
 985         se->expr = gfc_index_one_node;
 986     }
 987
 988   type = gfc_typenode_for_spec (&expr->ts);
 989   se->expr = convert (type, se->expr);
 990 }
 991
 992
 993 static void
 994 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 995 {
 996   tree arg;
 997   int n;
 998
 999   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1000
1001   switch (expr->value.function.actual->expr->ts.type)
1002     {
1003     case BT_INTEGER:
1004     case BT_REAL:
1005       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1006       break;
1007
1008     case BT_COMPLEX:
1009       switch (expr->ts.kind)
1010         {
1011         case 4:
1012           n = BUILT_IN_CABSF;
1013           break;
1014         case 8:
1015           n = BUILT_IN_CABS;
1016           break;
1017         case 10:
1018         case 16:
1019           n = BUILT_IN_CABSL;
1020           break;
1021         default:
1022           gcc_unreachable ();
1023         }
1024       se->expr = build_call_expr_loc (input_location,
1025                                   built_in_decls[n], 1, arg);
1026       break;
1027
1028     default:
1029       gcc_unreachable ();
1030     }
1031 }
1032
1033
1034 /* Create a complex value from one or two real components.  */
1035
1036 static void
1037 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1038 {
1039   tree real;
1040   tree imag;
1041   tree type;
1042   tree *args;
1043   unsigned int num_args;
1044
1045   num_args = gfc_intrinsic_argument_list_length (expr);
1046   args = (tree *) alloca (sizeof (tree) * num_args);
1047
1048   type = gfc_typenode_for_spec (&expr->ts);
1049   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1050   real = convert (TREE_TYPE (type), args[0]);
1051   if (both)
1052     imag = convert (TREE_TYPE (type), args[1]);
1053   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1054     {
1055       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1056                           args[0]);
1057       imag = convert (TREE_TYPE (type), imag);
1058     }
1059   else
1060     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1061
1062   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1063 }
1064
1065 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1066                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1067 /* TODO: MOD(x, 0)  */
1068
1069 static void
1070 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1071 {
1072   tree type;
1073   tree itype;
1074   tree tmp;
1075   tree test;
1076   tree test2;
1077   mpfr_t huge;
1078   int n, ikind;
1079   tree args[2];
1080
1081   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1082
1083   switch (expr->ts.type)
1084     {
1085     case BT_INTEGER:
1086       /* Integer case is easy, we've got a builtin op.  */
1087       type = TREE_TYPE (args[0]);
1088
1089       if (modulo)
1090        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1091       else
1092        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1093       break;
1094
1095     case BT_REAL:
1096       n = END_BUILTINS;
1097       /* Check if we have a builtin fmod.  */
1098       switch (expr->ts.kind)
1099         {
1100         case 4:
1101           n = BUILT_IN_FMODF;
1102           break;
1103
1104         case 8:
1105           n = BUILT_IN_FMOD;
1106           break;
1107
1108         case 10:
1109         case 16:
1110           n = BUILT_IN_FMODL;
1111           break;
1112
1113         default:
1114           break;
1115         }
1116
1117       /* Use it if it exists.  */
1118       if (n != END_BUILTINS)
1119         {
1120           tmp = build_addr (built_in_decls[n], current_function_decl);
1121           se->expr = build_call_array_loc (input_location,
1122                                        TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1123                                        tmp, 2, args);
1124           if (modulo == 0)
1125             return;
1126         }
1127
1128       type = TREE_TYPE (args[0]);
1129
1130       args[0] = gfc_evaluate_now (args[0], &se->pre);
1131       args[1] = gfc_evaluate_now (args[1], &se->pre);
1132
1133       /* Definition:
1134          modulo = arg - floor (arg/arg2) * arg2, so
1135                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1136          where
1137           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1138          thereby avoiding another division and retaining the accuracy
1139          of the builtin function.  */
1140       if (n != END_BUILTINS && modulo)
1141         {
1142           tree zero = gfc_build_const (type, integer_zero_node);
1143           tmp = gfc_evaluate_now (se->expr, &se->pre);
1144           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1145           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1146           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1147           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1148           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1149           test = gfc_evaluate_now (test, &se->pre);
1150           se->expr = fold_build3 (COND_EXPR, type, test,
1151                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1152                                   tmp);
1153           return;
1154         }
1155
1156       /* If we do not have a built_in fmod, the calculation is going to
1157          have to be done longhand.  */
1158       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1159
1160       /* Test if the value is too large to handle sensibly.  */
1161       gfc_set_model_kind (expr->ts.kind);
1162       mpfr_init (huge);
1163       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1164       ikind = expr->ts.kind;
1165       if (n < 0)
1166         {
1167           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1168           ikind = gfc_max_integer_kind;
1169         }
1170       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1171       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1172       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1173
1174       mpfr_neg (huge, huge, GFC_RND_MODE);
1175       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1176       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1177       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1178
1179       itype = gfc_get_int_type (ikind);
1180       if (modulo)
1181        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1182       else
1183        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1184       tmp = convert (type, tmp);
1185       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1186       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1187       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1188       mpfr_clear (huge);
1189       break;
1190
1191     default:
1192       gcc_unreachable ();
1193     }
1194 }
1195
1196 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1197
1198 static void
1199 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1200 {
1201   tree val;
1202   tree tmp;
1203   tree type;
1204   tree zero;
1205   tree args[2];
1206
1207   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1208   type = TREE_TYPE (args[0]);
1209
1210   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1211   val = gfc_evaluate_now (val, &se->pre);
1212
1213   zero = gfc_build_const (type, integer_zero_node);
1214   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1215   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1216 }
1217
1218
1219 /* SIGN(A, B) is absolute value of A times sign of B.
1220    The real value versions use library functions to ensure the correct
1221    handling of negative zero.  Integer case implemented as:
1222    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1223   */
1224
1225 static void
1226 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1227 {
1228   tree tmp;
1229   tree type;
1230   tree args[2];
1231
1232   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1233   if (expr->ts.type == BT_REAL)
1234     {
1235       tree abs;
1236
1237       switch (expr->ts.kind)
1238         {
1239         case 4:
1240           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1241           abs = built_in_decls[BUILT_IN_FABSF];
1242           break;
1243         case 8:
1244           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1245           abs = built_in_decls[BUILT_IN_FABS];
1246           break;
1247         case 10:
1248         case 16:
1249           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1250           abs = built_in_decls[BUILT_IN_FABSL];
1251           break;
1252         default:
1253           gcc_unreachable ();
1254         }
1255
1256       /* We explicitly have to ignore the minus sign. We do so by using
1257          result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1).  */
1258       if (!gfc_option.flag_sign_zero
1259           && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1260         {
1261           tree cond, zero;
1262           zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1263           cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
1264           se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
1265                                   build_call_expr (abs, 1, args[0]),
1266                                   build_call_expr (tmp, 2, args[0], args[1]));
1267         }
1268       else
1269         se->expr = build_call_expr_loc (input_location,
1270                                   tmp, 2, args[0], args[1]);
1271       return;
1272     }
1273
1274   /* Having excluded floating point types, we know we are now dealing
1275      with signed integer types.  */
1276   type = TREE_TYPE (args[0]);
1277
1278   /* Args[0] is used multiple times below.  */
1279   args[0] = gfc_evaluate_now (args[0], &se->pre);
1280
1281   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1282      the signs of A and B are the same, and of all ones if they differ.  */
1283   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1284   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1285                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1286   tmp = gfc_evaluate_now (tmp, &se->pre);
1287
1288   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1289      is all ones (i.e. -1).  */
1290   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1291                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1292                           tmp);
1293 }
1294
1295
1296 /* Test for the presence of an optional argument.  */
1297
1298 static void
1299 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1300 {
1301   gfc_expr *arg;
1302
1303   arg = expr->value.function.actual->expr;
1304   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1305   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1306   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1307 }
1308
1309
1310 /* Calculate the double precision product of two single precision values.  */
1311
1312 static void
1313 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1314 {
1315   tree type;
1316   tree args[2];
1317
1318   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1319
1320   /* Convert the args to double precision before multiplying.  */
1321   type = gfc_typenode_for_spec (&expr->ts);
1322   args[0] = convert (type, args[0]);
1323   args[1] = convert (type, args[1]);
1324   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1325 }
1326
1327
1328 /* Return a length one character string containing an ascii character.  */
1329
1330 static void
1331 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1332 {
1333   tree arg[2];
1334   tree var;
1335   tree type;
1336   unsigned int num_args;
1337
1338   num_args = gfc_intrinsic_argument_list_length (expr);
1339   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1340
1341   type = gfc_get_char_type (expr->ts.kind);
1342   var = gfc_create_var (type, "char");
1343
1344   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1345   gfc_add_modify (&se->pre, var, arg[0]);
1346   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1347   se->string_length = integer_one_node;
1348 }
1349
1350
1351 static void
1352 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1353 {
1354   tree var;
1355   tree len;
1356   tree tmp;
1357   tree cond;
1358   tree fndecl;
1359   tree *args;
1360   unsigned int num_args;
1361
1362   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1363   args = (tree *) alloca (sizeof (tree) * num_args);
1364
1365   var = gfc_create_var (pchar_type_node, "pstr");
1366   len = gfc_create_var (gfc_get_int_type (8), "len");
1367
1368   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1369   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1370   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1371
1372   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1373   tmp = build_call_array_loc (input_location,
1374                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1375                           fndecl, num_args, args);
1376   gfc_add_expr_to_block (&se->pre, tmp);
1377
1378   /* Free the temporary afterwards, if necessary.  */
1379   cond = fold_build2 (GT_EXPR, boolean_type_node,
1380                       len, build_int_cst (TREE_TYPE (len), 0));
1381   tmp = gfc_call_free (var);
1382   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1383   gfc_add_expr_to_block (&se->post, tmp);
1384
1385   se->expr = var;
1386   se->string_length = len;
1387 }
1388
1389
1390 static void
1391 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1392 {
1393   tree var;
1394   tree len;
1395   tree tmp;
1396   tree cond;
1397   tree fndecl;
1398   tree *args;
1399   unsigned int num_args;
1400
1401   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1402   args = (tree *) alloca (sizeof (tree) * num_args);
1403
1404   var = gfc_create_var (pchar_type_node, "pstr");
1405   len = gfc_create_var (gfc_get_int_type (4), "len");
1406
1407   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1408   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1409   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1410
1411   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1412   tmp = build_call_array_loc (input_location,
1413                           TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1414                           fndecl, num_args, args);
1415   gfc_add_expr_to_block (&se->pre, tmp);
1416
1417   /* Free the temporary afterwards, if necessary.  */
1418   cond = fold_build2 (GT_EXPR, boolean_type_node,
1419                       len, build_int_cst (TREE_TYPE (len), 0));
1420   tmp = gfc_call_free (var);
1421   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1422   gfc_add_expr_to_block (&se->post, tmp);
1423
1424   se->expr = var;
1425   se->string_length = len;
1426 }
1427
1428
1429 /* Return a character string containing the tty name.  */
1430
1431 static void
1432 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1433 {
1434   tree var;
1435   tree len;
1436   tree tmp;
1437   tree cond;
1438   tree fndecl;
1439   tree *args;
1440   unsigned int num_args;
1441
1442   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1443   args = (tree *) alloca (sizeof (tree) * num_args);
1444
1445   var = gfc_create_var (pchar_type_node, "pstr");
1446   len = gfc_create_var (gfc_get_int_type (4), "len");
1447
1448   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1449   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1450   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1451
1452   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1453   tmp = build_call_array_loc (input_location,
1454                           TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1455                           fndecl, num_args, args);
1456   gfc_add_expr_to_block (&se->pre, tmp);
1457
1458   /* Free the temporary afterwards, if necessary.  */
1459   cond = fold_build2 (GT_EXPR, boolean_type_node,
1460                       len, build_int_cst (TREE_TYPE (len), 0));
1461   tmp = gfc_call_free (var);
1462   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1463   gfc_add_expr_to_block (&se->post, tmp);
1464
1465   se->expr = var;
1466   se->string_length = len;
1467 }
1468
1469
1470 /* Get the minimum/maximum value of all the parameters.
1471     minmax (a1, a2, a3, ...)
1472     {
1473       mvar = a1;
1474       if (a2 .op. mvar || isnan(mvar))
1475         mvar = a2;
1476       if (a3 .op. mvar || isnan(mvar))
1477         mvar = a3;
1478       ...
1479       return mvar
1480     }
1481  */
1482
1483 /* TODO: Mismatching types can occur when specific names are used.
1484    These should be handled during resolution.  */
1485 static void
1486 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1487 {
1488   tree tmp;
1489   tree mvar;
1490   tree val;
1491   tree thencase;
1492   tree *args;
1493   tree type;
1494   gfc_actual_arglist *argexpr;
1495   unsigned int i, nargs;
1496
1497   nargs = gfc_intrinsic_argument_list_length (expr);
1498   args = (tree *) alloca (sizeof (tree) * nargs);
1499
1500   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1501   type = gfc_typenode_for_spec (&expr->ts);
1502
1503   argexpr = expr->value.function.actual;
1504   if (TREE_TYPE (args[0]) != type)
1505     args[0] = convert (type, args[0]);
1506   /* Only evaluate the argument once.  */
1507   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1508     args[0] = gfc_evaluate_now (args[0], &se->pre);
1509
1510   mvar = gfc_create_var (type, "M");
1511   gfc_add_modify (&se->pre, mvar, args[0]);
1512   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1513     {
1514       tree cond, isnan;
1515
1516       val = args[i];
1517
1518       /* Handle absent optional arguments by ignoring the comparison.  */
1519       if (argexpr->expr->expr_type == EXPR_VARIABLE
1520           && argexpr->expr->symtree->n.sym->attr.optional
1521           && TREE_CODE (val) == INDIRECT_REF)
1522         cond = fold_build2_loc (input_location,
1523                                 NE_EXPR, boolean_type_node,
1524                                 TREE_OPERAND (val, 0),
1525                         build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1526       else
1527       {
1528         cond = NULL_TREE;
1529
1530         /* Only evaluate the argument once.  */
1531         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1532           val = gfc_evaluate_now (val, &se->pre);
1533       }
1534
1535       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1536
1537       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1538
1539       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1540          __builtin_isnan might be made dependent on that module being loaded,
1541          to help performance of programs that don't rely on IEEE semantics.  */
1542       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1543         {
1544           isnan = build_call_expr_loc (input_location,
1545                                    built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1546           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1547                              fold_convert (boolean_type_node, isnan));
1548         }
1549       tmp = build3_v (COND_EXPR, tmp, thencase,
1550                       build_empty_stmt (input_location));
1551
1552       if (cond != NULL_TREE)
1553         tmp = build3_v (COND_EXPR, cond, tmp,
1554                         build_empty_stmt (input_location));
1555
1556       gfc_add_expr_to_block (&se->pre, tmp);
1557       argexpr = argexpr->next;
1558     }
1559   se->expr = mvar;
1560 }
1561
1562
1563 /* Generate library calls for MIN and MAX intrinsics for character
1564    variables.  */
1565 static void
1566 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1567 {
1568   tree *args;
1569   tree var, len, fndecl, tmp, cond, function;
1570   unsigned int nargs;
1571
1572   nargs = gfc_intrinsic_argument_list_length (expr);
1573   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1574   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1575
1576   /* Create the result variables.  */
1577   len = gfc_create_var (gfc_charlen_type_node, "len");
1578   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1579   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1580   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1581   args[2] = build_int_cst (NULL_TREE, op);
1582   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1583
1584   if (expr->ts.kind == 1)
1585     function = gfor_fndecl_string_minmax;
1586   else if (expr->ts.kind == 4)
1587     function = gfor_fndecl_string_minmax_char4;
1588   else
1589     gcc_unreachable ();
1590
1591   /* Make the function call.  */
1592   fndecl = build_addr (function, current_function_decl);
1593   tmp = build_call_array_loc (input_location,
1594                           TREE_TYPE (TREE_TYPE (function)), fndecl,
1595                           nargs + 4, args);
1596   gfc_add_expr_to_block (&se->pre, tmp);
1597
1598   /* Free the temporary afterwards, if necessary.  */
1599   cond = fold_build2 (GT_EXPR, boolean_type_node,
1600                       len, build_int_cst (TREE_TYPE (len), 0));
1601   tmp = gfc_call_free (var);
1602   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
1603   gfc_add_expr_to_block (&se->post, tmp);
1604
1605   se->expr = var;
1606   se->string_length = len;
1607 }
1608
1609
1610 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1611    has the generic name.  */
1612
1613 static gfc_symbol *
1614 gfc_get_symbol_for_expr (gfc_expr * expr)
1615 {
1616   gfc_symbol *sym;
1617
1618   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1619   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1620   sym = gfc_new_symbol (expr->value.function.name, NULL);
1621
1622   sym->ts = expr->ts;
1623   sym->attr.external = 1;
1624   sym->attr.function = 1;
1625   sym->attr.always_explicit = 1;
1626   sym->attr.proc = PROC_INTRINSIC;
1627   sym->attr.flavor = FL_PROCEDURE;
1628   sym->result = sym;
1629   if (expr->rank > 0)
1630     {
1631       sym->attr.dimension = 1;
1632       sym->as = gfc_get_array_spec ();
1633       sym->as->type = AS_ASSUMED_SHAPE;
1634       sym->as->rank = expr->rank;
1635     }
1636
1637   /* TODO: proper argument lists for external intrinsics.  */
1638   return sym;
1639 }
1640
1641 /* Generate a call to an external intrinsic function.  */
1642 static void
1643 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1644 {
1645   gfc_symbol *sym;
1646   tree append_args;
1647
1648   gcc_assert (!se->ss || se->ss->expr == expr);
1649
1650   if (se->ss)
1651     gcc_assert (expr->rank > 0);
1652   else
1653     gcc_assert (expr->rank == 0);
1654
1655   sym = gfc_get_symbol_for_expr (expr);
1656
1657   /* Calls to libgfortran_matmul need to be appended special arguments,
1658      to be able to call the BLAS ?gemm functions if required and possible.  */
1659   append_args = NULL_TREE;
1660   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1661       && sym->ts.type != BT_LOGICAL)
1662     {
1663       tree cint = gfc_get_int_type (gfc_c_int_kind);
1664
1665       if (gfc_option.flag_external_blas
1666           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1667           && (sym->ts.kind == gfc_default_real_kind
1668               || sym->ts.kind == gfc_default_double_kind))
1669         {
1670           tree gemm_fndecl;
1671
1672           if (sym->ts.type == BT_REAL)
1673             {
1674               if (sym->ts.kind == gfc_default_real_kind)
1675                 gemm_fndecl = gfor_fndecl_sgemm;
1676               else
1677                 gemm_fndecl = gfor_fndecl_dgemm;
1678             }
1679           else
1680             {
1681               if (sym->ts.kind == gfc_default_real_kind)
1682                 gemm_fndecl = gfor_fndecl_cgemm;
1683               else
1684                 gemm_fndecl = gfor_fndecl_zgemm;
1685             }
1686
1687           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1688           append_args = gfc_chainon_list
1689                           (append_args, build_int_cst
1690                                           (cint, gfc_option.blas_matmul_limit));
1691           append_args = gfc_chainon_list (append_args,
1692                                           gfc_build_addr_expr (NULL_TREE,
1693                                                                gemm_fndecl));
1694         }
1695       else
1696         {
1697           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1698           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1699           append_args = gfc_chainon_list (append_args, null_pointer_node);
1700         }
1701     }
1702
1703   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
1704                           append_args);
1705   gfc_free (sym);
1706 }
1707
1708 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1709    Implemented as
1710     any(a)
1711     {
1712       forall (i=...)
1713         if (a[i] != 0)
1714           return 1
1715       end forall
1716       return 0
1717     }
1718     all(a)
1719     {
1720       forall (i=...)
1721         if (a[i] == 0)
1722           return 0
1723       end forall
1724       return 1
1725     }
1726  */
1727 static void
1728 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1729 {
1730   tree resvar;
1731   stmtblock_t block;
1732   stmtblock_t body;
1733   tree type;
1734   tree tmp;
1735   tree found;
1736   gfc_loopinfo loop;
1737   gfc_actual_arglist *actual;
1738   gfc_ss *arrayss;
1739   gfc_se arrayse;
1740   tree exit_label;
1741
1742   if (se->ss)
1743     {
1744       gfc_conv_intrinsic_funcall (se, expr);
1745       return;
1746     }
1747
1748   actual = expr->value.function.actual;
1749   type = gfc_typenode_for_spec (&expr->ts);
1750   /* Initialize the result.  */
1751   resvar = gfc_create_var (type, "test");
1752   if (op == EQ_EXPR)
1753     tmp = convert (type, boolean_true_node);
1754   else
1755     tmp = convert (type, boolean_false_node);
1756   gfc_add_modify (&se->pre, resvar, tmp);
1757
1758   /* Walk the arguments.  */
1759   arrayss = gfc_walk_expr (actual->expr);
1760   gcc_assert (arrayss != gfc_ss_terminator);
1761
1762   /* Initialize the scalarizer.  */
1763   gfc_init_loopinfo (&loop);
1764   exit_label = gfc_build_label_decl (NULL_TREE);
1765   TREE_USED (exit_label) = 1;
1766   gfc_add_ss_to_loop (&loop, arrayss);
1767
1768   /* Initialize the loop.  */
1769   gfc_conv_ss_startstride (&loop);
1770   gfc_conv_loop_setup (&loop, &expr->where);
1771
1772   gfc_mark_ss_chain_used (arrayss, 1);
1773   /* Generate the loop body.  */
1774   gfc_start_scalarized_body (&loop, &body);
1775
1776   /* If the condition matches then set the return value.  */
1777   gfc_start_block (&block);
1778   if (op == EQ_EXPR)
1779     tmp = convert (type, boolean_false_node);
1780   else
1781     tmp = convert (type, boolean_true_node);
1782   gfc_add_modify (&block, resvar, tmp);
1783
1784   /* And break out of the loop.  */
1785   tmp = build1_v (GOTO_EXPR, exit_label);
1786   gfc_add_expr_to_block (&block, tmp);
1787
1788   found = gfc_finish_block (&block);
1789
1790   /* Check this element.  */
1791   gfc_init_se (&arrayse, NULL);
1792   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1793   arrayse.ss = arrayss;
1794   gfc_conv_expr_val (&arrayse, actual->expr);
1795
1796   gfc_add_block_to_block (&body, &arrayse.pre);
1797   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1798                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1799   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
1800   gfc_add_expr_to_block (&body, tmp);
1801   gfc_add_block_to_block (&body, &arrayse.post);
1802
1803   gfc_trans_scalarizing_loops (&loop, &body);
1804
1805   /* Add the exit label.  */
1806   tmp = build1_v (LABEL_EXPR, exit_label);
1807   gfc_add_expr_to_block (&loop.pre, tmp);
1808
1809   gfc_add_block_to_block (&se->pre, &loop.pre);
1810   gfc_add_block_to_block (&se->pre, &loop.post);
1811   gfc_cleanup_loop (&loop);
1812
1813   se->expr = resvar;
1814 }
1815
1816 /* COUNT(A) = Number of true elements in A.  */
1817 static void
1818 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1819 {
1820   tree resvar;
1821   tree type;
1822   stmtblock_t body;
1823   tree tmp;
1824   gfc_loopinfo loop;
1825   gfc_actual_arglist *actual;
1826   gfc_ss *arrayss;
1827   gfc_se arrayse;
1828
1829   if (se->ss)
1830     {
1831       gfc_conv_intrinsic_funcall (se, expr);
1832       return;
1833     }
1834
1835   actual = expr->value.function.actual;
1836
1837   type = gfc_typenode_for_spec (&expr->ts);
1838   /* Initialize the result.  */
1839   resvar = gfc_create_var (type, "count");
1840   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1841
1842   /* Walk the arguments.  */
1843   arrayss = gfc_walk_expr (actual->expr);
1844   gcc_assert (arrayss != gfc_ss_terminator);
1845
1846   /* Initialize the scalarizer.  */
1847   gfc_init_loopinfo (&loop);
1848   gfc_add_ss_to_loop (&loop, arrayss);
1849
1850   /* Initialize the loop.  */
1851   gfc_conv_ss_startstride (&loop);
1852   gfc_conv_loop_setup (&loop, &expr->where);
1853
1854   gfc_mark_ss_chain_used (arrayss, 1);
1855   /* Generate the loop body.  */
1856   gfc_start_scalarized_body (&loop, &body);
1857
1858   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1859                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1860   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1861
1862   gfc_init_se (&arrayse, NULL);
1863   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1864   arrayse.ss = arrayss;
1865   gfc_conv_expr_val (&arrayse, actual->expr);
1866   tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
1867                   build_empty_stmt (input_location));
1868
1869   gfc_add_block_to_block (&body, &arrayse.pre);
1870   gfc_add_expr_to_block (&body, tmp);
1871   gfc_add_block_to_block (&body, &arrayse.post);
1872
1873   gfc_trans_scalarizing_loops (&loop, &body);
1874
1875   gfc_add_block_to_block (&se->pre, &loop.pre);
1876   gfc_add_block_to_block (&se->pre, &loop.post);
1877   gfc_cleanup_loop (&loop);
1878
1879   se->expr = resvar;
1880 }
1881
1882 /* Inline implementation of the sum and product intrinsics.  */
1883 static void
1884 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1885 {
1886   tree resvar;
1887   tree type;
1888   stmtblock_t body;
1889   stmtblock_t block;
1890   tree tmp;
1891   gfc_loopinfo loop;
1892   gfc_actual_arglist *actual;
1893   gfc_ss *arrayss;
1894   gfc_ss *maskss;
1895   gfc_se arrayse;
1896   gfc_se maskse;
1897   gfc_expr *arrayexpr;
1898   gfc_expr *maskexpr;
1899
1900   if (se->ss)
1901     {
1902       gfc_conv_intrinsic_funcall (se, expr);
1903       return;
1904     }
1905
1906   type = gfc_typenode_for_spec (&expr->ts);
1907   /* Initialize the result.  */
1908   resvar = gfc_create_var (type, "val");
1909   if (op == PLUS_EXPR)
1910     tmp = gfc_build_const (type, integer_zero_node);
1911   else
1912     tmp = gfc_build_const (type, integer_one_node);
1913
1914   gfc_add_modify (&se->pre, resvar, tmp);
1915
1916   /* Walk the arguments.  */
1917   actual = expr->value.function.actual;
1918   arrayexpr = actual->expr;
1919   arrayss = gfc_walk_expr (arrayexpr);
1920   gcc_assert (arrayss != gfc_ss_terminator);
1921
1922   actual = actual->next->next;
1923   gcc_assert (actual);
1924   maskexpr = actual->expr;
1925   if (maskexpr && maskexpr->rank != 0)
1926     {
1927       maskss = gfc_walk_expr (maskexpr);
1928       gcc_assert (maskss != gfc_ss_terminator);
1929     }
1930   else
1931     maskss = NULL;
1932
1933   /* Initialize the scalarizer.  */
1934   gfc_init_loopinfo (&loop);
1935   gfc_add_ss_to_loop (&loop, arrayss);
1936   if (maskss)
1937     gfc_add_ss_to_loop (&loop, maskss);
1938
1939   /* Initialize the loop.  */
1940   gfc_conv_ss_startstride (&loop);
1941   gfc_conv_loop_setup (&loop, &expr->where);
1942
1943   gfc_mark_ss_chain_used (arrayss, 1);
1944   if (maskss)
1945     gfc_mark_ss_chain_used (maskss, 1);
1946   /* Generate the loop body.  */
1947   gfc_start_scalarized_body (&loop, &body);
1948
1949   /* If we have a mask, only add this element if the mask is set.  */
1950   if (maskss)
1951     {
1952       gfc_init_se (&maskse, NULL);
1953       gfc_copy_loopinfo_to_se (&maskse, &loop);
1954       maskse.ss = maskss;
1955       gfc_conv_expr_val (&maskse, maskexpr);
1956       gfc_add_block_to_block (&body, &maskse.pre);
1957
1958       gfc_start_block (&block);
1959     }
1960   else
1961     gfc_init_block (&block);
1962
1963   /* Do the actual summation/product.  */
1964   gfc_init_se (&arrayse, NULL);
1965   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1966   arrayse.ss = arrayss;
1967   gfc_conv_expr_val (&arrayse, arrayexpr);
1968   gfc_add_block_to_block (&block, &arrayse.pre);
1969
1970   tmp = fold_build2 (op, type, resvar, arrayse.expr);
1971   gfc_add_modify (&block, resvar, tmp);
1972   gfc_add_block_to_block (&block, &arrayse.post);
1973
1974   if (maskss)
1975     {
1976       /* We enclose the above in if (mask) {...} .  */
1977       tmp = gfc_finish_block (&block);
1978
1979       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1980                       build_empty_stmt (input_location));
1981     }
1982   else
1983     tmp = gfc_finish_block (&block);
1984   gfc_add_expr_to_block (&body, tmp);
1985
1986   gfc_trans_scalarizing_loops (&loop, &body);
1987
1988   /* For a scalar mask, enclose the loop in an if statement.  */
1989   if (maskexpr && maskss == NULL)
1990     {
1991       gfc_init_se (&maskse, NULL);
1992       gfc_conv_expr_val (&maskse, maskexpr);
1993       gfc_init_block (&block);
1994       gfc_add_block_to_block (&block, &loop.pre);
1995       gfc_add_block_to_block (&block, &loop.post);
1996       tmp = gfc_finish_block (&block);
1997
1998       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
1999                       build_empty_stmt (input_location));
2000       gfc_add_expr_to_block (&block, tmp);
2001       gfc_add_block_to_block (&se->pre, &block);
2002     }
2003   else
2004     {
2005       gfc_add_block_to_block (&se->pre, &loop.pre);
2006       gfc_add_block_to_block (&se->pre, &loop.post);
2007     }
2008
2009   gfc_cleanup_loop (&loop);
2010
2011   se->expr = resvar;
2012 }
2013
2014
2015 /* Inline implementation of the dot_product intrinsic. This function
2016    is based on gfc_conv_intrinsic_arith (the previous function).  */
2017 static void
2018 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2019 {
2020   tree resvar;
2021   tree type;
2022   stmtblock_t body;
2023   stmtblock_t block;
2024   tree tmp;
2025   gfc_loopinfo loop;
2026   gfc_actual_arglist *actual;
2027   gfc_ss *arrayss1, *arrayss2;
2028   gfc_se arrayse1, arrayse2;
2029   gfc_expr *arrayexpr1, *arrayexpr2;
2030
2031   type = gfc_typenode_for_spec (&expr->ts);
2032
2033   /* Initialize the result.  */
2034   resvar = gfc_create_var (type, "val");
2035   if (expr->ts.type == BT_LOGICAL)
2036     tmp = build_int_cst (type, 0);
2037   else
2038     tmp = gfc_build_const (type, integer_zero_node);
2039
2040   gfc_add_modify (&se->pre, resvar, tmp);
2041
2042   /* Walk argument #1.  */
2043   actual = expr->value.function.actual;
2044   arrayexpr1 = actual->expr;
2045   arrayss1 = gfc_walk_expr (arrayexpr1);
2046   gcc_assert (arrayss1 != gfc_ss_terminator);
2047
2048   /* Walk argument #2.  */
2049   actual = actual->next;
2050   arrayexpr2 = actual->expr;
2051   arrayss2 = gfc_walk_expr (arrayexpr2);
2052   gcc_assert (arrayss2 != gfc_ss_terminator);
2053
2054   /* Initialize the scalarizer.  */
2055   gfc_init_loopinfo (&loop);
2056   gfc_add_ss_to_loop (&loop, arrayss1);
2057   gfc_add_ss_to_loop (&loop, arrayss2);
2058
2059   /* Initialize the loop.  */
2060   gfc_conv_ss_startstride (&loop);
2061   gfc_conv_loop_setup (&loop, &expr->where);
2062
2063   gfc_mark_ss_chain_used (arrayss1, 1);
2064   gfc_mark_ss_chain_used (arrayss2, 1);
2065
2066   /* Generate the loop body.  */
2067   gfc_start_scalarized_body (&loop, &body);
2068   gfc_init_block (&block);
2069
2070   /* Make the tree expression for [conjg(]array1[)].  */
2071   gfc_init_se (&arrayse1, NULL);
2072   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2073   arrayse1.ss = arrayss1;
2074   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2075   if (expr->ts.type == BT_COMPLEX)
2076     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2077   gfc_add_block_to_block (&block, &arrayse1.pre);
2078
2079   /* Make the tree expression for array2.  */
2080   gfc_init_se (&arrayse2, NULL);
2081   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2082   arrayse2.ss = arrayss2;
2083   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2084   gfc_add_block_to_block (&block, &arrayse2.pre);
2085
2086   /* Do the actual product and sum.  */
2087   if (expr->ts.type == BT_LOGICAL)
2088     {
2089       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2090       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2091     }
2092   else
2093     {
2094       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2095       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2096     }
2097   gfc_add_modify (&block, resvar, tmp);
2098
2099   /* Finish up the loop block and the loop.  */
2100   tmp = gfc_finish_block (&block);
2101   gfc_add_expr_to_block (&body, tmp);
2102
2103   gfc_trans_scalarizing_loops (&loop, &body);
2104   gfc_add_block_to_block (&se->pre, &loop.pre);
2105   gfc_add_block_to_block (&se->pre, &loop.post);
2106   gfc_cleanup_loop (&loop);
2107
2108   se->expr = resvar;
2109 }
2110
2111
2112 /* Emit code for minloc or maxloc intrinsic.  There are many different cases
2113    we need to handle.  For performance reasons we sometimes create two
2114    loops instead of one, where the second one is much simpler.
2115    Examples for minloc intrinsic:
2116    1) Result is an array, a call is generated
2117    2) Array mask is used and NaNs need to be supported:
2118       limit = Infinity;
2119       pos = 0;
2120       S = from;
2121       while (S <= to) {
2122         if (mask[S]) {
2123           if (pos == 0) pos = S + (1 - from);
2124           if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2125         }
2126         S++;
2127       }
2128       goto lab2;
2129       lab1:;
2130       while (S <= to) {
2131         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2132         S++;
2133       }
2134       lab2:;
2135    3) NaNs need to be supported, but it is known at compile time or cheaply
2136       at runtime whether array is nonempty or not:
2137       limit = Infinity;
2138       pos = 0;
2139       S = from;
2140       while (S <= to) {
2141         if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2142         S++;
2143       }
2144       if (from <= to) pos = 1;
2145       goto lab2;
2146       lab1:;
2147       while (S <= to) {
2148         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2149         S++;
2150       }
2151       lab2:;
2152    4) NaNs aren't supported, array mask is used:
2153       limit = infinities_supported ? Infinity : huge (limit);
2154       pos = 0;
2155       S = from;
2156       while (S <= to) {
2157         if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2158         S++;
2159       }
2160       goto lab2;
2161       lab1:;
2162       while (S <= to) {
2163         if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2164         S++;
2165       }
2166       lab2:;
2167    5) Same without array mask:
2168       limit = infinities_supported ? Infinity : huge (limit);
2169       pos = (from <= to) ? 1 : 0;
2170       S = from;
2171       while (S <= to) {
2172         if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2173         S++;
2174       }
2175    For 3) and 5), if mask is scalar, this all goes into a conditional,
2176    setting pos = 0; in the else branch.  */
2177
2178 static void
2179 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2180 {
2181   stmtblock_t body;
2182   stmtblock_t block;
2183   stmtblock_t ifblock;
2184   stmtblock_t elseblock;
2185   tree limit;
2186   tree type;
2187   tree tmp;
2188   tree cond;
2189   tree elsetmp;
2190   tree ifbody;
2191   tree offset;
2192   tree nonempty;
2193   tree lab1, lab2;
2194   gfc_loopinfo loop;
2195   gfc_actual_arglist *actual;
2196   gfc_ss *arrayss;
2197   gfc_ss *maskss;
2198   gfc_se arrayse;
2199   gfc_se maskse;
2200   gfc_expr *arrayexpr;
2201   gfc_expr *maskexpr;
2202   tree pos;
2203   int n;
2204
2205   if (se->ss)
2206     {
2207       gfc_conv_intrinsic_funcall (se, expr);
2208       return;
2209     }
2210
2211   /* Initialize the result.  */
2212   pos = gfc_create_var (gfc_array_index_type, "pos");
2213   offset = gfc_create_var (gfc_array_index_type, "offset");
2214   type = gfc_typenode_for_spec (&expr->ts);
2215
2216   /* Walk the arguments.  */
2217   actual = expr->value.function.actual;
2218   arrayexpr = actual->expr;
2219   arrayss = gfc_walk_expr (arrayexpr);
2220   gcc_assert (arrayss != gfc_ss_terminator);
2221
2222   actual = actual->next->next;
2223   gcc_assert (actual);
2224   maskexpr = actual->expr;
2225   nonempty = NULL;
2226   if (maskexpr && maskexpr->rank != 0)
2227     {
2228       maskss = gfc_walk_expr (maskexpr);
2229       gcc_assert (maskss != gfc_ss_terminator);
2230     }
2231   else
2232     {
2233       mpz_t asize;
2234       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2235         {
2236           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2237           mpz_clear (asize);
2238           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2239                                   gfc_index_zero_node);
2240         }
2241       maskss = NULL;
2242     }
2243
2244   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2245   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2246   switch (arrayexpr->ts.type)
2247     {
2248     case BT_REAL:
2249       if (HONOR_INFINITIES (DECL_MODE (limit)))
2250         {
2251           REAL_VALUE_TYPE real;
2252           real_inf (&real);
2253           tmp = build_real (TREE_TYPE (limit), real);
2254         }
2255       else
2256         tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2257                                      arrayexpr->ts.kind, 0);
2258       break;
2259
2260     case BT_INTEGER:
2261       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2262                                   arrayexpr->ts.kind);
2263       break;
2264
2265     default:
2266       gcc_unreachable ();
2267     }
2268
2269   /* We start with the most negative possible value for MAXLOC, and the most
2270      positive possible value for MINLOC. The most negative possible value is
2271      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2272      possible value is HUGE in both cases.  */
2273   if (op == GT_EXPR)
2274     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2275   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2276     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2277                        build_int_cst (type, 1));
2278
2279   gfc_add_modify (&se->pre, limit, tmp);
2280
2281   /* Initialize the scalarizer.  */
2282   gfc_init_loopinfo (&loop);
2283   gfc_add_ss_to_loop (&loop, arrayss);
2284   if (maskss)
2285     gfc_add_ss_to_loop (&loop, maskss);
2286
2287   /* Initialize the loop.  */
2288   gfc_conv_ss_startstride (&loop);
2289   gfc_conv_loop_setup (&loop, &expr->where);
2290
2291   gcc_assert (loop.dimen == 1);
2292   if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
2293     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2294                             loop.to[0]);
2295
2296   lab1 = NULL;
2297   lab2 = NULL;
2298   /* Initialize the position to zero, following Fortran 2003.  We are free
2299      to do this because Fortran 95 allows the result of an entirely false
2300      mask to be processor dependent.  If we know at compile time the array
2301      is non-empty and no MASK is used, we can initialize to 1 to simplify
2302      the inner loop.  */
2303   if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
2304     gfc_add_modify (&loop.pre, pos,
2305                     fold_build3 (COND_EXPR, gfc_array_index_type,
2306                                  nonempty, gfc_index_one_node,
2307                                  gfc_index_zero_node));
2308   else
2309     {
2310       gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2311       lab1 = gfc_build_label_decl (NULL_TREE);
2312       TREE_USED (lab1) = 1;
2313       lab2 = gfc_build_label_decl (NULL_TREE);
2314       TREE_USED (lab2) = 1;
2315     }
2316
2317   gfc_mark_ss_chain_used (arrayss, 1);
2318   if (maskss)
2319     gfc_mark_ss_chain_used (maskss, 1);
2320   /* Generate the loop body.  */
2321   gfc_start_scalarized_body (&loop, &body);
2322
2323   /* If we have a mask, only check this element if the mask is set.  */
2324   if (maskss)
2325     {
2326       gfc_init_se (&maskse, NULL);
2327       gfc_copy_loopinfo_to_se (&maskse, &loop);
2328       maskse.ss = maskss;
2329       gfc_conv_expr_val (&maskse, maskexpr);
2330       gfc_add_block_to_block (&body, &maskse.pre);
2331
2332       gfc_start_block (&block);
2333     }
2334   else
2335     gfc_init_block (&block);
2336
2337   /* Compare with the current limit.  */
2338   gfc_init_se (&arrayse, NULL);
2339   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2340   arrayse.ss = arrayss;
2341   gfc_conv_expr_val (&arrayse, arrayexpr);
2342   gfc_add_block_to_block (&block, &arrayse.pre);
2343
2344   /* We do the following if this is a more extreme value.  */
2345   gfc_start_block (&ifblock);
2346
2347   /* Assign the value to the limit...  */
2348   gfc_add_modify (&ifblock, limit, arrayse.expr);
2349
2350   /* Remember where we are.  An offset must be added to the loop
2351      counter to obtain the required position.  */
2352   if (loop.from[0])
2353     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2354                        gfc_index_one_node, loop.from[0]);
2355   else
2356     tmp = gfc_index_one_node;
2357
2358   gfc_add_modify (&block, offset, tmp);
2359
2360   if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
2361     {
2362       stmtblock_t ifblock2;
2363       tree ifbody2;
2364
2365       gfc_start_block (&ifblock2);
2366       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2367                          loop.loopvar[0], offset);
2368       gfc_add_modify (&ifblock2, pos, tmp);
2369       ifbody2 = gfc_finish_block (&ifblock2);
2370       cond = fold_build2 (EQ_EXPR, boolean_type_node, pos,
2371                           gfc_index_zero_node);
2372       tmp = build3_v (COND_EXPR, cond, ifbody2,
2373                       build_empty_stmt (input_location));
2374       gfc_add_expr_to_block (&block, tmp);
2375     }
2376
2377   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2378                      loop.loopvar[0], offset);
2379   gfc_add_modify (&ifblock, pos, tmp);
2380
2381   if (lab1)
2382     gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
2383
2384   ifbody = gfc_finish_block (&ifblock);
2385
2386   if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
2387     {
2388       if (lab1)
2389         cond = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2390                             boolean_type_node, arrayse.expr, limit);
2391       else
2392         cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2393
2394       ifbody = build3_v (COND_EXPR, cond, ifbody,
2395                          build_empty_stmt (input_location));
2396     }
2397   gfc_add_expr_to_block (&block, ifbody);
2398
2399   if (maskss)
2400     {
2401       /* We enclose the above in if (mask) {...}.  */
2402       tmp = gfc_finish_block (&block);
2403
2404       tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2405                       build_empty_stmt (input_location));
2406     }
2407   else
2408     tmp = gfc_finish_block (&block);
2409   gfc_add_expr_to_block (&body, tmp);
2410
2411   if (lab1)
2412     {
2413       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2414
2415       if (HONOR_NANS (DECL_MODE (limit)))
2416         {
2417           if (nonempty != NULL)
2418             {
2419               ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
2420               tmp = build3_v (COND_EXPR, nonempty, ifbody,
2421                               build_empty_stmt (input_location));
2422               gfc_add_expr_to_block (&loop.code[0], tmp);
2423             }
2424         }
2425
2426       gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
2427       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
2428       gfc_start_block (&body);
2429
2430       /* If we have a mask, only check this element if the mask is set.  */
2431       if (maskss)
2432         {
2433           gfc_init_se (&maskse, NULL);
2434           gfc_copy_loopinfo_to_se (&maskse, &loop);
2435           maskse.ss = maskss;
2436           gfc_conv_expr_val (&maskse, maskexpr);
2437           gfc_add_block_to_block (&body, &maskse.pre);
2438
2439           gfc_start_block (&block);
2440         }
2441       else
2442         gfc_init_block (&block);
2443
2444       /* Compare with the current limit.  */
2445       gfc_init_se (&arrayse, NULL);
2446       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2447       arrayse.ss = arrayss;
2448       gfc_conv_expr_val (&arrayse, arrayexpr);
2449       gfc_add_block_to_block (&block, &arrayse.pre);
2450
2451       /* We do the following if this is a more extreme value.  */
2452       gfc_start_block (&ifblock);
2453
2454       /* Assign the value to the limit...  */
2455       gfc_add_modify (&ifblock, limit, arrayse.expr);
2456
2457       /* Remember where we are.  An offset must be added to the loop
2458          counter to obtain the required position.  */
2459       if (loop.from[0])
2460         tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2461                            gfc_index_one_node, loop.from[0]);
2462       else
2463         tmp = gfc_index_one_node;
2464
2465       gfc_add_modify (&block, offset, tmp);
2466
2467       tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2468                          loop.loopvar[0], offset);
2469       gfc_add_modify (&ifblock, pos, tmp);
2470
2471       ifbody = gfc_finish_block (&ifblock);
2472
2473       cond = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2474
2475       tmp = build3_v (COND_EXPR, cond, ifbody,
2476                       build_empty_stmt (input_location));
2477       gfc_add_expr_to_block (&block, tmp);
2478
2479       if (maskss)
2480         {
2481           /* We enclose the above in if (mask) {...}.  */
2482           tmp = gfc_finish_block (&block);
2483
2484           tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2485                           build_empty_stmt (input_location));
2486         }
2487       else
2488         tmp = gfc_finish_block (&block);
2489       gfc_add_expr_to_block (&body, tmp);
2490       /* Avoid initializing loopvar[0] again, it should be left where
2491          it finished by the first loop.  */
2492       loop.from[0] = loop.loopvar[0];
2493     }
2494
2495   gfc_trans_scalarizing_loops (&loop, &body);
2496
2497   if (lab2)
2498     gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
2499
2500   /* For a scalar mask, enclose the loop in an if statement.  */
2501   if (maskexpr && maskss == NULL)
2502     {
2503       gfc_init_se (&maskse, NULL);
2504       gfc_conv_expr_val (&maskse, maskexpr);
2505       gfc_init_block (&block);
2506       gfc_add_block_to_block (&block, &loop.pre);
2507       gfc_add_block_to_block (&block, &loop.post);
2508       tmp = gfc_finish_block (&block);
2509
2510       /* For the else part of the scalar mask, just initialize
2511          the pos variable the same way as above.  */
2512
2513       gfc_init_block (&elseblock);
2514       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2515       elsetmp = gfc_finish_block (&elseblock);
2516
2517       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2518       gfc_add_expr_to_block (&block, tmp);
2519       gfc_add_block_to_block (&se->pre, &block);
2520     }
2521   else
2522     {
2523       gfc_add_block_to_block (&se->pre, &loop.pre);
2524       gfc_add_block_to_block (&se->pre, &loop.post);
2525     }
2526   gfc_cleanup_loop (&loop);
2527
2528   se->expr = convert (type, pos);
2529 }
2530
2531 /* Emit code for minval or maxval intrinsic.  There are many different cases
2532    we need to handle.  For performance reasons we sometimes create two
2533    loops instead of one, where the second one is much simpler.
2534    Examples for minval intrinsic:
2535    1) Result is an array, a call is generated
2536    2) Array mask is used and NaNs need to be supported, rank 1:
2537       limit = Infinity;
2538       nonempty = false;
2539       S = from;
2540       while (S <= to) {
2541         if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
2542         S++;
2543       }
2544       limit = nonempty ? NaN : huge (limit);
2545       lab:
2546       while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
2547    3) NaNs need to be supported, but it is known at compile time or cheaply
2548       at runtime whether array is nonempty or not, rank 1:
2549       limit = Infinity;
2550       S = from;
2551       while (S <= to) { if (a[S] <= limit) goto lab; S++; }
2552       limit = (from <= to) ? NaN : huge (limit);
2553       lab:
2554       while (S <= to) { limit = min (a[S], limit); S++; }
2555    4) Array mask is used and NaNs need to be supported, rank > 1:
2556       limit = Infinity;
2557       nonempty = false;
2558       fast = false;
2559       S1 = from1;
2560       while (S1 <= to1) {
2561         S2 = from2;
2562         while (S2 <= to2) {
2563           if (mask[S1][S2]) {
2564             if (fast) limit = min (a[S1][S2], limit);
2565             else {
2566               nonempty = true;
2567               if (a[S1][S2] <= limit) {
2568                 limit = a[S1][S2];
2569                 fast = true;
2570               }
2571             }
2572           }
2573           S2++;
2574         }
2575         S1++;
2576       }
2577       if (!fast)
2578         limit = nonempty ? NaN : huge (limit);
2579    5) NaNs need to be supported, but it is known at compile time or cheaply
2580       at runtime whether array is nonempty or not, rank > 1:
2581       limit = Infinity;
2582       fast = false;
2583       S1 = from1;
2584       while (S1 <= to1) {
2585         S2 = from2;
2586         while (S2 <= to2) {
2587           if (fast) limit = min (a[S1][S2], limit);
2588           else {
2589             if (a[S1][S2] <= limit) {
2590               limit = a[S1][S2];
2591               fast = true;
2592             }
2593           }
2594           S2++;
2595         }
2596         S1++;
2597       }
2598       if (!fast)
2599         limit = (nonempty_array) ? NaN : huge (limit);
2600    6) NaNs aren't supported, but infinities are.  Array mask is used:
2601       limit = Infinity;
2602       nonempty = false;
2603       S = from;
2604       while (S <= to) {
2605         if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
2606         S++;
2607       }
2608       limit = nonempty ? limit : huge (limit);
2609    7) Same without array mask:
2610       limit = Infinity;
2611       S = from;
2612       while (S <= to) { limit = min (a[S], limit); S++; }
2613       limit = (from <= to) ? limit : huge (limit);
2614    8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
2615       limit = huge (limit);
2616       S = from;
2617       while (S <= to) { limit = min (a[S], limit); S++); }
2618       (or
2619       while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
2620       with array mask instead).
2621    For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
2622    setting limit = huge (limit); in the else branch.  */
2623
2624 static void
2625 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2626 {
2627   tree limit;
2628   tree type;
2629   tree tmp;
2630   tree ifbody;
2631   tree nonempty;
2632   tree nonempty_var;
2633   tree lab;
2634   tree fast;
2635   tree huge_cst = NULL, nan_cst = NULL;
2636   stmtblock_t body;
2637   stmtblock_t block, block2;
2638   gfc_loopinfo loop;
2639   gfc_actual_arglist *actual;
2640   gfc_ss *arrayss;
2641   gfc_ss *maskss;
2642   gfc_se arrayse;
2643   gfc_se maskse;
2644   gfc_expr *arrayexpr;
2645   gfc_expr *maskexpr;
2646   int n;
2647
2648   if (se->ss)
2649     {
2650       gfc_conv_intrinsic_funcall (se, expr);
2651       return;
2652     }
2653
2654   type = gfc_typenode_for_spec (&expr->ts);
2655   /* Initialize the result.  */
2656   limit = gfc_create_var (type, "limit");
2657   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2658   switch (expr->ts.type)
2659     {
2660     case BT_REAL:
2661       huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2662                                         expr->ts.kind, 0);
2663       if (HONOR_INFINITIES (DECL_MODE (limit)))
2664         {
2665           REAL_VALUE_TYPE real;
2666           real_inf (&real);
2667           tmp = build_real (type, real);
2668         }
2669       else
2670         tmp = huge_cst;
2671       if (HONOR_NANS (DECL_MODE (limit)))
2672         {
2673           REAL_VALUE_TYPE real;
2674           real_nan (&real, "", 1, DECL_MODE (limit));
2675           nan_cst = build_real (type, real);
2676         }
2677       break;
2678
2679     case BT_INTEGER:
2680       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2681       break;
2682
2683     default:
2684       gcc_unreachable ();
2685     }
2686
2687   /* We start with the most negative possible value for MAXVAL, and the most
2688      positive possible value for MINVAL. The most negative possible value is
2689      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2690      possible value is HUGE in both cases.  */
2691   if (op == GT_EXPR)
2692     {
2693       tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2694       if (huge_cst)
2695         huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
2696     }
2697
2698   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2699     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2700                        tmp, build_int_cst (type, 1));
2701
2702   gfc_add_modify (&se->pre, limit, tmp);
2703
2704   /* Walk the arguments.  */
2705   actual = expr->value.function.actual;
2706   arrayexpr = actual->expr;
2707   arrayss = gfc_walk_expr (arrayexpr);
2708   gcc_assert (arrayss != gfc_ss_terminator);
2709
2710   actual = actual->next->next;
2711   gcc_assert (actual);
2712   maskexpr = actual->expr;
2713   nonempty = NULL;
2714   if (maskexpr && maskexpr->rank != 0)
2715     {
2716       maskss = gfc_walk_expr (maskexpr);
2717       gcc_assert (maskss != gfc_ss_terminator);
2718     }
2719   else
2720     {
2721       mpz_t asize;
2722       if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
2723         {
2724           nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
2725           mpz_clear (asize);
2726           nonempty = fold_build2 (GT_EXPR, boolean_type_node, nonempty,
2727                                   gfc_index_zero_node);
2728         }
2729       maskss = NULL;
2730     }
2731
2732   /* Initialize the scalarizer.  */
2733   gfc_init_loopinfo (&loop);
2734   gfc_add_ss_to_loop (&loop, arrayss);
2735   if (maskss)
2736     gfc_add_ss_to_loop (&loop, maskss);
2737
2738   /* Initialize the loop.  */
2739   gfc_conv_ss_startstride (&loop);
2740   gfc_conv_loop_setup (&loop, &expr->where);
2741
2742   if (nonempty == NULL && maskss == NULL
2743       && loop.dimen == 1 && loop.from[0] && loop.to[0])
2744     nonempty = fold_build2 (LE_EXPR, boolean_type_node, loop.from[0],
2745                             loop.to[0]);
2746   nonempty_var = NULL;
2747   if (nonempty == NULL
2748       && (HONOR_INFINITIES (DECL_MODE (limit))
2749           || HONOR_NANS (DECL_MODE (limit))))
2750     {
2751       nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
2752       gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
2753       nonempty = nonempty_var;
2754     }
2755   lab = NULL;
2756   fast = NULL;
2757   if (HONOR_NANS (DECL_MODE (limit)))
2758     {
2759       if (loop.dimen == 1)
2760         {
2761           lab = gfc_build_label_decl (NULL_TREE);
2762           TREE_USED (lab) = 1;
2763         }
2764       else
2765         {
2766           fast = gfc_create_var (boolean_type_node, "fast");
2767           gfc_add_modify (&se->pre, fast, boolean_false_node);
2768         }
2769     }
2770
2771   gfc_mark_ss_chain_used (arrayss, 1);
2772   if (maskss)
2773     gfc_mark_ss_chain_used (maskss, 1);
2774   /* Generate the loop body.  */
2775   gfc_start_scalarized_body (&loop, &body);
2776
2777   /* If we have a mask, only add this element if the mask is set.  */
2778   if (maskss)
2779     {
2780       gfc_init_se (&maskse, NULL);
2781       gfc_copy_loopinfo_to_se (&maskse, &loop);
2782       maskse.ss = maskss;
2783       gfc_conv_expr_val (&maskse, maskexpr);
2784       gfc_add_block_to_block (&body, &maskse.pre);
2785
2786       gfc_start_block (&block);
2787     }
2788   else
2789     gfc_init_block (&block);
2790
2791   /* Compare with the current limit.  */
2792   gfc_init_se (&arrayse, NULL);
2793   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2794   arrayse.ss = arrayss;
2795   gfc_conv_expr_val (&arrayse, arrayexpr);
2796   gfc_add_block_to_block (&block, &arrayse.pre);
2797
2798   gfc_init_block (&block2);
2799
2800   if (nonempty_var)
2801     gfc_add_modify (&block2, nonempty_var, boolean_true_node);
2802
2803   if (HONOR_NANS (DECL_MODE (limit)))
2804     {
2805       tmp = fold_build2 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
2806                          boolean_type_node, arrayse.expr, limit);
2807       if (lab)
2808         ifbody = build1_v (GOTO_EXPR, lab);
2809       else
2810         {
2811           stmtblock_t ifblock;
2812
2813           gfc_init_block (&ifblock);
2814           gfc_add_modify (&ifblock, limit, arrayse.expr);
2815           gfc_add_modify (&ifblock, fast, boolean_true_node);
2816           ifbody = gfc_finish_block (&ifblock);
2817         }
2818       tmp = build3_v (COND_EXPR, tmp, ifbody,
2819                       build_empty_stmt (input_location));
2820       gfc_add_expr_to_block (&block2, tmp);
2821     }
2822   else
2823     {
2824       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2825          signed zeros.  */
2826       if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2827         {
2828           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2829           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2830           tmp = build3_v (COND_EXPR, tmp, ifbody,
2831                           build_empty_stmt (input_location));
2832           gfc_add_expr_to_block (&block2, tmp);
2833         }
2834       else
2835         {
2836           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2837                              type, arrayse.expr, limit);
2838           gfc_add_modify (&block2, limit, tmp);
2839         }
2840     }
2841
2842   if (fast)
2843     {
2844       tree elsebody = gfc_finish_block (&block2);
2845
2846       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2847          signed zeros.  */
2848       if (HONOR_NANS (DECL_MODE (limit))
2849           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2850         {
2851           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2852           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2853           ifbody = build3_v (COND_EXPR, tmp, ifbody,
2854                              build_empty_stmt (input_location));
2855         }
2856       else
2857         {
2858           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2859                              type, arrayse.expr, limit);
2860           ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2861         }
2862       tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
2863       gfc_add_expr_to_block (&block, tmp);
2864     }
2865   else
2866     gfc_add_block_to_block (&block, &block2);
2867
2868   gfc_add_block_to_block (&block, &arrayse.post);
2869
2870   tmp = gfc_finish_block (&block);
2871   if (maskss)
2872     /* We enclose the above in if (mask) {...}.  */
2873     tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2874                     build_empty_stmt (input_location));
2875   gfc_add_expr_to_block (&body, tmp);
2876
2877   if (lab)
2878     {
2879       gfc_trans_scalarized_loop_end (&loop, 0, &body);
2880
2881       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2882       gfc_add_modify (&loop.code[0], limit, tmp);
2883       gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
2884
2885       gfc_start_block (&body);
2886
2887       /* If we have a mask, only add this element if the mask is set.  */
2888       if (maskss)
2889         {
2890           gfc_init_se (&maskse, NULL);
2891           gfc_copy_loopinfo_to_se (&maskse, &loop);
2892           maskse.ss = maskss;
2893           gfc_conv_expr_val (&maskse, maskexpr);
2894           gfc_add_block_to_block (&body, &maskse.pre);
2895
2896           gfc_start_block (&block);
2897         }
2898       else
2899         gfc_init_block (&block);
2900
2901       /* Compare with the current limit.  */
2902       gfc_init_se (&arrayse, NULL);
2903       gfc_copy_loopinfo_to_se (&arrayse, &loop);
2904       arrayse.ss = arrayss;
2905       gfc_conv_expr_val (&arrayse, arrayexpr);
2906       gfc_add_block_to_block (&block, &arrayse.pre);
2907
2908       /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
2909          signed zeros.  */
2910       if (HONOR_NANS (DECL_MODE (limit))
2911           || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
2912         {
2913           tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2914           ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2915           tmp = build3_v (COND_EXPR, tmp, ifbody,
2916                           build_empty_stmt (input_location));
2917           gfc_add_expr_to_block (&block, tmp);
2918         }
2919       else
2920         {
2921           tmp = fold_build2 (op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
2922                              type, arrayse.expr, limit);
2923           gfc_add_modify (&block, limit, tmp);
2924         }
2925
2926       gfc_add_block_to_block (&block, &arrayse.post);
2927
2928       tmp = gfc_finish_block (&block);
2929       if (maskss)
2930         /* We enclose the above in if (mask) {...}.  */
2931         tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2932                         build_empty_stmt (input_location));
2933       gfc_add_expr_to_block (&body, tmp);
2934       /* Avoid initializing loopvar[0] again, it should be left where
2935          it finished by the first loop.  */
2936       loop.from[0] = loop.loopvar[0];
2937     }
2938   gfc_trans_scalarizing_loops (&loop, &body);
2939
2940   if (fast)
2941     {
2942       tmp = fold_build3 (COND_EXPR, type, nonempty, nan_cst, huge_cst);
2943       ifbody = build2_v (MODIFY_EXPR, limit, tmp);
2944       tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
2945                       ifbody);
2946       gfc_add_expr_to_block (&loop.pre, tmp);
2947     }
2948   else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
2949     {
2950       tmp = fold_build3 (COND_EXPR, type, nonempty, limit, huge_cst);
2951       gfc_add_modify (&loop.pre, limit, tmp);
2952     }
2953
2954   /* For a scalar mask, enclose the loop in an if statement.  */
2955   if (maskexpr && maskss == NULL)
2956     {
2957       tree else_stmt;
2958
2959       gfc_init_se (&maskse, NULL);
2960       gfc_conv_expr_val (&maskse, maskexpr);
2961       gfc_init_block (&block);
2962       gfc_add_block_to_block (&block, &loop.pre);
2963       gfc_add_block_to_block (&block, &loop.post);
2964       tmp = gfc_finish_block (&block);
2965
2966       if (HONOR_INFINITIES (DECL_MODE (limit)))
2967         else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
2968       else
2969         else_stmt = build_empty_stmt (input_location);
2970       tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
2971       gfc_add_expr_to_block (&block, tmp);
2972       gfc_add_block_to_block (&se->pre, &block);
2973     }
2974   else
2975     {
2976       gfc_add_block_to_block (&se->pre, &loop.pre);
2977       gfc_add_block_to_block (&se->pre, &loop.post);
2978     }
2979
2980   gfc_cleanup_loop (&loop);
2981
2982   se->expr = limit;
2983 }
2984
2985 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2986 static void
2987 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2988 {
2989   tree args[2];
2990   tree type;
2991   tree tmp;
2992
2993   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2994   type = TREE_TYPE (args[0]);
2995
2996   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2997   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2998   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2999                      build_int_cst (type, 0));
3000   type = gfc_typenode_for_spec (&expr->ts);
3001   se->expr = convert (type, tmp);
3002 }
3003
3004 /* Generate code to perform the specified operation.  */
3005 static void
3006 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3007 {
3008   tree args[2];
3009
3010   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3011   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
3012 }
3013
3014 /* Bitwise not.  */
3015 static void
3016 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3017 {
3018   tree arg;
3019
3020   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3021   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
3022 }
3023
3024 /* Set or clear a single bit.  */
3025 static void
3026 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3027 {
3028   tree args[2];
3029   tree type;
3030   tree tmp;
3031   enum tree_code op;
3032
3033   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3034   type = TREE_TYPE (args[0]);
3035
3036   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
3037   if (set)
3038     op = BIT_IOR_EXPR;
3039   else
3040     {
3041       op = BIT_AND_EXPR;
3042       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
3043     }
3044   se->expr = fold_build2 (op, type, args[0], tmp);
3045 }
3046
3047 /* Extract a sequence of bits.
3048     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
3049 static void
3050 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3051 {
3052   tree args[3];
3053   tree type;
3054   tree tmp;
3055   tree mask;
3056
3057   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3058   type = TREE_TYPE (args[0]);
3059
3060   mask = build_int_cst (type, -1);
3061   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
3062   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
3063
3064   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
3065
3066   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
3067 }
3068
3069 /* RSHIFT (I, SHIFT) = I >> SHIFT
3070    LSHIFT (I, SHIFT) = I << SHIFT  */
3071 static void
3072 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
3073 {
3074   tree args[2];
3075
3076   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3077
3078   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3079                           TREE_TYPE (args[0]), args[0], args[1]);
3080 }
3081
3082 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3083                         ? 0
3084                         : ((shift >= 0) ? i << shift : i >> -shift)
3085    where all shifts are logical shifts.  */
3086 static void
3087 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3088 {
3089   tree args[2];
3090   tree type;
3091   tree utype;
3092   tree tmp;
3093   tree width;
3094   tree num_bits;
3095   tree cond;
3096   tree lshift;
3097   tree rshift;
3098
3099   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3100   type = TREE_TYPE (args[0]);
3101   utype = unsigned_type_for (type);
3102
3103   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
3104
3105   /* Left shift if positive.  */
3106   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
3107
3108   /* Right shift if negative.
3109      We convert to an unsigned type because we want a logical shift.
3110      The standard doesn't define the case of shifting negative
3111      numbers, and we try to be compatible with other compilers, most
3112      notably g77, here.  */
3113   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
3114                                             convert (utype, args[0]), width));
3115
3116   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
3117                      build_int_cst (TREE_TYPE (args[1]), 0));
3118   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
3119
3120   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3121      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3122      special case.  */
3123   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3124   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
3125
3126   se->expr = fold_build3 (COND_EXPR, type, cond,
3127                           build_int_cst (type, 0), tmp);
3128 }
3129
3130
3131 /* Circular shift.  AKA rotate or barrel shift.  */
3132
3133 static void
3134 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
3135 {
3136   tree *args;
3137   tree type;
3138   tree tmp;
3139   tree lrot;
3140   tree rrot;
3141   tree zero;
3142   unsigned int num_args;
3143
3144   num_args = gfc_intrinsic_argument_list_length (expr);
3145   args = (tree *) alloca (sizeof (tree) * num_args);
3146
3147   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3148
3149   if (num_args == 3)
3150     {
3151       /* Use a library function for the 3 parameter version.  */
3152       tree int4type = gfc_get_int_type (4);
3153
3154       type = TREE_TYPE (args[0]);
3155       /* We convert the first argument to at least 4 bytes, and
3156          convert back afterwards.  This removes the need for library
3157          functions for all argument sizes, and function will be
3158          aligned to at least 32 bits, so there's no loss.  */
3159       if (expr->ts.kind < 4)
3160         args[0] = convert (int4type, args[0]);
3161
3162       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
3163          need loads of library  functions.  They cannot have values >
3164          BIT_SIZE (I) so the conversion is safe.  */
3165       args[1] = convert (int4type, args[1]);
3166       args[2] = convert (int4type, args[2]);
3167
3168       switch (expr->ts.kind)
3169         {
3170         case 1:
3171         case 2:
3172         case 4:
3173           tmp = gfor_fndecl_math_ishftc4;
3174           break;
3175         case 8:
3176           tmp = gfor_fndecl_math_ishftc8;
3177           break;
3178         case 16:
3179           tmp = gfor_fndecl_math_ishftc16;
3180           break;
3181         default:
3182           gcc_unreachable ();
3183         }
3184       se->expr = build_call_expr_loc (input_location,
3185                                   tmp, 3, args[0], args[1], args[2]);
3186       /* Convert the result back to the original type, if we extended
3187          the first argument's width above.  */
3188       if (expr->ts.kind < 4)
3189         se->expr = convert (type, se->expr);
3190
3191       return;
3192     }
3193   type = TREE_TYPE (args[0]);
3194
3195   /* Rotate left if positive.  */
3196   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
3197
3198   /* Rotate right if negative.  */
3199   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
3200   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
3201
3202   zero = build_int_cst (TREE_TYPE (args[1]), 0);
3203   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
3204   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
3205
3206   /* Do nothing if shift == 0.  */
3207   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
3208   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
3209 }
3210
3211 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
3212                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
3213
3214    The conditional expression is necessary because the result of LEADZ(0)
3215    is defined, but the result of __builtin_clz(0) is undefined for most
3216    targets.
3217
3218    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
3219    difference in bit size between the argument of LEADZ and the C int.  */
3220
3221 static void
3222 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
3223 {
3224   tree arg;
3225   tree arg_type;
3226   tree cond;
3227   tree result_type;
3228   tree leadz;
3229   tree bit_size;
3230   tree tmp;
3231   tree func;
3232   int s, argsize;
3233
3234   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3235   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3236
3237   /* Which variant of __builtin_clz* should we call?  */
3238   if (argsize <= INT_TYPE_SIZE)
3239     {
3240       arg_type = unsigned_type_node;
3241       func = built_in_decls[BUILT_IN_CLZ];
3242     }
3243   else if (argsize <= LONG_TYPE_SIZE)
3244     {
3245       arg_type = long_unsigned_type_node;
3246       func = built_in_decls[BUILT_IN_CLZL];
3247     }
3248   else if (argsize <= LONG_LONG_TYPE_SIZE)
3249     {
3250       arg_type = long_long_unsigned_type_node;
3251       func = built_in_decls[BUILT_IN_CLZLL];
3252     }
3253   else
3254     {
3255       gcc_assert (argsize == 128);
3256       arg_type = gfc_build_uint_type (argsize);
3257       func = gfor_fndecl_clz128;
3258     }
3259
3260   /* Convert the actual argument twice: first, to the unsigned type of the
3261      same size; then, to the proper argument type for the built-in
3262      function.  But the return type is of the default INTEGER kind.  */
3263   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3264   arg = fold_convert (arg_type, arg);
3265   result_type = gfc_get_int_type (gfc_default_integer_kind);
3266
3267   /* Compute LEADZ for the case i .ne. 0.  */
3268   s = TYPE_PRECISION (arg_type) - argsize;
3269   tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
3270   leadz = fold_build2 (MINUS_EXPR, result_type,
3271                        tmp, build_int_cst (result_type, s));
3272
3273   /* Build BIT_SIZE.  */
3274   bit_size = build_int_cst (result_type, argsize);
3275
3276   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3277                       arg, build_int_cst (arg_type, 0));
3278   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
3279 }
3280
3281 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
3282
3283    The conditional expression is necessary because the result of TRAILZ(0)
3284    is defined, but the result of __builtin_ctz(0) is undefined for most
3285    targets.  */
3286
3287 static void
3288 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
3289 {
3290   tree arg;
3291   tree arg_type;
3292   tree cond;
3293   tree result_type;
3294   tree trailz;
3295   tree bit_size;
3296   tree func;
3297   int argsize;
3298
3299   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3300   argsize = TYPE_PRECISION (TREE_TYPE (arg));
3301
3302   /* Which variant of __builtin_ctz* should we call?  */
3303   if (argsize <= INT_TYPE_SIZE)
3304     {
3305       arg_type = unsigned_type_node;
3306       func = built_in_decls[BUILT_IN_CTZ];
3307     }
3308   else if (argsize <= LONG_TYPE_SIZE)
3309     {
3310       arg_type = long_unsigned_type_node;
3311       func = built_in_decls[BUILT_IN_CTZL];
3312     }
3313   else if (argsize <= LONG_LONG_TYPE_SIZE)
3314     {
3315       arg_type = long_long_unsigned_type_node;
3316       func = built_in_decls[BUILT_IN_CTZLL];
3317     }
3318   else
3319     {
3320       gcc_assert (argsize == 128);
3321       arg_type = gfc_build_uint_type (argsize);
3322       func = gfor_fndecl_ctz128;
3323     }
3324
3325   /* Convert the actual argument twice: first, to the unsigned type of the
3326      same size; then, to the proper argument type for the built-in
3327      function.  But the return type is of the default INTEGER kind.  */
3328   arg = fold_convert (gfc_build_uint_type (argsize), arg);
3329   arg = fold_convert (arg_type, arg);
3330   result_type = gfc_get_int_type (gfc_default_integer_kind);
3331
3332   /* Compute TRAILZ for the case i .ne. 0.  */
3333   trailz = fold_convert (result_type, build_call_expr_loc (input_location,
3334                                                        func, 1, arg));
3335
3336   /* Build BIT_SIZE.  */
3337   bit_size = build_int_cst (result_type, argsize);
3338
3339   cond = fold_build2 (EQ_EXPR, boolean_type_node,
3340                       arg, build_int_cst (arg_type, 0));
3341   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
3342 }
3343
3344 /* Process an intrinsic with unspecified argument-types that has an optional
3345    argument (which could be of type character), e.g. EOSHIFT.  For those, we
3346    need to append the string length of the optional argument if it is not
3347    present and the type is really character.
3348    primary specifies the position (starting at 1) of the non-optional argument
3349    specifying the type and optional gives the position of the optional
3350    argument in the arglist.  */
3351
3352 static void
3353 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
3354                                      unsigned primary, unsigned optional)
3355 {
3356   gfc_actual_arglist* prim_arg;
3357   gfc_actual_arglist* opt_arg;
3358   unsigned cur_pos;
3359   gfc_actual_arglist* arg;
3360   gfc_symbol* sym;
3361   tree append_args;
3362
3363   /* Find the two arguments given as position.  */
3364   cur_pos = 0;
3365   prim_arg = NULL;
3366   opt_arg = NULL;
3367   for (arg = expr->value.function.actual; arg; arg = arg->next)
3368     {
3369       ++cur_pos;
3370
3371       if (cur_pos == primary)
3372         prim_arg = arg;
3373       if (cur_pos == optional)
3374         opt_arg = arg;
3375
3376       if (cur_pos >= primary && cur_pos >= optional)
3377         break;
3378     }
3379   gcc_assert (prim_arg);
3380   gcc_assert (prim_arg->expr);
3381   gcc_assert (opt_arg);
3382
3383   /* If we do have type CHARACTER and the optional argument is really absent,
3384      append a dummy 0 as string length.  */
3385   append_args = NULL_TREE;
3386   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
3387     {
3388       tree dummy;
3389
3390       dummy = build_int_cst (gfc_charlen_type_node, 0);
3391       append_args = gfc_chainon_list (append_args, dummy);
3392     }
3393
3394   /* Build the call itself.  */
3395   sym = gfc_get_symbol_for_expr (expr);
3396   gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
3397                           append_args);
3398   gfc_free (sym);
3399 }
3400
3401
3402 /* The length of a character string.  */
3403 static void
3404 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
3405 {
3406   tree len;
3407   tree type;
3408   tree decl;
3409   gfc_symbol *sym;
3410   gfc_se argse;
3411   gfc_expr *arg;
3412   gfc_ss *ss;
3413
3414   gcc_assert (!se->ss);
3415
3416   arg = expr->value.function.actual->expr;
3417
3418   type = gfc_typenode_for_spec (&expr->ts);
3419   switch (arg->expr_type)
3420     {
3421     case EXPR_CONSTANT:
3422       len = build_int_cst (NULL_TREE, arg->value.character.length);
3423       break;
3424
3425     case EXPR_ARRAY:
3426       /* Obtain the string length from the function used by
3427          trans-array.c(gfc_trans_array_constructor).  */
3428       len = NULL_TREE;
3429       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
3430       break;
3431
3432     case EXPR_VARIABLE:
3433       if (arg->ref == NULL
3434             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
3435         {
3436           /* This doesn't catch all cases.
3437              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
3438              and the surrounding thread.  */
3439           sym = arg->symtree->n.sym;
3440           decl = gfc_get_symbol_decl (sym);
3441           if (decl == current_function_decl && sym->attr.function
3442                 && (sym->result == sym))
3443             decl = gfc_get_fake_result_decl (sym, 0);
3444
3445           len = sym->ts.u.cl->backend_decl;
3446           gcc_assert (len);
3447           break;
3448         }
3449
3450       /* Otherwise fall through.  */
3451
3452     default:
3453       /* Anybody stupid enough to do this deserves inefficient code.  */
3454       ss = gfc_walk_expr (arg);
3455       gfc_init_se (&argse, se);
3456       if (ss == gfc_ss_terminator)
3457         gfc_conv_expr (&argse, arg);
3458       else
3459         gfc_conv_expr_descriptor (&argse, arg, ss);
3460       gfc_add_block_to_block (&se->pre, &argse.pre);
3461       gfc_add_block_to_block (&se->post, &argse.post);
3462       len = argse.string_length;
3463       break;
3464     }
3465   se->expr = convert (type, len);
3466 }
3467
3468 /* The length of a character string not including trailing blanks.  */
3469 static void
3470 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
3471 {
3472   int kind = expr->value.function.actual->expr->ts.kind;
3473   tree args[2], type, fndecl;
3474
3475   gfc_conv_intrinsic_function_args (se, expr, args, 2);