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);
3476   type = gfc_typenode_for_spec (&expr->ts);
3477
3478   if (kind == 1)
3479     fndecl = gfor_fndecl_string_len_trim;
3480   else if (kind == 4)
3481     fndecl = gfor_fndecl_string_len_trim_char4;
3482   else
3483     gcc_unreachable ();
3484
3485   se->expr = build_call_expr_loc (input_location,
3486                               fndecl, 2, args[0], args[1]);
3487   se->expr = convert (type, se->expr);
3488 }
3489
3490
3491 /* Returns the starting position of a substring within a string.  */
3492
3493 static void
3494 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
3495                                       tree function)
3496 {
3497   tree logical4_type_node = gfc_get_logical_type (4);
3498   tree type;
3499   tree fndecl;
3500   tree *args;
3501   unsigned int num_args;
3502
3503   args = (tree *) alloca (sizeof (tree) * 5);
3504
3505   /* Get number of arguments; characters count double due to the
3506      string length argument. Kind= is not passed to the library
3507      and thus ignored.  */
3508   if (expr->value.function.actual->next->next->expr == NULL)
3509     num_args = 4;
3510   else
3511     num_args = 5;
3512
3513   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3514   type = gfc_typenode_for_spec (&expr->ts);
3515
3516   if (num_args == 4)
3517     args[4] = build_int_cst (logical4_type_node, 0);
3518   else
3519     args[4] = convert (logical4_type_node, args[4]);
3520
3521   fndecl = build_addr (function, current_function_decl);
3522   se->expr = build_call_array_loc (input_location,
3523                                TREE_TYPE (TREE_TYPE (function)), fndecl,
3524                                5, args);
3525   se->expr = convert (type, se->expr);
3526
3527 }
3528
3529 /* The ascii value for a single character.  */
3530 static void
3531 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3532 {
3533   tree args[2], type, pchartype;
3534
3535   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3536   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3537   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3538   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3539   type = gfc_typenode_for_spec (&expr->ts);
3540
3541   se->expr = build_fold_indirect_ref_loc (input_location,
3542                                       args[1]);
3543   se->expr = convert (type, se->expr);
3544 }
3545
3546
3547 /* Intrinsic ISNAN calls __builtin_isnan.  */
3548
3549 static void
3550 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3551 {
3552   tree arg;
3553
3554   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3555   se->expr = build_call_expr_loc (input_location,
3556                               built_in_decls[BUILT_IN_ISNAN], 1, arg);
3557   STRIP_TYPE_NOPS (se->expr);
3558   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3559 }
3560
3561
3562 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3563    their argument against a constant integer value.  */
3564
3565 static void
3566 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3567 {
3568   tree arg;
3569
3570   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3571   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3572                           arg, build_int_cst (TREE_TYPE (arg), value));
3573 }
3574
3575
3576
3577 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3578
3579 static void
3580 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3581 {
3582   tree tsource;
3583   tree fsource;
3584   tree mask;
3585   tree type;
3586   tree len, len2;
3587   tree *args;
3588   unsigned int num_args;
3589
3590   num_args = gfc_intrinsic_argument_list_length (expr);
3591   args = (tree *) alloca (sizeof (tree) * num_args);
3592
3593   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3594   if (expr->ts.type != BT_CHARACTER)
3595     {
3596       tsource = args[0];
3597       fsource = args[1];
3598       mask = args[2];
3599     }
3600   else
3601     {
3602       /* We do the same as in the non-character case, but the argument
3603          list is different because of the string length arguments. We
3604          also have to set the string length for the result.  */
3605       len = args[0];
3606       tsource = args[1];
3607       len2 = args[2];
3608       fsource = args[3];
3609       mask = args[4];
3610
3611       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3612                                    &se->pre);
3613       se->string_length = len;
3614     }
3615   type = TREE_TYPE (tsource);
3616   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3617                           fold_convert (type, fsource));
3618 }
3619
3620
3621 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3622 static void
3623 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3624 {
3625   tree arg, type, tmp;
3626   int frexp;
3627
3628   switch (expr->ts.kind)
3629     {
3630       case 4:
3631         frexp = BUILT_IN_FREXPF;
3632         break;
3633       case 8:
3634         frexp = BUILT_IN_FREXP;
3635         break;
3636       case 10:
3637       case 16:
3638         frexp = BUILT_IN_FREXPL;
3639         break;
3640       default:
3641         gcc_unreachable ();
3642     }
3643
3644   type = gfc_typenode_for_spec (&expr->ts);
3645   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3646   tmp = gfc_create_var (integer_type_node, NULL);
3647   se->expr = build_call_expr_loc (input_location,
3648                               built_in_decls[frexp], 2,
3649                               fold_convert (type, arg),
3650                               gfc_build_addr_expr (NULL_TREE, tmp));
3651   se->expr = fold_convert (type, se->expr);
3652 }
3653
3654
3655 /* NEAREST (s, dir) is translated into
3656      tmp = copysign (HUGE_VAL, dir);
3657      return nextafter (s, tmp);
3658  */
3659 static void
3660 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3661 {
3662   tree args[2], type, tmp;
3663   int nextafter, copysign, huge_val;
3664
3665   switch (expr->ts.kind)
3666     {
3667       case 4:
3668         nextafter = BUILT_IN_NEXTAFTERF;
3669         copysign = BUILT_IN_COPYSIGNF;
3670         huge_val = BUILT_IN_HUGE_VALF;
3671         break;
3672       case 8:
3673         nextafter = BUILT_IN_NEXTAFTER;
3674         copysign = BUILT_IN_COPYSIGN;
3675         huge_val = BUILT_IN_HUGE_VAL;
3676         break;
3677       case 10:
3678       case 16:
3679         nextafter = BUILT_IN_NEXTAFTERL;
3680         copysign = BUILT_IN_COPYSIGNL;
3681         huge_val = BUILT_IN_HUGE_VALL;
3682         break;
3683       default:
3684         gcc_unreachable ();
3685     }
3686
3687   type = gfc_typenode_for_spec (&expr->ts);
3688   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3689   tmp = build_call_expr_loc (input_location,
3690                          built_in_decls[copysign], 2,
3691                          build_call_expr_loc (input_location,
3692                                           built_in_decls[huge_val], 0),
3693                          fold_convert (type, args[1]));
3694   se->expr = build_call_expr_loc (input_location,
3695                               built_in_decls[nextafter], 2,
3696                               fold_convert (type, args[0]), tmp);
3697   se->expr = fold_convert (type, se->expr);
3698 }
3699
3700
3701 /* SPACING (s) is translated into
3702     int e;
3703     if (s == 0)
3704       res = tiny;
3705     else
3706     {
3707       frexp (s, &e);
3708       e = e - prec;
3709       e = MAX_EXPR (e, emin);
3710       res = scalbn (1., e);
3711     }
3712     return res;
3713
3714  where prec is the precision of s, gfc_real_kinds[k].digits,
3715        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3716    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3717
3718 static void
3719 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3720 {
3721   tree arg, type, prec, emin, tiny, res, e;
3722   tree cond, tmp;
3723   int frexp, scalbn, k;
3724   stmtblock_t block;
3725
3726   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3727   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3728   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3729   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3730
3731   switch (expr->ts.kind)
3732     {
3733       case 4:
3734         frexp = BUILT_IN_FREXPF;
3735         scalbn = BUILT_IN_SCALBNF;
3736         break;
3737       case 8:
3738         frexp = BUILT_IN_FREXP;
3739         scalbn = BUILT_IN_SCALBN;
3740         break;
3741       case 10:
3742       case 16:
3743         frexp = BUILT_IN_FREXPL;
3744         scalbn = BUILT_IN_SCALBNL;
3745         break;
3746       default:
3747         gcc_unreachable ();
3748     }
3749
3750   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3751   arg = gfc_evaluate_now (arg, &se->pre);
3752
3753   type = gfc_typenode_for_spec (&expr->ts);
3754   e = gfc_create_var (integer_type_node, NULL);
3755   res = gfc_create_var (type, NULL);
3756
3757
3758   /* Build the block for s /= 0.  */
3759   gfc_start_block (&block);
3760   tmp = build_call_expr_loc (input_location,
3761                          built_in_decls[frexp], 2, arg,
3762                          gfc_build_addr_expr (NULL_TREE, e));
3763   gfc_add_expr_to_block (&block, tmp);
3764
3765   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3766   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3767                                           tmp, emin));
3768
3769   tmp = build_call_expr_loc (input_location,
3770                          built_in_decls[scalbn], 2,
3771                          build_real_from_int_cst (type, integer_one_node), e);
3772   gfc_add_modify (&block, res, tmp);
3773
3774   /* Finish by building the IF statement.  */
3775   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3776                       build_real_from_int_cst (type, integer_zero_node));
3777   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3778                   gfc_finish_block (&block));
3779
3780   gfc_add_expr_to_block (&se->pre, tmp);
3781   se->expr = res;
3782 }
3783
3784
3785 /* RRSPACING (s) is translated into
3786       int e;
3787       real x;
3788       x = fabs (s);
3789       if (x != 0)
3790       {
3791         frexp (s, &e);
3792         x = scalbn (x, precision - e);
3793       }
3794       return x;
3795
3796  where precision is gfc_real_kinds[k].digits.  */
3797
3798 static void
3799 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3800 {
3801   tree arg, type, e, x, cond, stmt, tmp;
3802   int frexp, scalbn, fabs, prec, k;
3803   stmtblock_t block;
3804
3805   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3806   prec = gfc_real_kinds[k].digits;
3807   switch (expr->ts.kind)
3808     {
3809       case 4:
3810         frexp = BUILT_IN_FREXPF;
3811         scalbn = BUILT_IN_SCALBNF;
3812         fabs = BUILT_IN_FABSF;
3813         break;
3814       case 8:
3815         frexp = BUILT_IN_FREXP;
3816         scalbn = BUILT_IN_SCALBN;
3817         fabs = BUILT_IN_FABS;
3818         break;
3819       case 10:
3820       case 16:
3821         frexp = BUILT_IN_FREXPL;
3822         scalbn = BUILT_IN_SCALBNL;
3823         fabs = BUILT_IN_FABSL;
3824         break;
3825       default:
3826         gcc_unreachable ();
3827     }
3828
3829   type = gfc_typenode_for_spec (&expr->ts);
3830   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3831   arg = gfc_evaluate_now (arg, &se->pre);
3832
3833   e = gfc_create_var (integer_type_node, NULL);
3834   x = gfc_create_var (type, NULL);
3835   gfc_add_modify (&se->pre, x,
3836                   build_call_expr_loc (input_location,
3837                                    built_in_decls[fabs], 1, arg));
3838
3839
3840   gfc_start_block (&block);
3841   tmp = build_call_expr_loc (input_location,
3842                          built_in_decls[frexp], 2, arg,
3843                          gfc_build_addr_expr (NULL_TREE, e));
3844   gfc_add_expr_to_block (&block, tmp);
3845
3846   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3847                      build_int_cst (NULL_TREE, prec), e);
3848   tmp = build_call_expr_loc (input_location,
3849                          built_in_decls[scalbn], 2, x, tmp);
3850   gfc_add_modify (&block, x, tmp);
3851   stmt = gfc_finish_block (&block);
3852
3853   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3854                       build_real_from_int_cst (type, integer_zero_node));
3855   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
3856   gfc_add_expr_to_block (&se->pre, tmp);
3857
3858   se->expr = fold_convert (type, x);
3859 }
3860
3861
3862 /* SCALE (s, i) is translated into scalbn (s, i).  */
3863 static void
3864 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3865 {
3866   tree args[2], type;
3867   int scalbn;
3868
3869   switch (expr->ts.kind)
3870     {
3871       case 4:
3872         scalbn = BUILT_IN_SCALBNF;
3873         break;
3874       case 8:
3875         scalbn = BUILT_IN_SCALBN;
3876         break;
3877       case 10:
3878       case 16:
3879         scalbn = BUILT_IN_SCALBNL;
3880         break;
3881       default:
3882         gcc_unreachable ();
3883     }
3884
3885   type = gfc_typenode_for_spec (&expr->ts);
3886   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3887   se->expr = build_call_expr_loc (input_location,
3888                               built_in_decls[scalbn], 2,
3889                               fold_convert (type, args[0]),
3890                               fold_convert (integer_type_node, args[1]));
3891   se->expr = fold_convert (type, se->expr);
3892 }
3893
3894
3895 /* SET_EXPONENT (s, i) is translated into
3896    scalbn (frexp (s, &dummy_int), i).  */
3897 static void
3898 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3899 {
3900   tree args[2], type, tmp;
3901   int frexp, scalbn;
3902
3903   switch (expr->ts.kind)
3904     {
3905       case 4:
3906         frexp = BUILT_IN_FREXPF;
3907         scalbn = BUILT_IN_SCALBNF;
3908         break;
3909       case 8:
3910         frexp = BUILT_IN_FREXP;
3911         scalbn = BUILT_IN_SCALBN;
3912         break;
3913       case 10:
3914       case 16:
3915         frexp = BUILT_IN_FREXPL;
3916         scalbn = BUILT_IN_SCALBNL;
3917         break;
3918       default:
3919         gcc_unreachable ();
3920     }
3921
3922   type = gfc_typenode_for_spec (&expr->ts);
3923   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3924
3925   tmp = gfc_create_var (integer_type_node, NULL);
3926   tmp = build_call_expr_loc (input_location,
3927                          built_in_decls[frexp], 2,
3928                          fold_convert (type, args[0]),
3929                          gfc_build_addr_expr (NULL_TREE, tmp));
3930   se->expr = build_call_expr_loc (input_location,
3931                               built_in_decls[scalbn], 2, tmp,
3932                               fold_convert (integer_type_node, args[1]));
3933   se->expr = fold_convert (type, se->expr);
3934 }
3935
3936
3937 static void
3938 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3939 {
3940   gfc_actual_arglist *actual;
3941   tree arg1;
3942   tree type;
3943   tree fncall0;
3944   tree fncall1;
3945   gfc_se argse;
3946   gfc_ss *ss;
3947
3948   gfc_init_se (&argse, NULL);
3949   actual = expr->value.function.actual;
3950
3951   ss = gfc_walk_expr (actual->expr);
3952   gcc_assert (ss != gfc_ss_terminator);
3953   argse.want_pointer = 1;
3954   argse.data_not_needed = 1;
3955   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3956   gfc_add_block_to_block (&se->pre, &argse.pre);
3957   gfc_add_block_to_block (&se->post, &argse.post);
3958   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3959
3960   /* Build the call to size0.  */
3961   fncall0 = build_call_expr_loc (input_location,
3962                              gfor_fndecl_size0, 1, arg1);
3963
3964   actual = actual->next;
3965
3966   if (actual->expr)
3967     {
3968       gfc_init_se (&argse, NULL);
3969       gfc_conv_expr_type (&argse, actual->expr,
3970                           gfc_array_index_type);
3971       gfc_add_block_to_block (&se->pre, &argse.pre);
3972
3973       /* Unusually, for an intrinsic, size does not exclude
3974          an optional arg2, so we must test for it.  */
3975       if (actual->expr->expr_type == EXPR_VARIABLE
3976             && actual->expr->symtree->n.sym->attr.dummy
3977             && actual->expr->symtree->n.sym->attr.optional)
3978         {
3979           tree tmp;
3980           /* Build the call to size1.  */
3981           fncall1 = build_call_expr_loc (input_location,
3982                                      gfor_fndecl_size1, 2,
3983                                      arg1, argse.expr);
3984
3985           gfc_init_se (&argse, NULL);
3986           argse.want_pointer = 1;
3987           argse.data_not_needed = 1;
3988           gfc_conv_expr (&argse, actual->expr);
3989           gfc_add_block_to_block (&se->pre, &argse.pre);
3990           tmp = fold_build2 (NE_EXPR, boolean_type_node,
3991                              argse.expr, null_pointer_node);
3992           tmp = gfc_evaluate_now (tmp, &se->pre);
3993           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3994                                   tmp, fncall1, fncall0);
3995         }
3996       else
3997         {
3998           se->expr = NULL_TREE;
3999           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4000                                     argse.expr, gfc_index_one_node);
4001         }
4002     }
4003   else if (expr->value.function.actual->expr->rank == 1)
4004     {
4005       argse.expr = gfc_index_zero_node;
4006       se->expr = NULL_TREE;
4007     }
4008   else
4009     se->expr = fncall0;
4010
4011   if (se->expr == NULL_TREE)
4012     {
4013       tree ubound, lbound;
4014
4015       arg1 = build_fold_indirect_ref_loc (input_location,
4016                                       arg1);
4017       ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
4018       lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
4019       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4020                               ubound, lbound);
4021       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
4022                               gfc_index_one_node);
4023       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
4024                               gfc_index_zero_node);
4025     }
4026
4027   type = gfc_typenode_for_spec (&expr->ts);
4028   se->expr = convert (type, se->expr);
4029 }
4030
4031
4032 /* Helper function to compute the size of a character variable,
4033    excluding the terminating null characters.  The result has
4034    gfc_array_index_type type.  */
4035
4036 static tree
4037 size_of_string_in_bytes (int kind, tree string_length)
4038 {
4039   tree bytesize;
4040   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
4041
4042   bytesize = build_int_cst (gfc_array_index_type,
4043                             gfc_character_kinds[i].bit_size / 8);
4044
4045   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
4046                       fold_convert (gfc_array_index_type, string_length));
4047 }
4048
4049
4050 static void
4051 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
4052 {
4053   gfc_expr *arg;
4054   gfc_ss *ss;
4055   gfc_se argse;
4056   tree source_bytes;
4057   tree type;
4058   tree tmp;
4059   tree lower;
4060   tree upper;
4061   int n;
4062
4063   arg = expr->value.function.actual->expr;
4064
4065   gfc_init_se (&argse, NULL);
4066   ss = gfc_walk_expr (arg);
4067
4068   if (ss == gfc_ss_terminator)
4069     {
4070       gfc_conv_expr_reference (&argse, arg);
4071
4072       type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4073                                                  argse.expr));
4074
4075       /* Obtain the source word length.  */
4076       if (arg->ts.type == BT_CHARACTER)
4077         se->expr = size_of_string_in_bytes (arg->ts.kind,
4078                                             argse.string_length);
4079       else
4080         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
4081     }
4082   else
4083     {
4084       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
4085       argse.want_pointer = 0;
4086       gfc_conv_expr_descriptor (&argse, arg, ss);
4087       type = gfc_get_element_type (TREE_TYPE (argse.expr));
4088
4089       /* Obtain the argument's word length.  */
4090       if (arg->ts.type == BT_CHARACTER)
4091         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
4092       else
4093         tmp = fold_convert (gfc_array_index_type,
4094                             size_in_bytes (type));
4095       gfc_add_modify (&argse.pre, source_bytes, tmp);
4096
4097       /* Obtain the size of the array in bytes.  */
4098       for (n = 0; n < arg->rank; n++)
4099         {
4100           tree idx;
4101           idx = gfc_rank_cst[n];
4102           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4103           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4104           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4105                              upper, lower);
4106           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4107                              tmp, gfc_index_one_node);
4108           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4109                              tmp, source_bytes);
4110           gfc_add_modify (&argse.pre, source_bytes, tmp);
4111         }
4112       se->expr = source_bytes;
4113     }
4114
4115   gfc_add_block_to_block (&se->pre, &argse.pre);
4116 }
4117
4118
4119 /* Intrinsic string comparison functions.  */
4120
4121 static void
4122 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
4123 {
4124   tree args[4];
4125
4126   gfc_conv_intrinsic_function_args (se, expr, args, 4);
4127
4128   se->expr
4129     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
4130                                 expr->value.function.actual->expr->ts.kind);
4131   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
4132                           build_int_cst (TREE_TYPE (se->expr), 0));
4133 }
4134
4135 /* Generate a call to the adjustl/adjustr library function.  */
4136 static void
4137 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
4138 {
4139   tree args[3];
4140   tree len;
4141   tree type;
4142   tree var;
4143   tree tmp;
4144
4145   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
4146   len = args[1];
4147
4148   type = TREE_TYPE (args[2]);
4149   var = gfc_conv_string_tmp (se, type, len);
4150   args[0] = var;
4151
4152   tmp = build_call_expr_loc (input_location,
4153                          fndecl, 3, args[0], args[1], args[2]);
4154   gfc_add_expr_to_block (&se->pre, tmp);
4155   se->expr = var;
4156   se->string_length = len;
4157 }
4158
4159
4160 /* Generate code for the TRANSFER intrinsic:
4161         For scalar results:
4162           DEST = TRANSFER (SOURCE, MOLD)
4163         where:
4164           typeof<DEST> = typeof<MOLD>
4165         and:
4166           MOLD is scalar.
4167
4168         For array results:
4169           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
4170         where:
4171           typeof<DEST> = typeof<MOLD>
4172         and:
4173           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
4174               sizeof (DEST(0) * SIZE).  */
4175 static void
4176 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
4177 {
4178   tree tmp;
4179   tree tmpdecl;
4180   tree ptr;
4181   tree extent;
4182   tree source;
4183   tree source_type;
4184   tree source_bytes;
4185   tree mold_type;
4186   tree dest_word_len;
4187   tree size_words;
4188   tree size_bytes;
4189   tree upper;
4190   tree lower;
4191   tree stmt;
4192   gfc_actual_arglist *arg;
4193   gfc_se argse;
4194   gfc_ss *ss;
4195   gfc_ss_info *info;
4196   stmtblock_t block;
4197   int n;
4198   bool scalar_mold;
4199
4200   info = NULL;
4201   if (se->loop)
4202     info = &se->ss->data.info;
4203
4204   /* Convert SOURCE.  The output from this stage is:-
4205         source_bytes = length of the source in bytes
4206         source = pointer to the source data.  */
4207   arg = expr->value.function.actual;
4208
4209   /* Ensure double transfer through LOGICAL preserves all
4210      the needed bits.  */
4211   if (arg->expr->expr_type == EXPR_FUNCTION
4212         && arg->expr->value.function.esym == NULL
4213         && arg->expr->value.function.isym != NULL
4214         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
4215         && arg->expr->ts.type == BT_LOGICAL
4216         && expr->ts.type != arg->expr->ts.type)
4217     arg->expr->value.function.name = "__transfer_in_transfer";
4218
4219   gfc_init_se (&argse, NULL);
4220   ss = gfc_walk_expr (arg->expr);
4221
4222   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
4223
4224   /* Obtain the pointer to source and the length of source in bytes.  */
4225   if (ss == gfc_ss_terminator)
4226     {
4227       gfc_conv_expr_reference (&argse, arg->expr);
4228       source = argse.expr;
4229
4230       source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4231                                                         argse.expr));
4232
4233       /* Obtain the source word length.  */
4234       if (arg->expr->ts.type == BT_CHARACTER)
4235         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4236                                        argse.string_length);
4237       else
4238         tmp = fold_convert (gfc_array_index_type,
4239                             size_in_bytes (source_type));
4240     }
4241   else
4242     {
4243       argse.want_pointer = 0;
4244       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4245       source = gfc_conv_descriptor_data_get (argse.expr);
4246       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4247
4248       /* Repack the source if not a full variable array.  */
4249       if (arg->expr->expr_type == EXPR_VARIABLE
4250               && arg->expr->ref->u.ar.type != AR_FULL)
4251         {
4252           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
4253
4254           if (gfc_option.warn_array_temp)
4255             gfc_warning ("Creating array temporary at %L", &expr->where);
4256
4257           source = build_call_expr_loc (input_location,
4258                                     gfor_fndecl_in_pack, 1, tmp);
4259           source = gfc_evaluate_now (source, &argse.pre);
4260
4261           /* Free the temporary.  */
4262           gfc_start_block (&block);
4263           tmp = gfc_call_free (convert (pvoid_type_node, source));
4264           gfc_add_expr_to_block (&block, tmp);
4265           stmt = gfc_finish_block (&block);
4266
4267           /* Clean up if it was repacked.  */
4268           gfc_init_block (&block);
4269           tmp = gfc_conv_array_data (argse.expr);
4270           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
4271           tmp = build3_v (COND_EXPR, tmp, stmt,
4272                           build_empty_stmt (input_location));
4273           gfc_add_expr_to_block (&block, tmp);
4274           gfc_add_block_to_block (&block, &se->post);
4275           gfc_init_block (&se->post);
4276           gfc_add_block_to_block (&se->post, &block);
4277         }
4278
4279       /* Obtain the source word length.  */
4280       if (arg->expr->ts.type == BT_CHARACTER)
4281         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
4282                                        argse.string_length);
4283       else
4284         tmp = fold_convert (gfc_array_index_type,
4285                             size_in_bytes (source_type));
4286
4287       /* Obtain the size of the array in bytes.  */
4288       extent = gfc_create_var (gfc_array_index_type, NULL);
4289       for (n = 0; n < arg->expr->rank; n++)
4290         {
4291           tree idx;
4292           idx = gfc_rank_cst[n];
4293           gfc_add_modify (&argse.pre, source_bytes, tmp);
4294           lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
4295           upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
4296           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4297                              upper, lower);
4298           gfc_add_modify (&argse.pre, extent, tmp);
4299           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4300                              extent, gfc_index_one_node);
4301           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4302                              tmp, source_bytes);
4303         }
4304     }
4305
4306   gfc_add_modify (&argse.pre, source_bytes, tmp);
4307   gfc_add_block_to_block (&se->pre, &argse.pre);
4308   gfc_add_block_to_block (&se->post, &argse.post);
4309
4310   /* Now convert MOLD.  The outputs are:
4311         mold_type = the TREE type of MOLD
4312         dest_word_len = destination word length in bytes.  */
4313   arg = arg->next;
4314
4315   gfc_init_se (&argse, NULL);
4316   ss = gfc_walk_expr (arg->expr);
4317
4318   scalar_mold = arg->expr->rank == 0;
4319
4320   if (ss == gfc_ss_terminator)
4321     {
4322       gfc_conv_expr_reference (&argse, arg->expr);
4323       mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
4324                                                       argse.expr));
4325     }
4326   else
4327     {
4328       gfc_init_se (&argse, NULL);
4329       argse.want_pointer = 0;
4330       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
4331       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
4332     }
4333
4334   gfc_add_block_to_block (&se->pre, &argse.pre);
4335   gfc_add_block_to_block (&se->post, &argse.post);
4336
4337   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
4338     {
4339       /* If this TRANSFER is nested in another TRANSFER, use a type
4340          that preserves all bits.  */
4341       if (arg->expr->ts.type == BT_LOGICAL)
4342         mold_type = gfc_get_int_type (arg->expr->ts.kind);
4343     }
4344
4345   if (arg->expr->ts.type == BT_CHARACTER)
4346     {
4347       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
4348       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
4349     }
4350   else
4351     tmp = fold_convert (gfc_array_index_type,
4352                         size_in_bytes (mold_type));
4353
4354   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
4355   gfc_add_modify (&se->pre, dest_word_len, tmp);
4356
4357   /* Finally convert SIZE, if it is present.  */
4358   arg = arg->next;
4359   size_words = gfc_create_var (gfc_array_index_type, NULL);
4360
4361   if (arg->expr)
4362     {
4363       gfc_init_se (&argse, NULL);
4364       gfc_conv_expr_reference (&argse, arg->expr);
4365       tmp = convert (gfc_array_index_type,
4366                      build_fold_indirect_ref_loc (input_location,
4367                                               argse.expr));
4368       gfc_add_block_to_block (&se->pre, &argse.pre);
4369       gfc_add_block_to_block (&se->post, &argse.post);
4370     }
4371   else
4372     tmp = NULL_TREE;
4373
4374   /* Separate array and scalar results.  */
4375   if (scalar_mold && tmp == NULL_TREE)
4376     goto scalar_transfer;
4377
4378   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
4379   if (tmp != NULL_TREE)
4380     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
4381                        tmp, dest_word_len);
4382   else
4383     tmp = source_bytes;
4384
4385   gfc_add_modify (&se->pre, size_bytes, tmp);
4386   gfc_add_modify (&se->pre, size_words,
4387                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
4388                                     size_bytes, dest_word_len));
4389
4390   /* Evaluate the bounds of the result.  If the loop range exists, we have
4391      to check if it is too large.  If so, we modify loop->to be consistent
4392      with min(size, size(source)).  Otherwise, size is made consistent with
4393      the loop range, so that the right number of bytes is transferred.*/
4394   n = se->loop->order[0];
4395   if (se->loop->to[n] != NULL_TREE)
4396     {
4397       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4398                          se->loop->to[n], se->loop->from[n]);
4399       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4400                          tmp, gfc_index_one_node);
4401       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
4402                          tmp, size_words);
4403       gfc_add_modify (&se->pre, size_words, tmp);
4404       gfc_add_modify (&se->pre, size_bytes,
4405                            fold_build2 (MULT_EXPR, gfc_array_index_type,
4406                                         size_words, dest_word_len));
4407       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
4408                            size_words, se->loop->from[n]);
4409       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4410                            upper, gfc_index_one_node);
4411     }
4412   else
4413     {
4414       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
4415                            size_words, gfc_index_one_node);
4416       se->loop->from[n] = gfc_index_zero_node;
4417     }
4418
4419   se->loop->to[n] = upper;
4420
4421   /* Build a destination descriptor, using the pointer, source, as the
4422      data field.  */
4423   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
4424                                info, mold_type, NULL_TREE, false, true, false,
4425                                &expr->where);
4426
4427   /* Cast the pointer to the result.  */
4428   tmp = gfc_conv_descriptor_data_get (info->descriptor);
4429   tmp = fold_convert (pvoid_type_node, tmp);
4430
4431   /* Use memcpy to do the transfer.  */
4432   tmp = build_call_expr_loc (input_location,
4433                          built_in_decls[BUILT_IN_MEMCPY],
4434                          3,
4435                          tmp,
4436                          fold_convert (pvoid_type_node, source),
4437                          fold_build2 (MIN_EXPR, gfc_array_index_type,
4438                                       size_bytes, source_bytes));
4439   gfc_add_expr_to_block (&se->pre, tmp);
4440
4441   se->expr = info->descriptor;
4442   if (expr->ts.type == BT_CHARACTER)
4443     se->string_length = dest_word_len;
4444
4445   return;
4446
4447 /* Deal with scalar results.  */
4448 scalar_transfer:
4449   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
4450                         dest_word_len, source_bytes);
4451   extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
4452                         extent, gfc_index_zero_node);
4453
4454   if (expr->ts.type == BT_CHARACTER)
4455     {
4456       tree direct;
4457       tree indirect;
4458
4459       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
4460       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
4461                                 "transfer");
4462
4463       /* If source is longer than the destination, use a pointer to
4464          the source directly.  */
4465       gfc_init_block (&block);
4466       gfc_add_modify (&block, tmpdecl, ptr);
4467       direct = gfc_finish_block (&block);
4468
4469       /* Otherwise, allocate a string with the length of the destination
4470          and copy the source into it.  */
4471       gfc_init_block (&block);
4472       tmp = gfc_get_pchar_type (expr->ts.kind);
4473       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
4474       gfc_add_modify (&block, tmpdecl,
4475                       fold_convert (TREE_TYPE (ptr), tmp));
4476       tmp = build_call_expr_loc (input_location,
4477                              built_in_decls[BUILT_IN_MEMCPY], 3,
4478                              fold_convert (pvoid_type_node, tmpdecl),
4479                              fold_convert (pvoid_type_node, ptr),
4480                              extent);
4481       gfc_add_expr_to_block (&block, tmp);
4482       indirect = gfc_finish_block (&block);
4483
4484       /* Wrap it up with the condition.  */
4485       tmp = fold_build2 (LE_EXPR, boolean_type_node,
4486                          dest_word_len, source_bytes);
4487       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
4488       gfc_add_expr_to_block (&se->pre, tmp);
4489
4490       se->expr = tmpdecl;
4491       se->string_length = dest_word_len;
4492     }
4493   else
4494     {
4495       tmpdecl = gfc_create_var (mold_type, "transfer");
4496
4497       ptr = convert (build_pointer_type (mold_type), source);
4498
4499       /* Use memcpy to do the transfer.  */
4500       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
4501       tmp = build_call_expr_loc (input_location,
4502                              built_in_decls[BUILT_IN_MEMCPY], 3,
4503                              fold_convert (pvoid_type_node, tmp),
4504                              fold_convert (pvoid_type_node, ptr),
4505                              extent);
4506       gfc_add_expr_to_block (&se->pre, tmp);
4507
4508       se->expr = tmpdecl;
4509     }
4510 }
4511
4512
4513 /* Generate code for the ALLOCATED intrinsic.
4514    Generate inline code that directly check the address of the argument.  */
4515
4516 static void
4517 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
4518 {
4519   gfc_actual_arglist *arg1;
4520   gfc_se arg1se;
4521   gfc_ss *ss1;
4522   tree tmp;
4523
4524   gfc_init_se (&arg1se, NULL);
4525   arg1 = expr->value.function.actual;
4526   ss1 = gfc_walk_expr (arg1->expr);
4527
4528   if (ss1 == gfc_ss_terminator)
4529     {
4530       /* Allocatable scalar.  */
4531       arg1se.want_pointer = 1;
4532       gfc_conv_expr (&arg1se, arg1->expr);
4533       tmp = arg1se.expr;
4534     }
4535   else
4536     {
4537       /* Allocatable array.  */
4538       arg1se.descriptor_only = 1;
4539       gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4540       tmp = gfc_conv_descriptor_data_get (arg1se.expr);
4541     }
4542
4543   tmp = fold_build2 (NE_EXPR, boolean_type_node,
4544                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
4545   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4546 }
4547
4548
4549 /* Generate code for the ASSOCIATED intrinsic.
4550    If both POINTER and TARGET are arrays, generate a call to library function
4551    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
4552    In other cases, generate inline code that directly compare the address of
4553    POINTER with the address of TARGET.  */
4554
4555 static void
4556 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4557 {
4558   gfc_actual_arglist *arg1;
4559   gfc_actual_arglist *arg2;
4560   gfc_se arg1se;
4561   gfc_se arg2se;
4562   tree tmp2;
4563   tree tmp;
4564   tree nonzero_charlen;
4565   tree nonzero_arraylen;
4566   gfc_ss *ss1, *ss2;
4567
4568   gfc_init_se (&arg1se, NULL);
4569   gfc_init_se (&arg2se, NULL);
4570   arg1 = expr->value.function.actual;
4571   if (arg1->expr->ts.type == BT_CLASS)
4572     gfc_add_component_ref (arg1->expr, "$data");
4573   arg2 = arg1->next;
4574   ss1 = gfc_walk_expr (arg1->expr);
4575
4576   if (!arg2->expr)
4577     {
4578       /* No optional target.  */
4579       if (ss1 == gfc_ss_terminator)
4580         {
4581           /* A pointer to a scalar.  */
4582           arg1se.want_pointer = 1;
4583           gfc_conv_expr (&arg1se, arg1->expr);
4584           tmp2 = arg1se.expr;
4585         }
4586       else
4587         {
4588           /* A pointer to an array.  */
4589           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4590           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4591         }
4592       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4593       gfc_add_block_to_block (&se->post, &arg1se.post);
4594       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4595                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4596       se->expr = tmp;
4597     }
4598   else
4599     {
4600       /* An optional target.  */
4601       ss2 = gfc_walk_expr (arg2->expr);
4602
4603       nonzero_charlen = NULL_TREE;
4604       if (arg1->expr->ts.type == BT_CHARACTER)
4605         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4606                                        arg1->expr->ts.u.cl->backend_decl,
4607                                        integer_zero_node);
4608
4609       if (ss1 == gfc_ss_terminator)
4610         {
4611           /* A pointer to a scalar.  */
4612           gcc_assert (ss2 == gfc_ss_terminator);
4613           arg1se.want_pointer = 1;
4614           gfc_conv_expr (&arg1se, arg1->expr);
4615           arg2se.want_pointer = 1;
4616           gfc_conv_expr (&arg2se, arg2->expr);
4617           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4618           gfc_add_block_to_block (&se->post, &arg1se.post);
4619           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4620                              arg1se.expr, arg2se.expr);
4621           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4622                               arg1se.expr, null_pointer_node);
4623           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4624                                   tmp, tmp2);
4625         }
4626       else
4627         {
4628           /* An array pointer of zero length is not associated if target is
4629              present.  */
4630           arg1se.descriptor_only = 1;
4631           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4632           tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
4633                                             gfc_rank_cst[arg1->expr->rank - 1]);
4634           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4635                                           build_int_cst (TREE_TYPE (tmp), 0));
4636
4637           /* A pointer to an array, call library function _gfor_associated.  */
4638           gcc_assert (ss2 != gfc_ss_terminator);
4639           arg1se.want_pointer = 1;
4640           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4641
4642           arg2se.want_pointer = 1;
4643           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4644           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4645           gfc_add_block_to_block (&se->post, &arg2se.post);
4646           se->expr = build_call_expr_loc (input_location,
4647                                       gfor_fndecl_associated, 2,
4648                                       arg1se.expr, arg2se.expr);
4649           se->expr = convert (boolean_type_node, se->expr);
4650           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4651                                   se->expr, nonzero_arraylen);
4652         }
4653
4654       /* If target is present zero character length pointers cannot
4655          be associated.  */
4656       if (nonzero_charlen != NULL_TREE)
4657         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4658                                 se->expr, nonzero_charlen);
4659     }
4660
4661   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4662 }
4663
4664
4665 /* Generate code for the SAME_TYPE_AS intrinsic.
4666    Generate inline code that directly checks the vindices.  */
4667
4668 static void
4669 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
4670 {
4671   gfc_expr *a, *b;
4672   gfc_se se1, se2;
4673   tree tmp;
4674
4675   gfc_init_se (&se1, NULL);
4676   gfc_init_se (&se2, NULL);
4677
4678   a = expr->value.function.actual->expr;
4679   b = expr->value.function.actual->next->expr;
4680
4681   if (a->ts.type == BT_CLASS)
4682     {
4683       gfc_add_component_ref (a, "$vptr");
4684       gfc_add_component_ref (a, "$hash");
4685     }
4686   else if (a->ts.type == BT_DERIVED)
4687     a = gfc_int_expr (a->ts.u.derived->hash_value);
4688
4689   if (b->ts.type == BT_CLASS)
4690     {
4691       gfc_add_component_ref (b, "$vptr");
4692       gfc_add_component_ref (b, "$hash");
4693     }
4694   else if (b->ts.type == BT_DERIVED)
4695     b = gfc_int_expr (b->ts.u.derived->hash_value);
4696
4697   gfc_conv_expr (&se1, a);
4698   gfc_conv_expr (&se2, b);
4699
4700   tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4701                      se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
4702   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
4703 }
4704
4705
4706 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4707
4708 static void
4709 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4710 {
4711   tree args[2];
4712
4713   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4714   se->expr = build_call_expr_loc (input_location,
4715                               gfor_fndecl_sc_kind, 2, args[0], args[1]);
4716   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4717 }
4718
4719
4720 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4721
4722 static void
4723 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4724 {
4725   tree arg, type;
4726
4727   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4728
4729   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4730   type = gfc_get_int_type (4);
4731   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4732
4733   /* Convert it to the required type.  */
4734   type = gfc_typenode_for_spec (&expr->ts);
4735   se->expr = build_call_expr_loc (input_location,
4736                               gfor_fndecl_si_kind, 1, arg);
4737   se->expr = fold_convert (type, se->expr);
4738 }
4739
4740
4741 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4742
4743 static void
4744 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4745 {
4746   gfc_actual_arglist *actual;
4747   tree args, type;
4748   gfc_se argse;
4749
4750   args = NULL_TREE;
4751   for (actual = expr->value.function.actual; actual; actual = actual->next)
4752     {
4753       gfc_init_se (&argse, se);
4754
4755       /* Pass a NULL pointer for an absent arg.  */
4756       if (actual->expr == NULL)
4757         argse.expr = null_pointer_node;
4758       else
4759         {
4760           gfc_typespec ts;
4761           gfc_clear_ts (&ts);
4762
4763           if (actual->expr->ts.kind != gfc_c_int_kind)
4764             {
4765               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4766               ts.type = BT_INTEGER;
4767               ts.kind = gfc_c_int_kind;
4768               gfc_convert_type (actual->expr, &ts, 2);
4769             }
4770           gfc_conv_expr_reference (&argse, actual->expr);
4771         }
4772
4773       gfc_add_block_to_block (&se->pre, &argse.pre);
4774       gfc_add_block_to_block (&se->post, &argse.post);
4775       args = gfc_chainon_list (args, argse.expr);
4776     }
4777
4778   /* Convert it to the required type.  */
4779   type = gfc_typenode_for_spec (&expr->ts);
4780   se->expr = build_function_call_expr (input_location,
4781                                        gfor_fndecl_sr_kind, args);
4782   se->expr = fold_convert (type, se->expr);
4783 }
4784
4785
4786 /* Generate code for TRIM (A) intrinsic function.  */
4787
4788 static void
4789 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4790 {
4791   tree var;
4792   tree len;
4793   tree addr;
4794   tree tmp;
4795   tree cond;
4796   tree fndecl;
4797   tree function;
4798   tree *args;
4799   unsigned int num_args;
4800
4801   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4802   args = (tree *) alloca (sizeof (tree) * num_args);
4803
4804   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4805   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4806   len = gfc_create_var (gfc_get_int_type (4), "len");
4807
4808   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4809   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4810   args[1] = addr;
4811
4812   if (expr->ts.kind == 1)
4813     function = gfor_fndecl_string_trim;
4814   else if (expr->ts.kind == 4)
4815     function = gfor_fndecl_string_trim_char4;
4816   else
4817     gcc_unreachable ();
4818
4819   fndecl = build_addr (function, current_function_decl);
4820   tmp = build_call_array_loc (input_location,
4821                           TREE_TYPE (TREE_TYPE (function)), fndecl,
4822                           num_args, args);
4823   gfc_add_expr_to_block (&se->pre, tmp);
4824
4825   /* Free the temporary afterwards, if necessary.  */
4826   cond = fold_build2 (GT_EXPR, boolean_type_node,
4827                       len, build_int_cst (TREE_TYPE (len), 0));
4828   tmp = gfc_call_free (var);
4829   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
4830   gfc_add_expr_to_block (&se->post, tmp);
4831
4832   se->expr = var;
4833   se->string_length = len;
4834 }
4835
4836
4837 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4838
4839 static void
4840 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4841 {
4842   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4843   tree type, cond, tmp, count, exit_label, n, max, largest;
4844   tree size;
4845   stmtblock_t block, body;
4846   int i;
4847
4848   /* We store in charsize the size of a character.  */
4849   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4850   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4851
4852   /* Get the arguments.  */
4853   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4854   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4855   src = args[1];
4856   ncopies = gfc_evaluate_now (args[2], &se->pre);
4857   ncopies_type = TREE_TYPE (ncopies);
4858
4859   /* Check that NCOPIES is not negative.  */
4860   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4861                       build_int_cst (ncopies_type, 0));
4862   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4863                            "Argument NCOPIES of REPEAT intrinsic is negative "
4864                            "(its value is %lld)",
4865                            fold_convert (long_integer_type_node, ncopies));
4866
4867   /* If the source length is zero, any non negative value of NCOPIES
4868      is valid, and nothing happens.  */
4869   n = gfc_create_var (ncopies_type, "ncopies");
4870   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4871                       build_int_cst (size_type_node, 0));
4872   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4873                      build_int_cst (ncopies_type, 0), ncopies);
4874   gfc_add_modify (&se->pre, n, tmp);
4875   ncopies = n;
4876
4877   /* Check that ncopies is not too large: ncopies should be less than
4878      (or equal to) MAX / slen, where MAX is the maximal integer of
4879      the gfc_charlen_type_node type.  If slen == 0, we need a special
4880      case to avoid the division by zero.  */
4881   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4882   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4883   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4884                      fold_convert (size_type_node, max), slen);
4885   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4886               ? size_type_node : ncopies_type;
4887   cond = fold_build2 (GT_EXPR, boolean_type_node,
4888                       fold_convert (largest, ncopies),
4889                       fold_convert (largest, max));
4890   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4891                      build_int_cst (size_type_node, 0));
4892   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4893                       cond);
4894   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4895                            "Argument NCOPIES of REPEAT intrinsic is too large");
4896
4897   /* Compute the destination length.  */
4898   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4899                       fold_convert (gfc_charlen_type_node, slen),
4900                       fold_convert (gfc_charlen_type_node, ncopies));
4901   type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
4902   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4903
4904   /* Generate the code to do the repeat operation:
4905        for (i = 0; i < ncopies; i++)
4906          memmove (dest + (i * slen * size), src, slen*size);  */
4907   gfc_start_block (&block);
4908   count = gfc_create_var (ncopies_type, "count");
4909   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4910   exit_label = gfc_build_label_decl (NULL_TREE);
4911
4912   /* Start the loop body.  */
4913   gfc_start_block (&body);
4914
4915   /* Exit the loop if count >= ncopies.  */
4916   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4917   tmp = build1_v (GOTO_EXPR, exit_label);
4918   TREE_USED (exit_label) = 1;
4919   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4920                      build_empty_stmt (input_location));
4921   gfc_add_expr_to_block (&body, tmp);
4922
4923   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4924   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4925                      fold_convert (gfc_charlen_type_node, slen),
4926                      fold_convert (gfc_charlen_type_node, count));
4927   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4928                      tmp, fold_convert (gfc_charlen_type_node, size));
4929   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4930                      fold_convert (pvoid_type_node, dest),
4931                      fold_convert (sizetype, tmp));
4932   tmp = build_call_expr_loc (input_location,
4933                          built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4934                          fold_build2 (MULT_EXPR, size_type_node, slen,
4935                                       fold_convert (size_type_node, size)));
4936   gfc_add_expr_to_block (&body, tmp);
4937
4938   /* Increment count.  */
4939   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4940                      count, build_int_cst (TREE_TYPE (count), 1));
4941   gfc_add_modify (&body, count, tmp);
4942
4943   /* Build the loop.  */
4944   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4945   gfc_add_expr_to_block (&block, tmp);
4946
4947   /* Add the exit label.  */
4948   tmp = build1_v (LABEL_EXPR, exit_label);
4949   gfc_add_expr_to_block (&block, tmp);
4950
4951   /* Finish the block.  */
4952   tmp = gfc_finish_block (&block);
4953   gfc_add_expr_to_block (&se->pre, tmp);
4954
4955   /* Set the result value.  */
4956   se->expr = dest;
4957   se->string_length = dlen;
4958 }
4959
4960
4961 /* Generate code for the IARGC intrinsic.  */
4962
4963 static void
4964 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4965 {
4966   tree tmp;
4967   tree fndecl;
4968   tree type;
4969
4970   /* Call the library function.  This always returns an INTEGER(4).  */
4971   fndecl = gfor_fndecl_iargc;
4972   tmp = build_call_expr_loc (input_location,
4973                          fndecl, 0);
4974
4975   /* Convert it to the required type.  */
4976   type = gfc_typenode_for_spec (&expr->ts);
4977   tmp = fold_convert (type, tmp);
4978
4979   se->expr = tmp;
4980 }
4981
4982
4983 /* The loc intrinsic returns the address of its argument as
4984    gfc_index_integer_kind integer.  */
4985
4986 static void
4987 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4988 {
4989   tree temp_var;
4990   gfc_expr *arg_expr;
4991   gfc_ss *ss;
4992
4993   gcc_assert (!se->ss);
4994
4995   arg_expr = expr->value.function.actual->expr;
4996   ss = gfc_walk_expr (arg_expr);
4997   if (ss == gfc_ss_terminator)
4998     gfc_conv_expr_reference (se, arg_expr);
4999   else
5000     gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL, NULL);
5001   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
5002
5003   /* Create a temporary variable for loc return value.  Without this,
5004      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
5005   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
5006   gfc_add_modify (&se->pre, temp_var, se->expr);
5007   se->expr = temp_var;
5008 }
5009
5010 /* Generate code for an intrinsic function.  Some map directly to library
5011    calls, others get special handling.  In some cases the name of the function
5012    used depends on the type specifiers.  */
5013
5014 void
5015 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
5016 {
5017   const char *name;
5018   int lib, kind;
5019   tree fndecl;
5020
5021   name = &expr->value.function.name[2];
5022
5023   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
5024     {
5025       lib = gfc_is_intrinsic_libcall (expr);
5026       if (lib != 0)
5027         {
5028           if (lib == 1)
5029             se->ignore_optional = 1;
5030
5031           switch (expr->value.function.isym->id)
5032             {
5033             case GFC_ISYM_EOSHIFT:
5034             case GFC_ISYM_PACK:
5035             case GFC_ISYM_RESHAPE:
5036               /* For all of those the first argument specifies the type and the
5037                  third is optional.  */
5038               conv_generic_with_optional_char_arg (se, expr, 1, 3);
5039               break;
5040
5041             default:
5042               gfc_conv_intrinsic_funcall (se, expr);
5043               break;
5044             }
5045
5046           return;
5047         }
5048     }
5049
5050   switch (expr->value.function.isym->id)
5051     {
5052     case GFC_ISYM_NONE:
5053       gcc_unreachable ();
5054
5055     case GFC_ISYM_REPEAT:
5056       gfc_conv_intrinsic_repeat (se, expr);
5057       break;
5058
5059     case GFC_ISYM_TRIM:
5060       gfc_conv_intrinsic_trim (se, expr);
5061       break;
5062
5063     case GFC_ISYM_SC_KIND:
5064       gfc_conv_intrinsic_sc_kind (se, expr);
5065       break;
5066
5067     case GFC_ISYM_SI_KIND:
5068       gfc_conv_intrinsic_si_kind (se, expr);
5069       break;
5070
5071     case GFC_ISYM_SR_KIND:
5072       gfc_conv_intrinsic_sr_kind (se, expr);
5073       break;
5074
5075     case GFC_ISYM_EXPONENT:
5076       gfc_conv_intrinsic_exponent (se, expr);
5077       break;
5078
5079     case GFC_ISYM_SCAN:
5080       kind = expr->value.function.actual->expr->ts.kind;
5081       if (kind == 1)
5082        fndecl = gfor_fndecl_string_scan;
5083       else if (kind == 4)
5084        fndecl = gfor_fndecl_string_scan_char4;
5085       else
5086        gcc_unreachable ();
5087
5088       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5089       break;
5090
5091     case GFC_ISYM_VERIFY:
5092       kind = expr->value.function.actual->expr->ts.kind;
5093       if (kind == 1)
5094        fndecl = gfor_fndecl_string_verify;
5095       else if (kind == 4)
5096        fndecl = gfor_fndecl_string_verify_char4;
5097       else
5098        gcc_unreachable ();
5099
5100       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5101       break;
5102
5103     case GFC_ISYM_ALLOCATED:
5104       gfc_conv_allocated (se, expr);
5105       break;
5106
5107     case GFC_ISYM_ASSOCIATED:
5108       gfc_conv_associated(se, expr);
5109       break;
5110
5111     case GFC_ISYM_SAME_TYPE_AS:
5112       gfc_conv_same_type_as (se, expr);
5113       break;
5114
5115     case GFC_ISYM_ABS:
5116       gfc_conv_intrinsic_abs (se, expr);
5117       break;
5118
5119     case GFC_ISYM_ADJUSTL:
5120       if (expr->ts.kind == 1)
5121        fndecl = gfor_fndecl_adjustl;
5122       else if (expr->ts.kind == 4)
5123        fndecl = gfor_fndecl_adjustl_char4;
5124       else
5125        gcc_unreachable ();
5126
5127       gfc_conv_intrinsic_adjust (se, expr, fndecl);
5128       break;
5129
5130     case GFC_ISYM_ADJUSTR:
5131       if (expr->ts.kind == 1)
5132        fndecl = gfor_fndecl_adjustr;
5133       else if (expr->ts.kind == 4)
5134        fndecl = gfor_fndecl_adjustr_char4;
5135       else
5136        gcc_unreachable ();
5137
5138       gfc_conv_intrinsic_adjust (se, expr, fndecl);
5139       break;
5140
5141     case GFC_ISYM_AIMAG:
5142       gfc_conv_intrinsic_imagpart (se, expr);
5143       break;
5144
5145     case GFC_ISYM_AINT:
5146       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
5147       break;
5148
5149     case GFC_ISYM_ALL:
5150       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
5151       break;
5152
5153     case GFC_ISYM_ANINT:
5154       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
5155       break;
5156
5157     case GFC_ISYM_AND:
5158       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5159       break;
5160
5161     case GFC_ISYM_ANY:
5162       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
5163       break;
5164
5165     case GFC_ISYM_BTEST:
5166       gfc_conv_intrinsic_btest (se, expr);
5167       break;
5168
5169     case GFC_ISYM_ACHAR:
5170     case GFC_ISYM_CHAR:
5171       gfc_conv_intrinsic_char (se, expr);
5172       break;
5173
5174     case GFC_ISYM_CONVERSION:
5175     case GFC_ISYM_REAL:
5176     case GFC_ISYM_LOGICAL:
5177     case GFC_ISYM_DBLE:
5178       gfc_conv_intrinsic_conversion (se, expr);
5179       break;
5180
5181       /* Integer conversions are handled separately to make sure we get the
5182          correct rounding mode.  */
5183     case GFC_ISYM_INT:
5184     case GFC_ISYM_INT2:
5185     case GFC_ISYM_INT8:
5186     case GFC_ISYM_LONG:
5187       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
5188       break;
5189
5190     case GFC_ISYM_NINT:
5191       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
5192       break;
5193
5194     case GFC_ISYM_CEILING:
5195       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
5196       break;
5197
5198     case GFC_ISYM_FLOOR:
5199       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
5200       break;
5201
5202     case GFC_ISYM_MOD:
5203       gfc_conv_intrinsic_mod (se, expr, 0);
5204       break;
5205
5206     case GFC_ISYM_MODULO:
5207       gfc_conv_intrinsic_mod (se, expr, 1);
5208       break;
5209
5210     case GFC_ISYM_CMPLX:
5211       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
5212       break;
5213
5214     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
5215       gfc_conv_intrinsic_iargc (se, expr);
5216       break;
5217
5218     case GFC_ISYM_COMPLEX:
5219       gfc_conv_intrinsic_cmplx (se, expr, 1);
5220       break;
5221
5222     case GFC_ISYM_CONJG:
5223       gfc_conv_intrinsic_conjg (se, expr);
5224       break;
5225
5226     case GFC_ISYM_COUNT:
5227       gfc_conv_intrinsic_count (se, expr);
5228       break;
5229
5230     case GFC_ISYM_CTIME:
5231       gfc_conv_intrinsic_ctime (se, expr);
5232       break;
5233
5234     case GFC_ISYM_DIM:
5235       gfc_conv_intrinsic_dim (se, expr);
5236       break;
5237
5238     case GFC_ISYM_DOT_PRODUCT:
5239       gfc_conv_intrinsic_dot_product (se, expr);
5240       break;
5241
5242     case GFC_ISYM_DPROD:
5243       gfc_conv_intrinsic_dprod (se, expr);
5244       break;
5245
5246     case GFC_ISYM_FDATE:
5247       gfc_conv_intrinsic_fdate (se, expr);
5248       break;
5249
5250     case GFC_ISYM_FRACTION:
5251       gfc_conv_intrinsic_fraction (se, expr);
5252       break;
5253
5254     case GFC_ISYM_IAND:
5255       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
5256       break;
5257
5258     case GFC_ISYM_IBCLR:
5259       gfc_conv_intrinsic_singlebitop (se, expr, 0);
5260       break;
5261
5262     case GFC_ISYM_IBITS:
5263       gfc_conv_intrinsic_ibits (se, expr);
5264       break;
5265
5266     case GFC_ISYM_IBSET:
5267       gfc_conv_intrinsic_singlebitop (se, expr, 1);
5268       break;
5269
5270     case GFC_ISYM_IACHAR:
5271     case GFC_ISYM_ICHAR:
5272       /* We assume ASCII character sequence.  */
5273       gfc_conv_intrinsic_ichar (se, expr);
5274       break;
5275
5276     case GFC_ISYM_IARGC:
5277       gfc_conv_intrinsic_iargc (se, expr);
5278       break;
5279
5280     case GFC_ISYM_IEOR:
5281       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5282       break;
5283
5284     case GFC_ISYM_INDEX:
5285       kind = expr->value.function.actual->expr->ts.kind;
5286       if (kind == 1)
5287        fndecl = gfor_fndecl_string_index;
5288       else if (kind == 4)
5289        fndecl = gfor_fndecl_string_index_char4;
5290       else
5291        gcc_unreachable ();
5292
5293       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
5294       break;
5295
5296     case GFC_ISYM_IOR:
5297       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5298       break;
5299
5300     case GFC_ISYM_IS_IOSTAT_END:
5301       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
5302       break;
5303
5304     case GFC_ISYM_IS_IOSTAT_EOR:
5305       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
5306       break;
5307
5308     case GFC_ISYM_ISNAN:
5309       gfc_conv_intrinsic_isnan (se, expr);
5310       break;
5311
5312     case GFC_ISYM_LSHIFT:
5313       gfc_conv_intrinsic_rlshift (se, expr, 0);
5314       break;
5315
5316     case GFC_ISYM_RSHIFT:
5317       gfc_conv_intrinsic_rlshift (se, expr, 1);
5318       break;
5319
5320     case GFC_ISYM_ISHFT:
5321       gfc_conv_intrinsic_ishft (se, expr);
5322       break;
5323
5324     case GFC_ISYM_ISHFTC:
5325       gfc_conv_intrinsic_ishftc (se, expr);
5326       break;
5327
5328     case GFC_ISYM_LEADZ:
5329       gfc_conv_intrinsic_leadz (se, expr);
5330       break;
5331
5332     case GFC_ISYM_TRAILZ:
5333       gfc_conv_intrinsic_trailz (se, expr);
5334       break;
5335
5336     case GFC_ISYM_LBOUND:
5337       gfc_conv_intrinsic_bound (se, expr, 0);
5338       break;
5339
5340     case GFC_ISYM_TRANSPOSE:
5341       if (se->ss && se->ss->useflags)
5342         {
5343           gfc_conv_tmp_array_ref (se);
5344           gfc_advance_se_ss_chain (se);
5345         }
5346       else
5347         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
5348       break;
5349
5350     case GFC_ISYM_LEN:
5351       gfc_conv_intrinsic_len (se, expr);
5352       break;
5353
5354     case GFC_ISYM_LEN_TRIM:
5355       gfc_conv_intrinsic_len_trim (se, expr);
5356       break;
5357
5358     case GFC_ISYM_LGE:
5359       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
5360       break;
5361
5362     case GFC_ISYM_LGT:
5363       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
5364       break;
5365
5366     case GFC_ISYM_LLE:
5367       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
5368       break;
5369
5370     case GFC_ISYM_LLT:
5371       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
5372       break;
5373
5374     case GFC_ISYM_MAX:
5375       if (expr->ts.type == BT_CHARACTER)
5376         gfc_conv_intrinsic_minmax_char (se, expr, 1);
5377       else
5378         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
5379       break;
5380
5381     case GFC_ISYM_MAXLOC:
5382       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
5383       break;
5384
5385     case GFC_ISYM_MAXVAL:
5386       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
5387       break;
5388
5389     case GFC_ISYM_MERGE:
5390       gfc_conv_intrinsic_merge (se, expr);
5391       break;
5392
5393     case GFC_ISYM_MIN:
5394       if (expr->ts.type == BT_CHARACTER)
5395         gfc_conv_intrinsic_minmax_char (se, expr, -1);
5396       else
5397         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
5398       break;
5399
5400     case GFC_ISYM_MINLOC:
5401       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
5402       break;
5403
5404     case GFC_ISYM_MINVAL:
5405       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
5406       break;
5407
5408     case GFC_ISYM_NEAREST:
5409       gfc_conv_intrinsic_nearest (se, expr);
5410       break;
5411
5412     case GFC_ISYM_NOT:
5413       gfc_conv_intrinsic_not (se, expr);
5414       break;
5415
5416     case GFC_ISYM_OR:
5417       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
5418       break;
5419
5420     case GFC_ISYM_PRESENT:
5421       gfc_conv_intrinsic_present (se, expr);
5422       break;
5423
5424     case GFC_ISYM_PRODUCT:
5425       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
5426       break;
5427
5428     case GFC_ISYM_RRSPACING:
5429       gfc_conv_intrinsic_rrspacing (se, expr);
5430       break;
5431
5432     case GFC_ISYM_SET_EXPONENT:
5433       gfc_conv_intrinsic_set_exponent (se, expr);
5434       break;
5435
5436     case GFC_ISYM_SCALE:
5437       gfc_conv_intrinsic_scale (se, expr);
5438       break;
5439
5440     case GFC_ISYM_SIGN:
5441       gfc_conv_intrinsic_sign (se, expr);
5442       break;
5443
5444     case GFC_ISYM_SIZE:
5445       gfc_conv_intrinsic_size (se, expr);
5446       break;
5447
5448     case GFC_ISYM_SIZEOF:
5449       gfc_conv_intrinsic_sizeof (se, expr);
5450       break;
5451
5452     case GFC_ISYM_SPACING:
5453       gfc_conv_intrinsic_spacing (se, expr);
5454       break;
5455
5456     case GFC_ISYM_SUM:
5457       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
5458       break;
5459
5460     case GFC_ISYM_TRANSFER:
5461       if (se->ss && se->ss->useflags)
5462         {
5463           /* Access the previously obtained result.  */
5464           gfc_conv_tmp_array_ref (se);
5465           gfc_advance_se_ss_chain (se);
5466         }
5467       else
5468         gfc_conv_intrinsic_transfer (se, expr);
5469       break;
5470
5471     case GFC_ISYM_TTYNAM:
5472       gfc_conv_intrinsic_ttynam (se, expr);
5473       break;
5474
5475     case GFC_ISYM_UBOUND:
5476       gfc_conv_intrinsic_bound (se, expr, 1);
5477       break;
5478
5479     case GFC_ISYM_XOR:
5480       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
5481       break;
5482
5483     case GFC_ISYM_LOC:
5484       gfc_conv_intrinsic_loc (se, expr);
5485       break;
5486
5487     case GFC_ISYM_ACCESS:
5488     case GFC_ISYM_CHDIR:
5489     case GFC_ISYM_CHMOD:
5490     case GFC_ISYM_DTIME:
5491     case GFC_ISYM_ETIME:
5492     case GFC_ISYM_EXTENDS_TYPE_OF:
5493     case GFC_ISYM_FGET:
5494     case GFC_ISYM_FGETC:
5495     case GFC_ISYM_FNUM:
5496     case GFC_ISYM_FPUT:
5497     case GFC_ISYM_FPUTC:
5498     case GFC_ISYM_FSTAT:
5499     case GFC_ISYM_FTELL:
5500     case GFC_ISYM_GETCWD:
5501     case GFC_ISYM_GETGID:
5502     case GFC_ISYM_GETPID:
5503     case GFC_ISYM_GETUID:
5504     case GFC_ISYM_HOSTNM:
5505     case GFC_ISYM_KILL:
5506     case GFC_ISYM_IERRNO:
5507     case GFC_ISYM_IRAND:
5508     case GFC_ISYM_ISATTY:
5509     case GFC_ISYM_LINK:
5510     case GFC_ISYM_LSTAT:
5511     case GFC_ISYM_MALLOC:
5512     case GFC_ISYM_MATMUL:
5513     case GFC_ISYM_MCLOCK:
5514     case GFC_ISYM_MCLOCK8:
5515     case GFC_ISYM_RAND:
5516     case GFC_ISYM_RENAME:
5517     case GFC_ISYM_SECOND:
5518     case GFC_ISYM_SECNDS:
5519     case GFC_ISYM_SIGNAL:
5520     case GFC_ISYM_STAT:
5521     case GFC_ISYM_SYMLNK:
5522     case GFC_ISYM_SYSTEM:
5523     case GFC_ISYM_TIME:
5524     case GFC_ISYM_TIME8:
5525     case GFC_ISYM_UMASK:
5526     case GFC_ISYM_UNLINK:
5527       gfc_conv_intrinsic_funcall (se, expr);
5528       break;
5529
5530     case GFC_ISYM_EOSHIFT:
5531     case GFC_ISYM_PACK:
5532     case GFC_ISYM_RESHAPE:
5533       /* For those, expr->rank should always be >0 and thus the if above the
5534          switch should have matched.  */
5535       gcc_unreachable ();
5536       break;
5537
5538     default:
5539       gfc_conv_intrinsic_lib_function (se, expr);
5540       break;
5541     }
5542 }
5543
5544
5545 /* This generates code to execute before entering the scalarization loop.
5546    Currently does nothing.  */
5547
5548 void
5549 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
5550 {
5551   switch (ss->expr->value.function.isym->id)
5552     {
5553     case GFC_ISYM_UBOUND:
5554     case GFC_ISYM_LBOUND:
5555       break;
5556
5557     default:
5558       gcc_unreachable ();
5559     }
5560 }
5561
5562
5563 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
5564    inside the scalarization loop.  */
5565
5566 static gfc_ss *
5567 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
5568 {
5569   gfc_ss *newss;
5570
5571   /* The two argument version returns a scalar.  */
5572   if (expr->value.function.actual->next->expr)
5573     return ss;
5574
5575   newss = gfc_get_ss ();
5576   newss->type = GFC_SS_INTRINSIC;
5577   newss->expr = expr;
5578   newss->next = ss;
5579   newss->data.info.dimen = 1;
5580
5581   return newss;
5582 }
5583
5584
5585 /* Walk an intrinsic array libcall.  */
5586
5587 static gfc_ss *
5588 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
5589 {
5590   gfc_ss *newss;
5591
5592   gcc_assert (expr->rank > 0);
5593
5594   newss = gfc_get_ss ();
5595   newss->type = GFC_SS_FUNCTION;
5596   newss->expr = expr;
5597   newss->next = ss;
5598   newss->data.info.dimen = expr->rank;
5599
5600   return newss;
5601 }
5602
5603
5604 /* Returns nonzero if the specified intrinsic function call maps directly to
5605    an external library call.  Should only be used for functions that return
5606    arrays.  */
5607
5608 int
5609 gfc_is_intrinsic_libcall (gfc_expr * expr)
5610 {
5611   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5612   gcc_assert (expr->rank > 0);
5613
5614   switch (expr->value.function.isym->id)
5615     {
5616     case GFC_ISYM_ALL:
5617     case GFC_ISYM_ANY:
5618     case GFC_ISYM_COUNT:
5619     case GFC_ISYM_MATMUL:
5620     case GFC_ISYM_MAXLOC:
5621     case GFC_ISYM_MAXVAL:
5622     case GFC_ISYM_MINLOC:
5623     case GFC_ISYM_MINVAL:
5624     case GFC_ISYM_PRODUCT:
5625     case GFC_ISYM_SUM:
5626     case GFC_ISYM_SHAPE:
5627     case GFC_ISYM_SPREAD:
5628     case GFC_ISYM_TRANSPOSE:
5629       /* Ignore absent optional parameters.  */
5630       return 1;
5631
5632     case GFC_ISYM_RESHAPE:
5633     case GFC_ISYM_CSHIFT:
5634     case GFC_ISYM_EOSHIFT:
5635     case GFC_ISYM_PACK:
5636     case GFC_ISYM_UNPACK:
5637       /* Pass absent optional parameters.  */
5638       return 2;
5639
5640     default:
5641       return 0;
5642     }
5643 }
5644
5645 /* Walk an intrinsic function.  */
5646 gfc_ss *
5647 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5648                              gfc_intrinsic_sym * isym)
5649 {
5650   gcc_assert (isym);
5651
5652   if (isym->elemental)
5653     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5654
5655   if (expr->rank == 0)
5656     return ss;
5657
5658   if (gfc_is_intrinsic_libcall (expr))
5659     return gfc_walk_intrinsic_libfunc (ss, expr);
5660
5661   /* Special cases.  */
5662   switch (isym->id)
5663     {
5664     case GFC_ISYM_LBOUND:
5665     case GFC_ISYM_UBOUND:
5666       return gfc_walk_intrinsic_bound (ss, expr);
5667
5668     case GFC_ISYM_TRANSFER:
5669       return gfc_walk_intrinsic_libfunc (ss, expr);
5670
5671     default:
5672       /* This probably meant someone forgot to add an intrinsic to the above
5673          list(s) when they implemented it, or something's gone horribly
5674          wrong.  */
5675       gcc_unreachable ();
5676     }
5677 }
5678
5679 #include "gt-fortran-trans-intrinsic.h"