gcc/fortran/trans-intrinsic.c

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