gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  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 "tree.h"
  29 #include "ggc.h"
  30 #include "toplev.h"
  31 #include "real.h"
  32 #include "tree-gimple.h"
  33 #include "flags.h"
  34 #include "gfortran.h"
  35 #include "arith.h"
  36 #include "intrinsic.h"
  37 #include "trans.h"
  38 #include "trans-const.h"
  39 #include "trans-types.h"
  40 #include "trans-array.h"
  41 #include "defaults.h"
  42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  43 #include "trans-stmt.h"
  44
  45 /* This maps fortran intrinsic math functions to external library or GCC
  46    builtin functions.  */
  47 typedef struct gfc_intrinsic_map_t      GTY(())
  48 {
  49   /* The explicit enum is required to work around inadequacies in the
  50      garbage collection/gengtype parsing mechanism.  */
  51   enum gfc_generic_isym_id id;
  52
  53   /* Enum value from the "language-independent", aka C-centric, part
  54      of gcc, or END_BUILTINS of no such value set.  */
  55   /* ??? There are now complex variants in builtins.def, though we
  56      don't currently do anything with them.  */
  57   enum built_in_function code4;
  58   enum built_in_function code8;
  59
  60   /* True if the naming pattern is to prepend "c" for complex and
  61      append "f" for kind=4.  False if the naming pattern is to
  62      prepend "_gfortran_" and append "[rc][48]".  */
  63   bool libm_name;
  64
  65   /* True if a complex version of the function exists.  */
  66   bool complex_available;
  67
  68   /* True if the function should be marked const.  */
  69   bool is_constant;
  70
  71   /* The base library name of this function.  */
  72   const char *name;
  73
  74   /* Cache decls created for the various operand types.  */
  75   tree real4_decl;
  76   tree real8_decl;
  77   tree complex4_decl;
  78   tree complex8_decl;
  79 }
  80 gfc_intrinsic_map_t;
  81
  82 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  83    defines complex variants of all of the entries in mathbuiltins.def
  84    except for atan2.  */
  85 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  86   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
  87     HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  88
  89 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
  90   BUILT_IN_FUNCTION (id, name, false)
  91
  92 /* TODO: Use builtin function for complex intrinsics.  */
  93 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
  94   BUILT_IN_FUNCTION (id, name, true)
  95
  96 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  97   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
  98     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
  99
 100 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 101   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
 102     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 103
 104 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 105 {
 106   /* Functions built into gcc itself.  */
 107 #include "mathbuiltins.def"
 108
 109   /* Functions in libm.  */
 110   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 111      pattern for other mathbuiltins.def entries.  At present we have no
 112      optimizations for this in the common sources.  */
 113   LIBM_FUNCTION (SCALE, "scalbn", false),
 114
 115   /* Functions in libgfortran.  */
 116   LIBF_FUNCTION (FRACTION, "fraction", false),
 117   LIBF_FUNCTION (NEAREST, "nearest", false),
 118   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 119
 120   /* End the list.  */
 121   LIBF_FUNCTION (NONE, NULL, false)
 122 };
 123 #undef DEFINE_MATH_BUILTIN
 124 #undef DEFINE_MATH_BUILTIN_C
 125 #undef BUILT_IN_FUNCTION
 126 #undef LIBM_FUNCTION
 127 #undef LIBF_FUNCTION
 128
 129 /* Structure for storing components of a floating number to be used by
 130    elemental functions to manipulate reals.  */
 131 typedef struct
 132 {
 133   tree arg;     /* Variable tree to view convert to integer.  */
 134   tree expn;    /* Variable tree to save exponent.  */
 135   tree frac;    /* Variable tree to save fraction.  */
 136   tree smask;   /* Constant tree of sign's mask.  */
 137   tree emask;   /* Constant tree of exponent's mask.  */
 138   tree fmask;   /* Constant tree of fraction's mask.  */
 139   tree edigits; /* Constant tree of the number of exponent bits.  */
 140   tree fdigits; /* Constant tree of the number of fraction bits.  */
 141   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 142   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 143   tree type;    /* Type tree of arg1.  */
 144   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 145 }
 146 real_compnt_info;
 147
 148
 149 /* Evaluate the arguments to an intrinsic function.  */
 150
 151 static tree
 152 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 153 {
 154   gfc_actual_arglist *actual;
 155   tree args;
 156   gfc_se argse;
 157
 158   args = NULL_TREE;
 159   for (actual = expr->value.function.actual; actual; actual = actual->next)
 160     {
 161       /* Skip ommitted optional arguments.  */
 162       if (!actual->expr)
 163         continue;
 164
 165       /* Evaluate the parameter.  This will substitute scalarized
 166          references automatically.  */
 167       gfc_init_se (&argse, se);
 168
 169       if (actual->expr->ts.type == BT_CHARACTER)
 170         {
 171           gfc_conv_expr (&argse, actual->expr);
 172           gfc_conv_string_parameter (&argse);
 173           args = gfc_chainon_list (args, argse.string_length);
 174         }
 175       else
 176         gfc_conv_expr_val (&argse, actual->expr);
 177
 178       gfc_add_block_to_block (&se->pre, &argse.pre);
 179       gfc_add_block_to_block (&se->post, &argse.post);
 180       args = gfc_chainon_list (args, argse.expr);
 181     }
 182   return args;
 183 }
 184
 185
 186 /* Conversions between different types are output by the frontend as
 187    intrinsic functions.  We implement these directly with inline code.  */
 188
 189 static void
 190 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 191 {
 192   tree type;
 193   tree arg;
 194
 195   /* Evaluate the argument.  */
 196   type = gfc_typenode_for_spec (&expr->ts);
 197   gcc_assert (expr->value.function.actual->expr);
 198   arg = gfc_conv_intrinsic_function_args (se, expr);
 199   arg = TREE_VALUE (arg);
 200
 201   /* Conversion from complex to non-complex involves taking the real
 202      component of the value.  */
 203   if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 204       && expr->ts.type != BT_COMPLEX)
 205     {
 206       tree artype;
 207
 208       artype = TREE_TYPE (TREE_TYPE (arg));
 209       arg = build1 (REALPART_EXPR, artype, arg);
 210     }
 211
 212   se->expr = convert (type, arg);
 213 }
 214
 215 /* This is needed because the gcc backend only implements
 216    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 217    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 218    Similarly for CEILING.  */
 219
 220 static tree
 221 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 222 {
 223   tree tmp;
 224   tree cond;
 225   tree argtype;
 226   tree intval;
 227
 228   argtype = TREE_TYPE (arg);
 229   arg = gfc_evaluate_now (arg, pblock);
 230
 231   intval = convert (type, arg);
 232   intval = gfc_evaluate_now (intval, pblock);
 233
 234   tmp = convert (argtype, intval);
 235   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 236
 237   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 238                 convert (type, integer_one_node));
 239   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 240   return tmp;
 241 }
 242
 243
 244 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 245    NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
 246
 247 static tree
 248 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 249 {
 250   tree tmp;
 251   tree cond;
 252   tree neg;
 253   tree pos;
 254   tree argtype;
 255   REAL_VALUE_TYPE r;
 256
 257   argtype = TREE_TYPE (arg);
 258   arg = gfc_evaluate_now (arg, pblock);
 259
 260   real_from_string (&r, "0.5");
 261   pos = build_real (argtype, r);
 262
 263   real_from_string (&r, "-0.5");
 264   neg = build_real (argtype, r);
 265
 266   tmp = gfc_build_const (argtype, integer_zero_node);
 267   cond = fold (build2 (GT_EXPR, boolean_type_node, arg, tmp));
 268
 269   tmp = fold (build3 (COND_EXPR, argtype, cond, pos, neg));
 270   tmp = fold (build2 (PLUS_EXPR, argtype, arg, tmp));
 271   return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
 272 }
 273
 274
 275 /* Convert a real to an integer using a specific rounding mode.
 276    Ideally we would just build the corresponding GENERIC node,
 277    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 278
 279 static tree
 280 build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
 281 {
 282   switch (op)
 283     {
 284     case FIX_FLOOR_EXPR:
 285       return build_fixbound_expr (pblock, arg, type, 0);
 286       break;
 287
 288     case FIX_CEIL_EXPR:
 289       return build_fixbound_expr (pblock, arg, type, 1);
 290       break;
 291
 292     case FIX_ROUND_EXPR:
 293       return build_round_expr (pblock, arg, type);
 294
 295     default:
 296       return build1 (op, type, arg);
 297     }
 298 }
 299
 300
 301 /* Round a real value using the specified rounding mode.
 302    We use a temporary integer of that same kind size as the result.
 303    Values larger than can be represented by this kind are unchanged, as
 304    will not be accurate enough to represent the rounding.
 305     huge = HUGE (KIND (a))
 306     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 307    */
 308
 309 static void
 310 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
 311 {
 312   tree type;
 313   tree itype;
 314   tree arg;
 315   tree tmp;
 316   tree cond;
 317   mpfr_t huge;
 318   int n;
 319   int kind;
 320
 321   kind = expr->ts.kind;
 322
 323   n = END_BUILTINS;
 324   /* We have builtin functions for some cases.  */
 325   switch (op)
 326     {
 327     case FIX_ROUND_EXPR:
 328       switch (kind)
 329         {
 330         case 4:
 331           n = BUILT_IN_ROUNDF;
 332           break;
 333
 334         case 8:
 335           n = BUILT_IN_ROUND;
 336           break;
 337         }
 338       break;
 339
 340     case FIX_FLOOR_EXPR:
 341       switch (kind)
 342         {
 343         case 4:
 344           n = BUILT_IN_FLOORF;
 345           break;
 346
 347         case 8:
 348           n = BUILT_IN_FLOOR;
 349           break;
 350         }
 351     }
 352
 353   /* Evaluate the argument.  */
 354   gcc_assert (expr->value.function.actual->expr);
 355   arg = gfc_conv_intrinsic_function_args (se, expr);
 356
 357   /* Use a builtin function if one exists.  */
 358   if (n != END_BUILTINS)
 359     {
 360       tmp = built_in_decls[n];
 361       se->expr = gfc_build_function_call (tmp, arg);
 362       return;
 363     }
 364
 365   /* This code is probably redundant, but we'll keep it lying around just
 366      in case.  */
 367   type = gfc_typenode_for_spec (&expr->ts);
 368   arg = TREE_VALUE (arg);
 369   arg = gfc_evaluate_now (arg, &se->pre);
 370
 371   /* Test if the value is too large to handle sensibly.  */
 372   gfc_set_model_kind (kind);
 373   mpfr_init (huge);
 374   n = gfc_validate_kind (BT_INTEGER, kind, false);
 375   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 376   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 377   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
 378
 379   mpfr_neg (huge, huge, GFC_RND_MODE);
 380   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 381   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
 382   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 383   itype = gfc_get_int_type (kind);
 384
 385   tmp = build_fix_expr (&se->pre, arg, itype, op);
 386   tmp = convert (type, tmp);
 387   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
 388   mpfr_clear (huge);
 389 }
 390
 391
 392 /* Convert to an integer using the specified rounding mode.  */
 393
 394 static void
 395 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
 396 {
 397   tree type;
 398   tree arg;
 399
 400   /* Evaluate the argument.  */
 401   type = gfc_typenode_for_spec (&expr->ts);
 402   gcc_assert (expr->value.function.actual->expr);
 403   arg = gfc_conv_intrinsic_function_args (se, expr);
 404   arg = TREE_VALUE (arg);
 405
 406   if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
 407     {
 408       /* Conversion to a different integer kind.  */
 409       se->expr = convert (type, arg);
 410     }
 411   else
 412     {
 413       /* Conversion from complex to non-complex involves taking the real
 414          component of the value.  */
 415       if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 416           && expr->ts.type != BT_COMPLEX)
 417         {
 418           tree artype;
 419
 420           artype = TREE_TYPE (TREE_TYPE (arg));
 421           arg = build1 (REALPART_EXPR, artype, arg);
 422         }
 423
 424       se->expr = build_fix_expr (&se->pre, arg, type, op);
 425     }
 426 }
 427
 428
 429 /* Get the imaginary component of a value.  */
 430
 431 static void
 432 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 433 {
 434   tree arg;
 435
 436   arg = gfc_conv_intrinsic_function_args (se, expr);
 437   arg = TREE_VALUE (arg);
 438   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 439 }
 440
 441
 442 /* Get the complex conjugate of a value.  */
 443
 444 static void
 445 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 446 {
 447   tree arg;
 448
 449   arg = gfc_conv_intrinsic_function_args (se, expr);
 450   arg = TREE_VALUE (arg);
 451   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 452 }
 453
 454
 455 /* Initialize function decls for library functions.  The external functions
 456    are created as required.  Builtin functions are added here.  */
 457
 458 void
 459 gfc_build_intrinsic_lib_fndecls (void)
 460 {
 461   gfc_intrinsic_map_t *m;
 462
 463   /* Add GCC builtin functions.  */
 464   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 465     {
 466       if (m->code4 != END_BUILTINS)
 467         m->real4_decl = built_in_decls[m->code4];
 468       if (m->code8 != END_BUILTINS)
 469         m->real8_decl = built_in_decls[m->code8];
 470     }
 471 }
 472
 473
 474 /* Create a fndecl for a simple intrinsic library function.  */
 475
 476 static tree
 477 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 478 {
 479   tree type;
 480   tree argtypes;
 481   tree fndecl;
 482   gfc_actual_arglist *actual;
 483   tree *pdecl;
 484   gfc_typespec *ts;
 485   char name[GFC_MAX_SYMBOL_LEN + 3];
 486
 487   ts = &expr->ts;
 488   if (ts->type == BT_REAL)
 489     {
 490       switch (ts->kind)
 491         {
 492         case 4:
 493           pdecl = &m->real4_decl;
 494           break;
 495         case 8:
 496           pdecl = &m->real8_decl;
 497           break;
 498         default:
 499           gcc_unreachable ();
 500         }
 501     }
 502   else if (ts->type == BT_COMPLEX)
 503     {
 504       gcc_assert (m->complex_available);
 505
 506       switch (ts->kind)
 507         {
 508         case 4:
 509           pdecl = &m->complex4_decl;
 510           break;
 511         case 8:
 512           pdecl = &m->complex8_decl;
 513           break;
 514         default:
 515           gcc_unreachable ();
 516         }
 517     }
 518   else
 519     gcc_unreachable ();
 520
 521   if (*pdecl)
 522     return *pdecl;
 523
 524   if (m->libm_name)
 525     {
 526       gcc_assert (ts->kind == 4 || ts->kind == 8);
 527       snprintf (name, sizeof (name), "%s%s%s",
 528                 ts->type == BT_COMPLEX ? "c" : "",
 529                 m->name,
 530                 ts->kind == 4 ? "f" : "");
 531     }
 532   else
 533     {
 534       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 535                 ts->type == BT_COMPLEX ? 'c' : 'r',
 536                 ts->kind);
 537     }
 538
 539   argtypes = NULL_TREE;
 540   for (actual = expr->value.function.actual; actual; actual = actual->next)
 541     {
 542       type = gfc_typenode_for_spec (&actual->expr->ts);
 543       argtypes = gfc_chainon_list (argtypes, type);
 544     }
 545   argtypes = gfc_chainon_list (argtypes, void_type_node);
 546   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 547   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 548
 549   /* Mark the decl as external.  */
 550   DECL_EXTERNAL (fndecl) = 1;
 551   TREE_PUBLIC (fndecl) = 1;
 552
 553   /* Mark it __attribute__((const)), if possible.  */
 554   TREE_READONLY (fndecl) = m->is_constant;
 555
 556   rest_of_decl_compilation (fndecl, 1, 0);
 557
 558   (*pdecl) = fndecl;
 559   return fndecl;
 560 }
 561
 562
 563 /* Convert an intrinsic function into an external or builtin call.  */
 564
 565 static void
 566 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 567 {
 568   gfc_intrinsic_map_t *m;
 569   tree args;
 570   tree fndecl;
 571   gfc_generic_isym_id id;
 572
 573   id = expr->value.function.isym->generic_id;
 574   /* Find the entry for this function.  */
 575   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 576     {
 577       if (id == m->id)
 578         break;
 579     }
 580
 581   if (m->id == GFC_ISYM_NONE)
 582     {
 583       internal_error ("Intrinsic function %s(%d) not recognized",
 584                       expr->value.function.name, id);
 585     }
 586
 587   /* Get the decl and generate the call.  */
 588   args = gfc_conv_intrinsic_function_args (se, expr);
 589   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 590   se->expr = gfc_build_function_call (fndecl, args);
 591 }
 592
 593 /* Generate code for EXPONENT(X) intrinsic function.  */
 594
 595 static void
 596 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
 597 {
 598   tree args, fndecl;
 599   gfc_expr *a1;
 600
 601   args = gfc_conv_intrinsic_function_args (se, expr);
 602
 603   a1 = expr->value.function.actual->expr;
 604   switch (a1->ts.kind)
 605     {
 606     case 4:
 607       fndecl = gfor_fndecl_math_exponent4;
 608       break;
 609     case 8:
 610       fndecl = gfor_fndecl_math_exponent8;
 611       break;
 612     default:
 613       gcc_unreachable ();
 614     }
 615
 616   se->expr = gfc_build_function_call (fndecl, args);
 617 }
 618
 619 /* Evaluate a single upper or lower bound.  */
 620 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 621
 622 static void
 623 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 624 {
 625   gfc_actual_arglist *arg;
 626   gfc_actual_arglist *arg2;
 627   tree desc;
 628   tree type;
 629   tree bound;
 630   tree tmp;
 631   tree cond;
 632   gfc_se argse;
 633   gfc_ss *ss;
 634   int i;
 635
 636   gfc_init_se (&argse, NULL);
 637   arg = expr->value.function.actual;
 638   arg2 = arg->next;
 639
 640   if (se->ss)
 641     {
 642       /* Create an implicit second parameter from the loop variable.  */
 643       gcc_assert (!arg2->expr);
 644       gcc_assert (se->loop->dimen == 1);
 645       gcc_assert (se->ss->expr == expr);
 646       gfc_advance_se_ss_chain (se);
 647       bound = se->loop->loopvar[0];
 648       bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
 649                             se->loop->from[0]));
 650     }
 651   else
 652     {
 653       /* use the passed argument.  */
 654       gcc_assert (arg->next->expr);
 655       gfc_init_se (&argse, NULL);
 656       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 657       gfc_add_block_to_block (&se->pre, &argse.pre);
 658       bound = argse.expr;
 659       /* Convert from one based to zero based.  */
 660       bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
 661                             gfc_index_one_node));
 662     }
 663
 664   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 665   /* Get a descriptor for the first parameter.  */
 666   ss = gfc_walk_expr (arg->expr);
 667   gcc_assert (ss != gfc_ss_terminator);
 668   argse.want_pointer = 0;
 669   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 670   gfc_add_block_to_block (&se->pre, &argse.pre);
 671   gfc_add_block_to_block (&se->post, &argse.post);
 672
 673   desc = argse.expr;
 674
 675   if (INTEGER_CST_P (bound))
 676     {
 677       gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
 678       i = TREE_INT_CST_LOW (bound);
 679       gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
 680     }
 681   else
 682     {
 683       if (flag_bounds_check)
 684         {
 685           bound = gfc_evaluate_now (bound, &se->pre);
 686           cond = fold (build2 (LT_EXPR, boolean_type_node,
 687                                bound, convert (TREE_TYPE (bound),
 688                                                integer_zero_node)));
 689           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 690           tmp = fold (build2 (GE_EXPR, boolean_type_node, bound, tmp));
 691           cond = fold(build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
 692           gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
 693         }
 694     }
 695
 696   if (upper)
 697     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 698   else
 699     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 700
 701   type = gfc_typenode_for_spec (&expr->ts);
 702   se->expr = convert (type, se->expr);
 703 }
 704
 705
 706 static void
 707 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 708 {
 709   tree args;
 710   tree val;
 711   int n;
 712
 713   args = gfc_conv_intrinsic_function_args (se, expr);
 714   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
 715   val = TREE_VALUE (args);
 716
 717   switch (expr->value.function.actual->expr->ts.type)
 718     {
 719     case BT_INTEGER:
 720     case BT_REAL:
 721       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 722       break;
 723
 724     case BT_COMPLEX:
 725       switch (expr->ts.kind)
 726         {
 727         case 4:
 728           n = BUILT_IN_CABSF;
 729           break;
 730         case 8:
 731           n = BUILT_IN_CABS;
 732           break;
 733         default:
 734           gcc_unreachable ();
 735         }
 736       se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
 737       break;
 738
 739     default:
 740       gcc_unreachable ();
 741     }
 742 }
 743
 744
 745 /* Create a complex value from one or two real components.  */
 746
 747 static void
 748 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 749 {
 750   tree arg;
 751   tree real;
 752   tree imag;
 753   tree type;
 754
 755   type = gfc_typenode_for_spec (&expr->ts);
 756   arg = gfc_conv_intrinsic_function_args (se, expr);
 757   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 758   if (both)
 759     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 760   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 761     {
 762       arg = TREE_VALUE (arg);
 763       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 764       imag = convert (TREE_TYPE (type), imag);
 765     }
 766   else
 767     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 768
 769   se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
 770 }
 771
 772 /* Remainder function MOD(A, P) = A - INT(A / P) * P
 773                       MODULO(A, P) = A - FLOOR (A / P) * P  */
 774 /* TODO: MOD(x, 0)  */
 775
 776 static void
 777 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 778 {
 779   tree arg;
 780   tree arg2;
 781   tree type;
 782   tree itype;
 783   tree tmp;
 784   tree test;
 785   tree test2;
 786   mpfr_t huge;
 787   int n;
 788
 789   arg = gfc_conv_intrinsic_function_args (se, expr);
 790   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 791   arg = TREE_VALUE (arg);
 792   type = TREE_TYPE (arg);
 793
 794   switch (expr->ts.type)
 795     {
 796     case BT_INTEGER:
 797       /* Integer case is easy, we've got a builtin op.  */
 798       if (modulo)
 799        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
 800       else
 801        se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
 802       break;
 803
 804     case BT_REAL:
 805       /* Real values we have to do the hard way.  */
 806       arg = gfc_evaluate_now (arg, &se->pre);
 807       arg2 = gfc_evaluate_now (arg2, &se->pre);
 808
 809       tmp = build2 (RDIV_EXPR, type, arg, arg2);
 810       /* Test if the value is too large to handle sensibly.  */
 811       gfc_set_model_kind (expr->ts.kind);
 812       mpfr_init (huge);
 813       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
 814       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 815       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 816       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 817
 818       mpfr_neg (huge, huge, GFC_RND_MODE);
 819       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 820       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 821       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 822
 823       itype = gfc_get_int_type (expr->ts.kind);
 824       if (modulo)
 825        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
 826       else
 827        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 828       tmp = convert (type, tmp);
 829       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 830       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 831       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 832       mpfr_clear (huge);
 833       break;
 834
 835     default:
 836       gcc_unreachable ();
 837     }
 838 }
 839
 840 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 841
 842 static void
 843 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 844 {
 845   tree arg;
 846   tree arg2;
 847   tree val;
 848   tree tmp;
 849   tree type;
 850   tree zero;
 851
 852   arg = gfc_conv_intrinsic_function_args (se, expr);
 853   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 854   arg = TREE_VALUE (arg);
 855   type = TREE_TYPE (arg);
 856
 857   val = build2 (MINUS_EXPR, type, arg, arg2);
 858   val = gfc_evaluate_now (val, &se->pre);
 859
 860   zero = gfc_build_const (type, integer_zero_node);
 861   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 862   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 863 }
 864
 865
 866 /* SIGN(A, B) is absolute value of A times sign of B.
 867    The real value versions use library functions to ensure the correct
 868    handling of negative zero.  Integer case implemented as:
 869    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 870   */
 871
 872 static void
 873 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 874 {
 875   tree tmp;
 876   tree arg;
 877   tree arg2;
 878   tree type;
 879   tree zero;
 880   tree testa;
 881   tree testb;
 882
 883
 884   arg = gfc_conv_intrinsic_function_args (se, expr);
 885   if (expr->ts.type == BT_REAL)
 886     {
 887       switch (expr->ts.kind)
 888         {
 889         case 4:
 890           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 891           break;
 892         case 8:
 893           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 894           break;
 895         default:
 896           gcc_unreachable ();
 897         }
 898       se->expr = fold (gfc_build_function_call (tmp, arg));
 899       return;
 900     }
 901
 902   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 903   arg = TREE_VALUE (arg);
 904   type = TREE_TYPE (arg);
 905   zero = gfc_build_const (type, integer_zero_node);
 906
 907   testa = fold (build2 (GE_EXPR, boolean_type_node, arg, zero));
 908   testb = fold (build2 (GE_EXPR, boolean_type_node, arg2, zero));
 909   tmp = fold (build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
 910   se->expr = fold (build3 (COND_EXPR, type, tmp,
 911                            build1 (NEGATE_EXPR, type, arg), arg));
 912 }
 913
 914
 915 /* Test for the presence of an optional argument.  */
 916
 917 static void
 918 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 919 {
 920   gfc_expr *arg;
 921
 922   arg = expr->value.function.actual->expr;
 923   gcc_assert (arg->expr_type == EXPR_VARIABLE);
 924   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
 925   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 926 }
 927
 928
 929 /* Calculate the double precision product of two single precision values.  */
 930
 931 static void
 932 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 933 {
 934   tree arg;
 935   tree arg2;
 936   tree type;
 937
 938   arg = gfc_conv_intrinsic_function_args (se, expr);
 939   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 940   arg = TREE_VALUE (arg);
 941
 942   /* Convert the args to double precision before multiplying.  */
 943   type = gfc_typenode_for_spec (&expr->ts);
 944   arg = convert (type, arg);
 945   arg2 = convert (type, arg2);
 946   se->expr = build2 (MULT_EXPR, type, arg, arg2);
 947 }
 948
 949
 950 /* Return a length one character string containing an ascii character.  */
 951
 952 static void
 953 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 954 {
 955   tree arg;
 956   tree var;
 957   tree type;
 958
 959   arg = gfc_conv_intrinsic_function_args (se, expr);
 960   arg = TREE_VALUE (arg);
 961
 962   /* We currently don't support character types != 1.  */
 963   gcc_assert (expr->ts.kind == 1);
 964   type = gfc_character1_type_node;
 965   var = gfc_create_var (type, "char");
 966
 967   arg = convert (type, arg);
 968   gfc_add_modify_expr (&se->pre, var, arg);
 969   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
 970   se->string_length = integer_one_node;
 971 }
 972
 973
 974 /* Get the minimum/maximum value of all the parameters.
 975     minmax (a1, a2, a3, ...)
 976     {
 977       if (a2 .op. a1)
 978         mvar = a2;
 979       else
 980         mvar = a1;
 981       if (a3 .op. mvar)
 982         mvar = a3;
 983       ...
 984       return mvar
 985     }
 986  */
 987
 988 /* TODO: Mismatching types can occur when specific names are used.
 989    These should be handled during resolution.  */
 990 static void
 991 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 992 {
 993   tree limit;
 994   tree tmp;
 995   tree mvar;
 996   tree val;
 997   tree thencase;
 998   tree elsecase;
 999   tree arg;
1000   tree type;
1001
1002   arg = gfc_conv_intrinsic_function_args (se, expr);
1003   type = gfc_typenode_for_spec (&expr->ts);
1004
1005   limit = TREE_VALUE (arg);
1006   if (TREE_TYPE (limit) != type)
1007     limit = convert (type, limit);
1008   /* Only evaluate the argument once.  */
1009   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1010     limit = gfc_evaluate_now(limit, &se->pre);
1011
1012   mvar = gfc_create_var (type, "M");
1013   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1014   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1015     {
1016       val = TREE_VALUE (arg);
1017       if (TREE_TYPE (val) != type)
1018         val = convert (type, val);
1019
1020       /* Only evaluate the argument once.  */
1021       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1022         val = gfc_evaluate_now(val, &se->pre);
1023
1024       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1025
1026       tmp = build2 (op, boolean_type_node, val, limit);
1027       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1028       gfc_add_expr_to_block (&se->pre, tmp);
1029       elsecase = build_empty_stmt ();
1030       limit = mvar;
1031     }
1032   se->expr = mvar;
1033 }
1034
1035
1036 /* Create a symbol node for this intrinsic.  The symbol form the frontend
1037    is for the generic name.  */
1038
1039 static gfc_symbol *
1040 gfc_get_symbol_for_expr (gfc_expr * expr)
1041 {
1042   gfc_symbol *sym;
1043
1044   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1045   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1046   sym = gfc_new_symbol (expr->value.function.name, NULL);
1047
1048   sym->ts = expr->ts;
1049   sym->attr.external = 1;
1050   sym->attr.function = 1;
1051   sym->attr.always_explicit = 1;
1052   sym->attr.proc = PROC_INTRINSIC;
1053   sym->attr.flavor = FL_PROCEDURE;
1054   sym->result = sym;
1055   if (expr->rank > 0)
1056     {
1057       sym->attr.dimension = 1;
1058       sym->as = gfc_get_array_spec ();
1059       sym->as->type = AS_ASSUMED_SHAPE;
1060       sym->as->rank = expr->rank;
1061     }
1062
1063   /* TODO: proper argument lists for external intrinsics.  */
1064   return sym;
1065 }
1066
1067 /* Generate a call to an external intrinsic function.  */
1068 static void
1069 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1070 {
1071   gfc_symbol *sym;
1072
1073   gcc_assert (!se->ss || se->ss->expr == expr);
1074
1075   if (se->ss)
1076     gcc_assert (expr->rank > 0);
1077   else
1078     gcc_assert (expr->rank == 0);
1079
1080   sym = gfc_get_symbol_for_expr (expr);
1081   gfc_conv_function_call (se, sym, expr->value.function.actual);
1082   gfc_free (sym);
1083 }
1084
1085 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1086    Implemented as
1087     any(a)
1088     {
1089       forall (i=...)
1090         if (a[i] != 0)
1091           return 1
1092       end forall
1093       return 0
1094     }
1095     all(a)
1096     {
1097       forall (i=...)
1098         if (a[i] == 0)
1099           return 0
1100       end forall
1101       return 1
1102     }
1103  */
1104 static void
1105 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1106 {
1107   tree resvar;
1108   stmtblock_t block;
1109   stmtblock_t body;
1110   tree type;
1111   tree tmp;
1112   tree found;
1113   gfc_loopinfo loop;
1114   gfc_actual_arglist *actual;
1115   gfc_ss *arrayss;
1116   gfc_se arrayse;
1117   tree exit_label;
1118
1119   if (se->ss)
1120     {
1121       gfc_conv_intrinsic_funcall (se, expr);
1122       return;
1123     }
1124
1125   actual = expr->value.function.actual;
1126   type = gfc_typenode_for_spec (&expr->ts);
1127   /* Initialize the result.  */
1128   resvar = gfc_create_var (type, "test");
1129   if (op == EQ_EXPR)
1130     tmp = convert (type, boolean_true_node);
1131   else
1132     tmp = convert (type, boolean_false_node);
1133   gfc_add_modify_expr (&se->pre, resvar, tmp);
1134
1135   /* Walk the arguments.  */
1136   arrayss = gfc_walk_expr (actual->expr);
1137   gcc_assert (arrayss != gfc_ss_terminator);
1138
1139   /* Initialize the scalarizer.  */
1140   gfc_init_loopinfo (&loop);
1141   exit_label = gfc_build_label_decl (NULL_TREE);
1142   TREE_USED (exit_label) = 1;
1143   gfc_add_ss_to_loop (&loop, arrayss);
1144
1145   /* Initialize the loop.  */
1146   gfc_conv_ss_startstride (&loop);
1147   gfc_conv_loop_setup (&loop);
1148
1149   gfc_mark_ss_chain_used (arrayss, 1);
1150   /* Generate the loop body.  */
1151   gfc_start_scalarized_body (&loop, &body);
1152
1153   /* If the condition matches then set the return value.  */
1154   gfc_start_block (&block);
1155   if (op == EQ_EXPR)
1156     tmp = convert (type, boolean_false_node);
1157   else
1158     tmp = convert (type, boolean_true_node);
1159   gfc_add_modify_expr (&block, resvar, tmp);
1160
1161   /* And break out of the loop.  */
1162   tmp = build1_v (GOTO_EXPR, exit_label);
1163   gfc_add_expr_to_block (&block, tmp);
1164
1165   found = gfc_finish_block (&block);
1166
1167   /* Check this element.  */
1168   gfc_init_se (&arrayse, NULL);
1169   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1170   arrayse.ss = arrayss;
1171   gfc_conv_expr_val (&arrayse, actual->expr);
1172
1173   gfc_add_block_to_block (&body, &arrayse.pre);
1174   tmp = build2 (op, boolean_type_node, arrayse.expr,
1175                 fold_convert (TREE_TYPE (arrayse.expr),
1176                               integer_zero_node));
1177   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1178   gfc_add_expr_to_block (&body, tmp);
1179   gfc_add_block_to_block (&body, &arrayse.post);
1180
1181   gfc_trans_scalarizing_loops (&loop, &body);
1182
1183   /* Add the exit label.  */
1184   tmp = build1_v (LABEL_EXPR, exit_label);
1185   gfc_add_expr_to_block (&loop.pre, tmp);
1186
1187   gfc_add_block_to_block (&se->pre, &loop.pre);
1188   gfc_add_block_to_block (&se->pre, &loop.post);
1189   gfc_cleanup_loop (&loop);
1190
1191   se->expr = resvar;
1192 }
1193
1194 /* COUNT(A) = Number of true elements in A.  */
1195 static void
1196 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1197 {
1198   tree resvar;
1199   tree type;
1200   stmtblock_t body;
1201   tree tmp;
1202   gfc_loopinfo loop;
1203   gfc_actual_arglist *actual;
1204   gfc_ss *arrayss;
1205   gfc_se arrayse;
1206
1207   if (se->ss)
1208     {
1209       gfc_conv_intrinsic_funcall (se, expr);
1210       return;
1211     }
1212
1213   actual = expr->value.function.actual;
1214
1215   type = gfc_typenode_for_spec (&expr->ts);
1216   /* Initialize the result.  */
1217   resvar = gfc_create_var (type, "count");
1218   gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
1219
1220   /* Walk the arguments.  */
1221   arrayss = gfc_walk_expr (actual->expr);
1222   gcc_assert (arrayss != gfc_ss_terminator);
1223
1224   /* Initialize the scalarizer.  */
1225   gfc_init_loopinfo (&loop);
1226   gfc_add_ss_to_loop (&loop, arrayss);
1227
1228   /* Initialize the loop.  */
1229   gfc_conv_ss_startstride (&loop);
1230   gfc_conv_loop_setup (&loop);
1231
1232   gfc_mark_ss_chain_used (arrayss, 1);
1233   /* Generate the loop body.  */
1234   gfc_start_scalarized_body (&loop, &body);
1235
1236   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1237                 convert (TREE_TYPE (resvar), integer_one_node));
1238   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1239
1240   gfc_init_se (&arrayse, NULL);
1241   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1242   arrayse.ss = arrayss;
1243   gfc_conv_expr_val (&arrayse, actual->expr);
1244   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1245
1246   gfc_add_block_to_block (&body, &arrayse.pre);
1247   gfc_add_expr_to_block (&body, tmp);
1248   gfc_add_block_to_block (&body, &arrayse.post);
1249
1250   gfc_trans_scalarizing_loops (&loop, &body);
1251
1252   gfc_add_block_to_block (&se->pre, &loop.pre);
1253   gfc_add_block_to_block (&se->pre, &loop.post);
1254   gfc_cleanup_loop (&loop);
1255
1256   se->expr = resvar;
1257 }
1258
1259 /* Inline implementation of the sum and product intrinsics.  */
1260 static void
1261 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1262 {
1263   tree resvar;
1264   tree type;
1265   stmtblock_t body;
1266   stmtblock_t block;
1267   tree tmp;
1268   gfc_loopinfo loop;
1269   gfc_actual_arglist *actual;
1270   gfc_ss *arrayss;
1271   gfc_ss *maskss;
1272   gfc_se arrayse;
1273   gfc_se maskse;
1274   gfc_expr *arrayexpr;
1275   gfc_expr *maskexpr;
1276
1277   if (se->ss)
1278     {
1279       gfc_conv_intrinsic_funcall (se, expr);
1280       return;
1281     }
1282
1283   type = gfc_typenode_for_spec (&expr->ts);
1284   /* Initialize the result.  */
1285   resvar = gfc_create_var (type, "val");
1286   if (op == PLUS_EXPR)
1287     tmp = gfc_build_const (type, integer_zero_node);
1288   else
1289     tmp = gfc_build_const (type, integer_one_node);
1290
1291   gfc_add_modify_expr (&se->pre, resvar, tmp);
1292
1293   /* Walk the arguments.  */
1294   actual = expr->value.function.actual;
1295   arrayexpr = actual->expr;
1296   arrayss = gfc_walk_expr (arrayexpr);
1297   gcc_assert (arrayss != gfc_ss_terminator);
1298
1299   actual = actual->next->next;
1300   gcc_assert (actual);
1301   maskexpr = actual->expr;
1302   if (maskexpr)
1303     {
1304       maskss = gfc_walk_expr (maskexpr);
1305       gcc_assert (maskss != gfc_ss_terminator);
1306     }
1307   else
1308     maskss = NULL;
1309
1310   /* Initialize the scalarizer.  */
1311   gfc_init_loopinfo (&loop);
1312   gfc_add_ss_to_loop (&loop, arrayss);
1313   if (maskss)
1314     gfc_add_ss_to_loop (&loop, maskss);
1315
1316   /* Initialize the loop.  */
1317   gfc_conv_ss_startstride (&loop);
1318   gfc_conv_loop_setup (&loop);
1319
1320   gfc_mark_ss_chain_used (arrayss, 1);
1321   if (maskss)
1322     gfc_mark_ss_chain_used (maskss, 1);
1323   /* Generate the loop body.  */
1324   gfc_start_scalarized_body (&loop, &body);
1325
1326   /* If we have a mask, only add this element if the mask is set.  */
1327   if (maskss)
1328     {
1329       gfc_init_se (&maskse, NULL);
1330       gfc_copy_loopinfo_to_se (&maskse, &loop);
1331       maskse.ss = maskss;
1332       gfc_conv_expr_val (&maskse, maskexpr);
1333       gfc_add_block_to_block (&body, &maskse.pre);
1334
1335       gfc_start_block (&block);
1336     }
1337   else
1338     gfc_init_block (&block);
1339
1340   /* Do the actual summation/product.  */
1341   gfc_init_se (&arrayse, NULL);
1342   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1343   arrayse.ss = arrayss;
1344   gfc_conv_expr_val (&arrayse, arrayexpr);
1345   gfc_add_block_to_block (&block, &arrayse.pre);
1346
1347   tmp = build2 (op, type, resvar, arrayse.expr);
1348   gfc_add_modify_expr (&block, resvar, tmp);
1349   gfc_add_block_to_block (&block, &arrayse.post);
1350
1351   if (maskss)
1352     {
1353       /* We enclose the above in if (mask) {...} .  */
1354       tmp = gfc_finish_block (&block);
1355
1356       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1357     }
1358   else
1359     tmp = gfc_finish_block (&block);
1360   gfc_add_expr_to_block (&body, tmp);
1361
1362   gfc_trans_scalarizing_loops (&loop, &body);
1363   gfc_add_block_to_block (&se->pre, &loop.pre);
1364   gfc_add_block_to_block (&se->pre, &loop.post);
1365   gfc_cleanup_loop (&loop);
1366
1367   se->expr = resvar;
1368 }
1369
1370 static void
1371 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1372 {
1373   stmtblock_t body;
1374   stmtblock_t block;
1375   stmtblock_t ifblock;
1376   tree limit;
1377   tree type;
1378   tree tmp;
1379   tree ifbody;
1380   tree cond;
1381   gfc_loopinfo loop;
1382   gfc_actual_arglist *actual;
1383   gfc_ss *arrayss;
1384   gfc_ss *maskss;
1385   gfc_se arrayse;
1386   gfc_se maskse;
1387   gfc_expr *arrayexpr;
1388   gfc_expr *maskexpr;
1389   tree pos;
1390   int n;
1391
1392   if (se->ss)
1393     {
1394       gfc_conv_intrinsic_funcall (se, expr);
1395       return;
1396     }
1397
1398   /* Initialize the result.  */
1399   pos = gfc_create_var (gfc_array_index_type, "pos");
1400   type = gfc_typenode_for_spec (&expr->ts);
1401
1402   /* Walk the arguments.  */
1403   actual = expr->value.function.actual;
1404   arrayexpr = actual->expr;
1405   arrayss = gfc_walk_expr (arrayexpr);
1406   gcc_assert (arrayss != gfc_ss_terminator);
1407
1408   actual = actual->next->next;
1409   gcc_assert (actual);
1410   maskexpr = actual->expr;
1411   if (maskexpr)
1412     {
1413       maskss = gfc_walk_expr (maskexpr);
1414       gcc_assert (maskss != gfc_ss_terminator);
1415     }
1416   else
1417     maskss = NULL;
1418
1419   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1420   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1421   switch (arrayexpr->ts.type)
1422     {
1423     case BT_REAL:
1424       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1425       break;
1426
1427     case BT_INTEGER:
1428       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1429                                   arrayexpr->ts.kind);
1430       break;
1431
1432     default:
1433       gcc_unreachable ();
1434     }
1435
1436   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1437   if (op == GT_EXPR)
1438     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1439   gfc_add_modify_expr (&se->pre, limit, tmp);
1440
1441   /* Initialize the scalarizer.  */
1442   gfc_init_loopinfo (&loop);
1443   gfc_add_ss_to_loop (&loop, arrayss);
1444   if (maskss)
1445     gfc_add_ss_to_loop (&loop, maskss);
1446
1447   /* Initialize the loop.  */
1448   gfc_conv_ss_startstride (&loop);
1449   gfc_conv_loop_setup (&loop);
1450
1451   gcc_assert (loop.dimen == 1);
1452
1453   /* Initialize the position to the first element.  If the array has zero
1454      size we need to return zero.  Otherwise use the first element of the
1455      array, in case all elements are equal to the limit.
1456      i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1457   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1458                       loop.from[0], gfc_index_one_node));
1459   cond = fold (build2 (GE_EXPR, boolean_type_node,
1460                        loop.to[0], loop.from[0]));
1461   tmp = fold (build3 (COND_EXPR, gfc_array_index_type, cond,
1462                       loop.from[0], tmp));
1463   gfc_add_modify_expr (&loop.pre, pos, tmp);
1464
1465   gfc_mark_ss_chain_used (arrayss, 1);
1466   if (maskss)
1467     gfc_mark_ss_chain_used (maskss, 1);
1468   /* Generate the loop body.  */
1469   gfc_start_scalarized_body (&loop, &body);
1470
1471   /* If we have a mask, only check this element if the mask is set.  */
1472   if (maskss)
1473     {
1474       gfc_init_se (&maskse, NULL);
1475       gfc_copy_loopinfo_to_se (&maskse, &loop);
1476       maskse.ss = maskss;
1477       gfc_conv_expr_val (&maskse, maskexpr);
1478       gfc_add_block_to_block (&body, &maskse.pre);
1479
1480       gfc_start_block (&block);
1481     }
1482   else
1483     gfc_init_block (&block);
1484
1485   /* Compare with the current limit.  */
1486   gfc_init_se (&arrayse, NULL);
1487   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1488   arrayse.ss = arrayss;
1489   gfc_conv_expr_val (&arrayse, arrayexpr);
1490   gfc_add_block_to_block (&block, &arrayse.pre);
1491
1492   /* We do the following if this is a more extreme value.  */
1493   gfc_start_block (&ifblock);
1494
1495   /* Assign the value to the limit...  */
1496   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1497
1498   /* Remember where we are.  */
1499   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1500
1501   ifbody = gfc_finish_block (&ifblock);
1502
1503   /* If it is a more extreme value.  */
1504   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1505   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1506   gfc_add_expr_to_block (&block, tmp);
1507
1508   if (maskss)
1509     {
1510       /* We enclose the above in if (mask) {...}.  */
1511       tmp = gfc_finish_block (&block);
1512
1513       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1514     }
1515   else
1516     tmp = gfc_finish_block (&block);
1517   gfc_add_expr_to_block (&body, tmp);
1518
1519   gfc_trans_scalarizing_loops (&loop, &body);
1520
1521   gfc_add_block_to_block (&se->pre, &loop.pre);
1522   gfc_add_block_to_block (&se->pre, &loop.post);
1523   gfc_cleanup_loop (&loop);
1524
1525   /* Return a value in the range 1..SIZE(array).  */
1526   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1527                       gfc_index_one_node));
1528   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1529   /* And convert to the required type.  */
1530   se->expr = convert (type, tmp);
1531 }
1532
1533 static void
1534 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1535 {
1536   tree limit;
1537   tree type;
1538   tree tmp;
1539   tree ifbody;
1540   stmtblock_t body;
1541   stmtblock_t block;
1542   gfc_loopinfo loop;
1543   gfc_actual_arglist *actual;
1544   gfc_ss *arrayss;
1545   gfc_ss *maskss;
1546   gfc_se arrayse;
1547   gfc_se maskse;
1548   gfc_expr *arrayexpr;
1549   gfc_expr *maskexpr;
1550   int n;
1551
1552   if (se->ss)
1553     {
1554       gfc_conv_intrinsic_funcall (se, expr);
1555       return;
1556     }
1557
1558   type = gfc_typenode_for_spec (&expr->ts);
1559   /* Initialize the result.  */
1560   limit = gfc_create_var (type, "limit");
1561   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1562   switch (expr->ts.type)
1563     {
1564     case BT_REAL:
1565       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1566       break;
1567
1568     case BT_INTEGER:
1569       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1570       break;
1571
1572     default:
1573       gcc_unreachable ();
1574     }
1575
1576   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1577   if (op == GT_EXPR)
1578     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1579   gfc_add_modify_expr (&se->pre, limit, tmp);
1580
1581   /* Walk the arguments.  */
1582   actual = expr->value.function.actual;
1583   arrayexpr = actual->expr;
1584   arrayss = gfc_walk_expr (arrayexpr);
1585   gcc_assert (arrayss != gfc_ss_terminator);
1586
1587   actual = actual->next->next;
1588   gcc_assert (actual);
1589   maskexpr = actual->expr;
1590   if (maskexpr)
1591     {
1592       maskss = gfc_walk_expr (maskexpr);
1593       gcc_assert (maskss != gfc_ss_terminator);
1594     }
1595   else
1596     maskss = NULL;
1597
1598   /* Initialize the scalarizer.  */
1599   gfc_init_loopinfo (&loop);
1600   gfc_add_ss_to_loop (&loop, arrayss);
1601   if (maskss)
1602     gfc_add_ss_to_loop (&loop, maskss);
1603
1604   /* Initialize the loop.  */
1605   gfc_conv_ss_startstride (&loop);
1606   gfc_conv_loop_setup (&loop);
1607
1608   gfc_mark_ss_chain_used (arrayss, 1);
1609   if (maskss)
1610     gfc_mark_ss_chain_used (maskss, 1);
1611   /* Generate the loop body.  */
1612   gfc_start_scalarized_body (&loop, &body);
1613
1614   /* If we have a mask, only add this element if the mask is set.  */
1615   if (maskss)
1616     {
1617       gfc_init_se (&maskse, NULL);
1618       gfc_copy_loopinfo_to_se (&maskse, &loop);
1619       maskse.ss = maskss;
1620       gfc_conv_expr_val (&maskse, maskexpr);
1621       gfc_add_block_to_block (&body, &maskse.pre);
1622
1623       gfc_start_block (&block);
1624     }
1625   else
1626     gfc_init_block (&block);
1627
1628   /* Compare with the current limit.  */
1629   gfc_init_se (&arrayse, NULL);
1630   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1631   arrayse.ss = arrayss;
1632   gfc_conv_expr_val (&arrayse, arrayexpr);
1633   gfc_add_block_to_block (&block, &arrayse.pre);
1634
1635   /* Assign the value to the limit...  */
1636   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1637
1638   /* If it is a more extreme value.  */
1639   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1640   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1641   gfc_add_expr_to_block (&block, tmp);
1642   gfc_add_block_to_block (&block, &arrayse.post);
1643
1644   tmp = gfc_finish_block (&block);
1645   if (maskss)
1646     /* We enclose the above in if (mask) {...}.  */
1647     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1648   gfc_add_expr_to_block (&body, tmp);
1649
1650   gfc_trans_scalarizing_loops (&loop, &body);
1651
1652   gfc_add_block_to_block (&se->pre, &loop.pre);
1653   gfc_add_block_to_block (&se->pre, &loop.post);
1654   gfc_cleanup_loop (&loop);
1655
1656   se->expr = limit;
1657 }
1658
1659 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1660 static void
1661 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1662 {
1663   tree arg;
1664   tree arg2;
1665   tree type;
1666   tree tmp;
1667
1668   arg = gfc_conv_intrinsic_function_args (se, expr);
1669   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1670   arg = TREE_VALUE (arg);
1671   type = TREE_TYPE (arg);
1672
1673   tmp = build2 (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
1674   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1675   tmp = fold (build2 (NE_EXPR, boolean_type_node, tmp,
1676                       convert (type, integer_zero_node)));
1677   type = gfc_typenode_for_spec (&expr->ts);
1678   se->expr = convert (type, tmp);
1679 }
1680
1681 /* Generate code to perform the specified operation.  */
1682 static void
1683 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1684 {
1685   tree arg;
1686   tree arg2;
1687   tree type;
1688
1689   arg = gfc_conv_intrinsic_function_args (se, expr);
1690   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1691   arg = TREE_VALUE (arg);
1692   type = TREE_TYPE (arg);
1693
1694   se->expr = fold (build2 (op, type, arg, arg2));
1695 }
1696
1697 /* Bitwise not.  */
1698 static void
1699 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1700 {
1701   tree arg;
1702
1703   arg = gfc_conv_intrinsic_function_args (se, expr);
1704   arg = TREE_VALUE (arg);
1705
1706   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1707 }
1708
1709 /* Set or clear a single bit.  */
1710 static void
1711 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1712 {
1713   tree arg;
1714   tree arg2;
1715   tree type;
1716   tree tmp;
1717   int op;
1718
1719   arg = gfc_conv_intrinsic_function_args (se, expr);
1720   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1721   arg = TREE_VALUE (arg);
1722   type = TREE_TYPE (arg);
1723
1724   tmp = fold (build2 (LSHIFT_EXPR, type,
1725                      convert (type, integer_one_node), arg2));
1726   if (set)
1727     op = BIT_IOR_EXPR;
1728   else
1729     {
1730       op = BIT_AND_EXPR;
1731       tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1732     }
1733   se->expr = fold (build2 (op, type, arg, tmp));
1734 }
1735
1736 /* Extract a sequence of bits.
1737     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1738 static void
1739 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1740 {
1741   tree arg;
1742   tree arg2;
1743   tree arg3;
1744   tree type;
1745   tree tmp;
1746   tree mask;
1747
1748   arg = gfc_conv_intrinsic_function_args (se, expr);
1749   arg2 = TREE_CHAIN (arg);
1750   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1751   arg = TREE_VALUE (arg);
1752   arg2 = TREE_VALUE (arg2);
1753   type = TREE_TYPE (arg);
1754
1755   mask = build_int_cst (NULL_TREE, -1);
1756   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1757   mask = build1 (BIT_NOT_EXPR, type, mask);
1758
1759   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1760
1761   se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
1762 }
1763
1764 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1765                         ? 0
1766                         : ((shift >= 0) ? i << shift : i >> -shift)
1767    where all shifts are logical shifts.  */
1768 static void
1769 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1770 {
1771   tree arg;
1772   tree arg2;
1773   tree type;
1774   tree utype;
1775   tree tmp;
1776   tree width;
1777   tree num_bits;
1778   tree cond;
1779   tree lshift;
1780   tree rshift;
1781
1782   arg = gfc_conv_intrinsic_function_args (se, expr);
1783   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1784   arg = TREE_VALUE (arg);
1785   type = TREE_TYPE (arg);
1786   utype = gfc_unsigned_type (type);
1787
1788   /* We convert to an unsigned type because we want a logical shift.
1789      The standard doesn't define the case of shifting negative
1790      numbers, and we try to be compatible with other compilers, most
1791      notably g77, here.  */
1792   arg = convert (utype, arg);
1793   width = fold (build1 (ABS_EXPR, TREE_TYPE (arg2), arg2));
1794
1795   /* Left shift if positive.  */
1796   lshift = fold (build2 (LSHIFT_EXPR, type, arg, width));
1797
1798   /* Right shift if negative.  */
1799   rshift = convert (type, fold (build2 (RSHIFT_EXPR, utype, arg, width)));
1800
1801   tmp = fold (build2 (GE_EXPR, boolean_type_node, arg2,
1802                       convert (TREE_TYPE (arg2), integer_zero_node)));
1803   tmp = fold (build3 (COND_EXPR, type, tmp, lshift, rshift));
1804
1805   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1806      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1807      special case.  */
1808   num_bits = convert (TREE_TYPE (arg2),
1809                       build_int_cst (NULL, TYPE_PRECISION (type)));
1810   cond = fold (build2 (GE_EXPR, boolean_type_node, width,
1811                        convert (TREE_TYPE (arg2), num_bits)));
1812
1813   se->expr = fold (build3 (COND_EXPR, type, cond,
1814                            convert (type, integer_zero_node),
1815                            tmp));
1816 }
1817
1818 /* Circular shift.  AKA rotate or barrel shift.  */
1819 static void
1820 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1821 {
1822   tree arg;
1823   tree arg2;
1824   tree arg3;
1825   tree type;
1826   tree tmp;
1827   tree lrot;
1828   tree rrot;
1829
1830   arg = gfc_conv_intrinsic_function_args (se, expr);
1831   arg2 = TREE_CHAIN (arg);
1832   arg3 = TREE_CHAIN (arg2);
1833   if (arg3)
1834     {
1835       /* Use a library function for the 3 parameter version.  */
1836       tree int4type = gfc_get_int_type (4);
1837
1838       type = TREE_TYPE (TREE_VALUE (arg));
1839       /* We convert the first argument to at least 4 bytes, and
1840          convert back afterwards.  This removes the need for library
1841          functions for all argument sizes, and function will be
1842          aligned to at least 32 bits, so there's no loss.  */
1843       if (expr->ts.kind < 4)
1844         {
1845           tmp = convert (int4type, TREE_VALUE (arg));
1846           TREE_VALUE (arg) = tmp;
1847         }
1848       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1849          need loads of library  functions.  They cannot have values >
1850          BIT_SIZE (I) so the conversion is safe.  */
1851       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
1852       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
1853
1854       switch (expr->ts.kind)
1855         {
1856         case 1:
1857         case 2:
1858         case 4:
1859           tmp = gfor_fndecl_math_ishftc4;
1860           break;
1861         case 8:
1862           tmp = gfor_fndecl_math_ishftc8;
1863           break;
1864         default:
1865           gcc_unreachable ();
1866         }
1867       se->expr = gfc_build_function_call (tmp, arg);
1868       /* Convert the result back to the original type, if we extended
1869          the first argument's width above.  */
1870       if (expr->ts.kind < 4)
1871         se->expr = convert (type, se->expr);
1872
1873       return;
1874     }
1875   arg = TREE_VALUE (arg);
1876   arg2 = TREE_VALUE (arg2);
1877   type = TREE_TYPE (arg);
1878
1879   /* Rotate left if positive.  */
1880   lrot = fold (build2 (LROTATE_EXPR, type, arg, arg2));
1881
1882   /* Rotate right if negative.  */
1883   tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2));
1884   rrot = fold (build2 (RROTATE_EXPR, type, arg, tmp));
1885
1886   tmp = fold (build2 (GT_EXPR, boolean_type_node, arg2,
1887                       convert (TREE_TYPE (arg2), integer_zero_node)));
1888   rrot = fold (build3 (COND_EXPR, type, tmp, lrot, rrot));
1889
1890   /* Do nothing if shift == 0.  */
1891   tmp = fold (build2 (EQ_EXPR, boolean_type_node, arg2,
1892                       convert (TREE_TYPE (arg2), integer_zero_node)));
1893   se->expr = fold (build3 (COND_EXPR, type, tmp, arg, rrot));
1894 }
1895
1896 /* The length of a character string.  */
1897 static void
1898 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1899 {
1900   tree len;
1901   tree type;
1902   tree decl;
1903   gfc_symbol *sym;
1904   gfc_se argse;
1905   gfc_expr *arg;
1906
1907   gcc_assert (!se->ss);
1908
1909   arg = expr->value.function.actual->expr;
1910
1911   type = gfc_typenode_for_spec (&expr->ts);
1912   switch (arg->expr_type)
1913     {
1914     case EXPR_CONSTANT:
1915       len = build_int_cst (NULL_TREE, arg->value.character.length);
1916       break;
1917
1918     default:
1919         if (arg->expr_type == EXPR_VARIABLE
1920             && (arg->ref == NULL || (arg->ref->next == NULL
1921                                      && arg->ref->type == REF_ARRAY)))
1922           {
1923             /* This doesn't catch all cases.
1924                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1925                and the surrounding thread.  */
1926             sym = arg->symtree->n.sym;
1927             decl = gfc_get_symbol_decl (sym);
1928             if (decl == current_function_decl && sym->attr.function
1929                 && (sym->result == sym))
1930               decl = gfc_get_fake_result_decl (sym);
1931
1932             len = sym->ts.cl->backend_decl;
1933             gcc_assert (len);
1934           }
1935         else
1936           {
1937             /* Anybody stupid enough to do this deserves inefficient code.  */
1938             gfc_init_se (&argse, se);
1939             gfc_conv_expr (&argse, arg);
1940             gfc_add_block_to_block (&se->pre, &argse.pre);
1941             gfc_add_block_to_block (&se->post, &argse.post);
1942             len = argse.string_length;
1943         }
1944       break;
1945     }
1946   se->expr = convert (type, len);
1947 }
1948
1949 /* The length of a character string not including trailing blanks.  */
1950 static void
1951 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1952 {
1953   tree args;
1954   tree type;
1955
1956   args = gfc_conv_intrinsic_function_args (se, expr);
1957   type = gfc_typenode_for_spec (&expr->ts);
1958   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1959   se->expr = convert (type, se->expr);
1960 }
1961
1962
1963 /* Returns the starting position of a substring within a string.  */
1964
1965 static void
1966 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1967 {
1968   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1969   tree args;
1970   tree back;
1971   tree type;
1972   tree tmp;
1973
1974   args = gfc_conv_intrinsic_function_args (se, expr);
1975   type = gfc_typenode_for_spec (&expr->ts);
1976   tmp = gfc_advance_chain (args, 3);
1977   if (TREE_CHAIN (tmp) == NULL_TREE)
1978     {
1979       back = convert (gfc_logical4_type_node, integer_one_node);
1980       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1981       TREE_CHAIN (tmp) = back;
1982     }
1983   else
1984     {
1985       back = TREE_CHAIN (tmp);
1986       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1987     }
1988
1989   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1990   se->expr = convert (type, se->expr);
1991 }
1992
1993 /* The ascii value for a single character.  */
1994 static void
1995 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1996 {
1997   tree arg;
1998   tree type;
1999
2000   arg = gfc_conv_intrinsic_function_args (se, expr);
2001   arg = TREE_VALUE (TREE_CHAIN (arg));
2002   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2003   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2004   type = gfc_typenode_for_spec (&expr->ts);
2005
2006   se->expr = gfc_build_indirect_ref (arg);
2007   se->expr = convert (type, se->expr);
2008 }
2009
2010
2011 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2012
2013 static void
2014 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2015 {
2016   tree arg;
2017   tree tsource;
2018   tree fsource;
2019   tree mask;
2020   tree type;
2021   tree len;
2022
2023   arg = gfc_conv_intrinsic_function_args (se, expr);
2024   if (expr->ts.type != BT_CHARACTER)
2025     {
2026       tsource = TREE_VALUE (arg);
2027       arg = TREE_CHAIN (arg);
2028       fsource = TREE_VALUE (arg);
2029       mask = TREE_VALUE (TREE_CHAIN (arg));
2030     }
2031   else
2032     {
2033       /* We do the same as in the non-character case, but the argument
2034          list is different because of the string length arguments. We
2035          also have to set the string length for the result.  */
2036       len = TREE_VALUE (arg);
2037       arg = TREE_CHAIN (arg);
2038       tsource = TREE_VALUE (arg);
2039       arg = TREE_CHAIN (TREE_CHAIN (arg));
2040       fsource = TREE_VALUE (arg);
2041       mask = TREE_VALUE (TREE_CHAIN (arg));
2042
2043       se->string_length = len;
2044     }
2045   type = TREE_TYPE (tsource);
2046   se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
2047 }
2048
2049
2050 static void
2051 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2052 {
2053   gfc_actual_arglist *actual;
2054   tree args;
2055   tree type;
2056   tree fndecl;
2057   gfc_se argse;
2058   gfc_ss *ss;
2059
2060   gfc_init_se (&argse, NULL);
2061   actual = expr->value.function.actual;
2062
2063   ss = gfc_walk_expr (actual->expr);
2064   gcc_assert (ss != gfc_ss_terminator);
2065   argse.want_pointer = 1;
2066   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2067   gfc_add_block_to_block (&se->pre, &argse.pre);
2068   gfc_add_block_to_block (&se->post, &argse.post);
2069   args = gfc_chainon_list (NULL_TREE, argse.expr);
2070
2071   actual = actual->next;
2072   if (actual->expr)
2073     {
2074       gfc_init_se (&argse, NULL);
2075       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2076       gfc_add_block_to_block (&se->pre, &argse.pre);
2077       args = gfc_chainon_list (args, argse.expr);
2078       fndecl = gfor_fndecl_size1;
2079     }
2080   else
2081     fndecl = gfor_fndecl_size0;
2082
2083   se->expr = gfc_build_function_call (fndecl, args);
2084   type = gfc_typenode_for_spec (&expr->ts);
2085   se->expr = convert (type, se->expr);
2086 }
2087
2088
2089 /* Intrinsic string comparison functions.  */
2090
2091   static void
2092 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2093 {
2094   tree type;
2095   tree args;
2096
2097   args = gfc_conv_intrinsic_function_args (se, expr);
2098   /* Build a call for the comparison.  */
2099   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2100
2101   type = gfc_typenode_for_spec (&expr->ts);
2102   se->expr = build2 (op, type, se->expr,
2103                      convert (TREE_TYPE (se->expr), integer_zero_node));
2104 }
2105
2106 /* Generate a call to the adjustl/adjustr library function.  */
2107 static void
2108 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2109 {
2110   tree args;
2111   tree len;
2112   tree type;
2113   tree var;
2114   tree tmp;
2115
2116   args = gfc_conv_intrinsic_function_args (se, expr);
2117   len = TREE_VALUE (args);
2118
2119   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2120   var = gfc_conv_string_tmp (se, type, len);
2121   args = tree_cons (NULL_TREE, var, args);
2122
2123   tmp = gfc_build_function_call (fndecl, args);
2124   gfc_add_expr_to_block (&se->pre, tmp);
2125   se->expr = var;
2126   se->string_length = len;
2127 }
2128
2129
2130 /* Scalar transfer statement.
2131    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2132
2133 static void
2134 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2135 {
2136   gfc_actual_arglist *arg;
2137   gfc_se argse;
2138   tree type;
2139   tree ptr;
2140   gfc_ss *ss;
2141
2142   gcc_assert (!se->ss);
2143
2144   /* Get a pointer to the source.  */
2145   arg = expr->value.function.actual;
2146   ss = gfc_walk_expr (arg->expr);
2147   gfc_init_se (&argse, NULL);
2148   if (ss == gfc_ss_terminator)
2149     gfc_conv_expr_reference (&argse, arg->expr);
2150   else
2151     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2152   gfc_add_block_to_block (&se->pre, &argse.pre);
2153   gfc_add_block_to_block (&se->post, &argse.post);
2154   ptr = argse.expr;
2155
2156   arg = arg->next;
2157   type = gfc_typenode_for_spec (&expr->ts);
2158   ptr = convert (build_pointer_type (type), ptr);
2159   if (expr->ts.type == BT_CHARACTER)
2160     {
2161       gfc_init_se (&argse, NULL);
2162       gfc_conv_expr (&argse, arg->expr);
2163       gfc_add_block_to_block (&se->pre, &argse.pre);
2164       gfc_add_block_to_block (&se->post, &argse.post);
2165       se->expr = ptr;
2166       se->string_length = argse.string_length;
2167     }
2168   else
2169     {
2170       se->expr = gfc_build_indirect_ref (ptr);
2171     }
2172 }
2173
2174
2175 /* Generate code for the ALLOCATED intrinsic.
2176    Generate inline code that directly check the address of the argument.  */
2177
2178 static void
2179 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2180 {
2181   gfc_actual_arglist *arg1;
2182   gfc_se arg1se;
2183   gfc_ss *ss1;
2184   tree tmp;
2185
2186   gfc_init_se (&arg1se, NULL);
2187   arg1 = expr->value.function.actual;
2188   ss1 = gfc_walk_expr (arg1->expr);
2189   arg1se.descriptor_only = 1;
2190   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2191
2192   tmp = gfc_conv_descriptor_data (arg1se.expr);
2193   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2194                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2195   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2196 }
2197
2198
2199 /* Generate code for the ASSOCIATED intrinsic.
2200    If both POINTER and TARGET are arrays, generate a call to library function
2201    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2202    In other cases, generate inline code that directly compare the address of
2203    POINTER with the address of TARGET.  */
2204
2205 static void
2206 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2207 {
2208   gfc_actual_arglist *arg1;
2209   gfc_actual_arglist *arg2;
2210   gfc_se arg1se;
2211   gfc_se arg2se;
2212   tree tmp2;
2213   tree tmp;
2214   tree args, fndecl;
2215   gfc_ss *ss1, *ss2;
2216
2217   gfc_init_se (&arg1se, NULL);
2218   gfc_init_se (&arg2se, NULL);
2219   arg1 = expr->value.function.actual;
2220   arg2 = arg1->next;
2221   ss1 = gfc_walk_expr (arg1->expr);
2222
2223   if (!arg2->expr)
2224     {
2225       /* No optional target.  */
2226       if (ss1 == gfc_ss_terminator)
2227         {
2228           /* A pointer to a scalar.  */
2229           arg1se.want_pointer = 1;
2230           gfc_conv_expr (&arg1se, arg1->expr);
2231           tmp2 = arg1se.expr;
2232         }
2233       else
2234         {
2235           /* A pointer to an array.  */
2236           arg1se.descriptor_only = 1;
2237           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2238           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2239         }
2240       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2241                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2242       se->expr = tmp;
2243     }
2244   else
2245     {
2246       /* An optional target.  */
2247       ss2 = gfc_walk_expr (arg2->expr);
2248       if (ss1 == gfc_ss_terminator)
2249         {
2250           /* A pointer to a scalar.  */
2251           gcc_assert (ss2 == gfc_ss_terminator);
2252           arg1se.want_pointer = 1;
2253           gfc_conv_expr (&arg1se, arg1->expr);
2254           arg2se.want_pointer = 1;
2255           gfc_conv_expr (&arg2se, arg2->expr);
2256           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2257           se->expr = tmp;
2258         }
2259       else
2260         {
2261           /* A pointer to an array, call library function _gfor_associated.  */
2262           gcc_assert (ss2 != gfc_ss_terminator);
2263           args = NULL_TREE;
2264           arg1se.want_pointer = 1;
2265           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2266           args = gfc_chainon_list (args, arg1se.expr);
2267           arg2se.want_pointer = 1;
2268           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2269           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2270           gfc_add_block_to_block (&se->post, &arg2se.post);
2271           args = gfc_chainon_list (args, arg2se.expr);
2272           fndecl = gfor_fndecl_associated;
2273           se->expr = gfc_build_function_call (fndecl, args);
2274         }
2275      }
2276   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2277 }
2278
2279
2280 /* Scan a string for any one of the characters in a set of characters.  */
2281
2282 static void
2283 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2284 {
2285   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2286   tree args;
2287   tree back;
2288   tree type;
2289   tree tmp;
2290
2291   args = gfc_conv_intrinsic_function_args (se, expr);
2292   type = gfc_typenode_for_spec (&expr->ts);
2293   tmp = gfc_advance_chain (args, 3);
2294   if (TREE_CHAIN (tmp) == NULL_TREE)
2295     {
2296       back = convert (gfc_logical4_type_node, integer_one_node);
2297       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2298       TREE_CHAIN (tmp) = back;
2299     }
2300   else
2301     {
2302       back = TREE_CHAIN (tmp);
2303       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2304     }
2305
2306   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2307   se->expr = convert (type, se->expr);
2308 }
2309
2310
2311 /* Verify that a set of characters contains all the characters in a string
2312    by identifying the position of the first character in a string of
2313    characters that does not appear in a given set of characters.  */
2314
2315 static void
2316 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2317 {
2318   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2319   tree args;
2320   tree back;
2321   tree type;
2322   tree tmp;
2323
2324   args = gfc_conv_intrinsic_function_args (se, expr);
2325   type = gfc_typenode_for_spec (&expr->ts);
2326   tmp = gfc_advance_chain (args, 3);
2327   if (TREE_CHAIN (tmp) == NULL_TREE)
2328     {
2329       back = convert (gfc_logical4_type_node, integer_one_node);
2330       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2331       TREE_CHAIN (tmp) = back;
2332     }
2333   else
2334     {
2335       back = TREE_CHAIN (tmp);
2336       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2337     }
2338
2339   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2340   se->expr = convert (type, se->expr);
2341 }
2342
2343 /* Prepare components and related information of a real number which is
2344    the first argument of a elemental functions to manipulate reals.  */
2345
2346 static
2347 void prepare_arg_info (gfc_se * se, gfc_expr * expr,
2348                        real_compnt_info * rcs, int all)
2349 {
2350    tree arg;
2351    tree masktype;
2352    tree tmp;
2353    tree wbits;
2354    tree one;
2355    tree exponent, fraction;
2356    int n;
2357    gfc_expr *a1;
2358
2359    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2360      gfc_todo_error ("Non-IEEE floating format");
2361
2362    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2363
2364    arg = gfc_conv_intrinsic_function_args (se, expr);
2365    arg = TREE_VALUE (arg);
2366    rcs->type = TREE_TYPE (arg);
2367
2368    /* Force arg'type to integer by unaffected convert  */
2369    a1 = expr->value.function.actual->expr;
2370    masktype = gfc_get_int_type (a1->ts.kind);
2371    rcs->mtype = masktype;
2372    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2373    arg = gfc_create_var (masktype, "arg");
2374    gfc_add_modify_expr(&se->pre, arg, tmp);
2375    rcs->arg = arg;
2376
2377    /* Caculate the numbers of bits of exponent, fraction and word  */
2378    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2379    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2380    rcs->fdigits = convert (masktype, tmp);
2381    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2382    wbits = convert (masktype, wbits);
2383    rcs->edigits = fold (build2 (MINUS_EXPR, masktype, wbits, tmp));
2384
2385    /* Form masks for exponent/fraction/sign  */
2386    one = gfc_build_const (masktype, integer_one_node);
2387    rcs->smask = fold (build2 (LSHIFT_EXPR, masktype, one, wbits));
2388    rcs->f1 = fold (build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2389    rcs->emask = fold (build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2390    rcs->fmask = fold (build2 (MINUS_EXPR, masktype, rcs->f1, one));
2391    /* Form bias.  */
2392    tmp = fold (build2 (MINUS_EXPR, masktype, rcs->edigits, one));
2393    tmp = fold (build2 (LSHIFT_EXPR, masktype, one, tmp));
2394    rcs->bias = fold (build2 (MINUS_EXPR, masktype, tmp ,one));
2395
2396    if (all)
2397    {
2398      /* exponent, and fraction  */
2399      tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2400      tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2401      exponent = gfc_create_var (masktype, "exponent");
2402      gfc_add_modify_expr(&se->pre, exponent, tmp);
2403      rcs->expn = exponent;
2404
2405      tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2406      fraction = gfc_create_var (masktype, "fraction");
2407      gfc_add_modify_expr(&se->pre, fraction, tmp);
2408      rcs->frac = fraction;
2409   }
2410 }
2411
2412 /* Build a call to __builtin_clz.  */
2413
2414 static tree
2415 call_builtin_clz (tree result_type, tree op0)
2416 {
2417   tree fn, parms, call;
2418   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2419
2420   if (op0_mode == TYPE_MODE (integer_type_node))
2421     fn = built_in_decls[BUILT_IN_CLZ];
2422   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2423     fn = built_in_decls[BUILT_IN_CLZL];
2424   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2425     fn = built_in_decls[BUILT_IN_CLZLL];
2426   else
2427     gcc_unreachable ();
2428
2429   parms = tree_cons (NULL, op0, NULL);
2430   call = gfc_build_function_call (fn, parms);
2431
2432   return convert (result_type, call);
2433 }
2434
2435
2436 /* Generate code for SPACING (X) intrinsic function.
2437    SPACING (X) = POW (2, e-p)
2438
2439    We generate:
2440
2441     t = expn - fdigits // e - p.
2442     res = t << fdigits // Form the exponent. Fraction is zero.
2443     if (t < 0) // The result is out of range. Denormalized case.
2444       res = tiny(X)
2445  */
2446
2447 static void
2448 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2449 {
2450    tree arg;
2451    tree masktype;
2452    tree tmp, t1, cond;
2453    tree tiny, zero;
2454    tree fdigits;
2455    real_compnt_info rcs;
2456
2457    prepare_arg_info (se, expr, &rcs, 0);
2458    arg = rcs.arg;
2459    masktype = rcs.mtype;
2460    fdigits = rcs.fdigits;
2461    tiny = rcs.f1;
2462    zero = gfc_build_const (masktype, integer_zero_node);
2463    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2464    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2465    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2466    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2467    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2468    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2469    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2470
2471    se->expr = tmp;
2472 }
2473
2474 /* Generate code for RRSPACING (X) intrinsic function.
2475    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2476
2477    So the result's exponent is p. And if X is normalized, X's fraction part
2478    is the result's fraction. If X is denormalized, to get the X's fraction we
2479    shift X's fraction part to left until the first '1' is removed.
2480
2481    We generate:
2482
2483     if (expn == 0 && frac == 0)
2484        res = 0;
2485     else
2486     {
2487        // edigits is the number of exponent bits. Add the sign bit.
2488        sedigits = edigits + 1;
2489
2490        if (expn == 0) // Denormalized case.
2491        {
2492          t1 = leadzero (frac);
2493          frac = frac << (t1 + 1); //Remove the first '1'.
2494          frac = frac >> (sedigits); //Form the fraction.
2495        }
2496
2497        //fdigits is the number of fraction bits. Form the exponent.
2498        t = bias + fdigits;
2499
2500        res = (t << fdigits) | frac;
2501     }
2502 */
2503
2504 static void
2505 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2506 {
2507    tree masktype;
2508    tree tmp, t1, t2, cond, cond2;
2509    tree one, zero;
2510    tree fdigits, fraction;
2511    real_compnt_info rcs;
2512
2513    prepare_arg_info (se, expr, &rcs, 1);
2514    masktype = rcs.mtype;
2515    fdigits = rcs.fdigits;
2516    fraction = rcs.frac;
2517    one = gfc_build_const (masktype, integer_one_node);
2518    zero = gfc_build_const (masktype, integer_zero_node);
2519    t2 = fold (build2 (PLUS_EXPR, masktype, rcs.edigits, one));
2520
2521    t1 = call_builtin_clz (masktype, fraction);
2522    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2523    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2524    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2525    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2526    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2527
2528    tmp = fold (build2 (PLUS_EXPR, masktype, rcs.bias, fdigits));
2529    tmp = fold (build2 (LSHIFT_EXPR, masktype, tmp, fdigits));
2530    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2531
2532    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2533    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2534    tmp = build3 (COND_EXPR, masktype, cond,
2535                  convert (masktype, integer_zero_node), tmp);
2536
2537    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2538    se->expr = tmp;
2539 }
2540
2541 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2542
2543 static void
2544 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2545 {
2546   tree args;
2547
2548   args = gfc_conv_intrinsic_function_args (se, expr);
2549   args = TREE_VALUE (args);
2550   args = gfc_build_addr_expr (NULL, args);
2551   args = tree_cons (NULL_TREE, args, NULL_TREE);
2552   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2553 }
2554
2555 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2556
2557 static void
2558 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2559 {
2560   gfc_actual_arglist *actual;
2561   tree args;
2562   gfc_se argse;
2563
2564   args = NULL_TREE;
2565   for (actual = expr->value.function.actual; actual; actual = actual->next)
2566     {
2567       gfc_init_se (&argse, se);
2568
2569       /* Pass a NULL pointer for an absent arg.  */
2570       if (actual->expr == NULL)
2571         argse.expr = null_pointer_node;
2572       else
2573         gfc_conv_expr_reference (&argse, actual->expr);
2574
2575       gfc_add_block_to_block (&se->pre, &argse.pre);
2576       gfc_add_block_to_block (&se->post, &argse.post);
2577       args = gfc_chainon_list (args, argse.expr);
2578     }
2579   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2580 }
2581
2582
2583 /* Generate code for TRIM (A) intrinsic function.  */
2584
2585 static void
2586 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2587 {
2588   tree gfc_int4_type_node = gfc_get_int_type (4);
2589   tree var;
2590   tree len;
2591   tree addr;
2592   tree tmp;
2593   tree arglist;
2594   tree type;
2595   tree cond;
2596
2597   arglist = NULL_TREE;
2598
2599   type = build_pointer_type (gfc_character1_type_node);
2600   var = gfc_create_var (type, "pstr");
2601   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2602   len = gfc_create_var (gfc_int4_type_node, "len");
2603
2604   tmp = gfc_conv_intrinsic_function_args (se, expr);
2605   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2606   arglist = gfc_chainon_list (arglist, addr);
2607   arglist = chainon (arglist, tmp);
2608
2609   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2610   gfc_add_expr_to_block (&se->pre, tmp);
2611
2612   /* Free the temporary afterwards, if necessary.  */
2613   cond = build2 (GT_EXPR, boolean_type_node, len,
2614                  convert (TREE_TYPE (len), integer_zero_node));
2615   arglist = gfc_chainon_list (NULL_TREE, var);
2616   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2617   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2618   gfc_add_expr_to_block (&se->post, tmp);
2619
2620   se->expr = var;
2621   se->string_length = len;
2622 }
2623
2624
2625 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2626
2627 static void
2628 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2629 {
2630   tree gfc_int4_type_node = gfc_get_int_type (4);
2631   tree tmp;
2632   tree len;
2633   tree args;
2634   tree arglist;
2635   tree ncopies;
2636   tree var;
2637   tree type;
2638
2639   args = gfc_conv_intrinsic_function_args (se, expr);
2640   len = TREE_VALUE (args);
2641   tmp = gfc_advance_chain (args, 2);
2642   ncopies = TREE_VALUE (tmp);
2643   len = fold (build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2644   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2645   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2646
2647   arglist = NULL_TREE;
2648   arglist = gfc_chainon_list (arglist, var);
2649   arglist = chainon (arglist, args);
2650   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2651   gfc_add_expr_to_block (&se->pre, tmp);
2652
2653   se->expr = var;
2654   se->string_length = len;
2655 }
2656
2657
2658 /* Generate code for the IARGC intrinsic.  If args_only is true this is
2659    actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1.  */
2660
2661 static void
2662 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
2663 {
2664   tree tmp;
2665   tree fndecl;
2666   tree type;
2667
2668   /* Call the library function.  This always returns an INTEGER(4).  */
2669   fndecl = gfor_fndecl_iargc;
2670   tmp = gfc_build_function_call (fndecl, NULL_TREE);
2671
2672   /* Convert it to the required type.  */
2673   type = gfc_typenode_for_spec (&expr->ts);
2674   tmp = fold_convert (type, tmp);
2675
2676   if (args_only)
2677     tmp = build2 (MINUS_EXPR, type, tmp, convert (type, integer_one_node));
2678   se->expr = tmp;
2679 }
2680
2681 /* Generate code for an intrinsic function.  Some map directly to library
2682    calls, others get special handling.  In some cases the name of the function
2683    used depends on the type specifiers.  */
2684
2685 void
2686 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2687 {
2688   gfc_intrinsic_sym *isym;
2689   const char *name;
2690   int lib;
2691
2692   isym = expr->value.function.isym;
2693
2694   name = &expr->value.function.name[2];
2695
2696   if (expr->rank > 0)
2697     {
2698       lib = gfc_is_intrinsic_libcall (expr);
2699       if (lib != 0)
2700         {
2701           if (lib == 1)
2702             se->ignore_optional = 1;
2703           gfc_conv_intrinsic_funcall (se, expr);
2704           return;
2705         }
2706     }
2707
2708   switch (expr->value.function.isym->generic_id)
2709     {
2710     case GFC_ISYM_NONE:
2711       gcc_unreachable ();
2712
2713     case GFC_ISYM_REPEAT:
2714       gfc_conv_intrinsic_repeat (se, expr);
2715       break;
2716
2717     case GFC_ISYM_TRIM:
2718       gfc_conv_intrinsic_trim (se, expr);
2719       break;
2720
2721     case GFC_ISYM_SI_KIND:
2722       gfc_conv_intrinsic_si_kind (se, expr);
2723       break;
2724
2725     case GFC_ISYM_SR_KIND:
2726       gfc_conv_intrinsic_sr_kind (se, expr);
2727       break;
2728
2729     case GFC_ISYM_EXPONENT:
2730       gfc_conv_intrinsic_exponent (se, expr);
2731       break;
2732
2733     case GFC_ISYM_SPACING:
2734       gfc_conv_intrinsic_spacing (se, expr);
2735       break;
2736
2737     case GFC_ISYM_RRSPACING:
2738       gfc_conv_intrinsic_rrspacing (se, expr);
2739       break;
2740
2741     case GFC_ISYM_SCAN:
2742       gfc_conv_intrinsic_scan (se, expr);
2743       break;
2744
2745     case GFC_ISYM_VERIFY:
2746       gfc_conv_intrinsic_verify (se, expr);
2747       break;
2748
2749     case GFC_ISYM_ALLOCATED:
2750       gfc_conv_allocated (se, expr);
2751       break;
2752
2753     case GFC_ISYM_ASSOCIATED:
2754       gfc_conv_associated(se, expr);
2755       break;
2756
2757     case GFC_ISYM_ABS:
2758       gfc_conv_intrinsic_abs (se, expr);
2759       break;
2760
2761     case GFC_ISYM_ADJUSTL:
2762       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2763       break;
2764
2765     case GFC_ISYM_ADJUSTR:
2766       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2767       break;
2768
2769     case GFC_ISYM_AIMAG:
2770       gfc_conv_intrinsic_imagpart (se, expr);
2771       break;
2772
2773     case GFC_ISYM_AINT:
2774       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2775       break;
2776
2777     case GFC_ISYM_ALL:
2778       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2779       break;
2780
2781     case GFC_ISYM_ANINT:
2782       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2783       break;
2784
2785     case GFC_ISYM_ANY:
2786       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2787       break;
2788
2789     case GFC_ISYM_BTEST:
2790       gfc_conv_intrinsic_btest (se, expr);
2791       break;
2792
2793     case GFC_ISYM_ACHAR:
2794     case GFC_ISYM_CHAR:
2795       gfc_conv_intrinsic_char (se, expr);
2796       break;
2797
2798     case GFC_ISYM_CONVERSION:
2799     case GFC_ISYM_REAL:
2800     case GFC_ISYM_LOGICAL:
2801     case GFC_ISYM_DBLE:
2802       gfc_conv_intrinsic_conversion (se, expr);
2803       break;
2804
2805       /* Integer conversions are handled seperately to make sure we get the
2806          correct rounding mode.  */
2807     case GFC_ISYM_INT:
2808       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2809       break;
2810
2811     case GFC_ISYM_NINT:
2812       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2813       break;
2814
2815     case GFC_ISYM_CEILING:
2816       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2817       break;
2818
2819     case GFC_ISYM_FLOOR:
2820       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2821       break;
2822
2823     case GFC_ISYM_MOD:
2824       gfc_conv_intrinsic_mod (se, expr, 0);
2825       break;
2826
2827     case GFC_ISYM_MODULO:
2828       gfc_conv_intrinsic_mod (se, expr, 1);
2829       break;
2830
2831     case GFC_ISYM_CMPLX:
2832       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2833       break;
2834
2835     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2836       gfc_conv_intrinsic_iargc (se, expr, TRUE);
2837       break;
2838
2839     case GFC_ISYM_CONJG:
2840       gfc_conv_intrinsic_conjg (se, expr);
2841       break;
2842
2843     case GFC_ISYM_COUNT:
2844       gfc_conv_intrinsic_count (se, expr);
2845       break;
2846
2847     case GFC_ISYM_DIM:
2848       gfc_conv_intrinsic_dim (se, expr);
2849       break;
2850
2851     case GFC_ISYM_DPROD:
2852       gfc_conv_intrinsic_dprod (se, expr);
2853       break;
2854
2855     case GFC_ISYM_IAND:
2856       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2857       break;
2858
2859     case GFC_ISYM_IBCLR:
2860       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2861       break;
2862
2863     case GFC_ISYM_IBITS:
2864       gfc_conv_intrinsic_ibits (se, expr);
2865       break;
2866
2867     case GFC_ISYM_IBSET:
2868       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2869       break;
2870
2871     case GFC_ISYM_IACHAR:
2872     case GFC_ISYM_ICHAR:
2873       /* We assume ASCII character sequence.  */
2874       gfc_conv_intrinsic_ichar (se, expr);
2875       break;
2876
2877     case GFC_ISYM_IARGC:
2878       gfc_conv_intrinsic_iargc (se, expr, FALSE);
2879       break;
2880
2881     case GFC_ISYM_IEOR:
2882       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2883       break;
2884
2885     case GFC_ISYM_INDEX:
2886       gfc_conv_intrinsic_index (se, expr);
2887       break;
2888
2889     case GFC_ISYM_IOR:
2890       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2891       break;
2892
2893     case GFC_ISYM_ISHFT:
2894       gfc_conv_intrinsic_ishft (se, expr);
2895       break;
2896
2897     case GFC_ISYM_ISHFTC:
2898       gfc_conv_intrinsic_ishftc (se, expr);
2899       break;
2900
2901     case GFC_ISYM_LBOUND:
2902       gfc_conv_intrinsic_bound (se, expr, 0);
2903       break;
2904
2905     case GFC_ISYM_LEN:
2906       gfc_conv_intrinsic_len (se, expr);
2907       break;
2908
2909     case GFC_ISYM_LEN_TRIM:
2910       gfc_conv_intrinsic_len_trim (se, expr);
2911       break;
2912
2913     case GFC_ISYM_LGE:
2914       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2915       break;
2916
2917     case GFC_ISYM_LGT:
2918       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2919       break;
2920
2921     case GFC_ISYM_LLE:
2922       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2923       break;
2924
2925     case GFC_ISYM_LLT:
2926       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2927       break;
2928
2929     case GFC_ISYM_MAX:
2930       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2931       break;
2932
2933     case GFC_ISYM_MAXLOC:
2934       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2935       break;
2936
2937     case GFC_ISYM_MAXVAL:
2938       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2939       break;
2940
2941     case GFC_ISYM_MERGE:
2942       gfc_conv_intrinsic_merge (se, expr);
2943       break;
2944
2945     case GFC_ISYM_MIN:
2946       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2947       break;
2948
2949     case GFC_ISYM_MINLOC:
2950       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2951       break;
2952
2953     case GFC_ISYM_MINVAL:
2954       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2955       break;
2956
2957     case GFC_ISYM_NOT:
2958       gfc_conv_intrinsic_not (se, expr);
2959       break;
2960
2961     case GFC_ISYM_PRESENT:
2962       gfc_conv_intrinsic_present (se, expr);
2963       break;
2964
2965     case GFC_ISYM_PRODUCT:
2966       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2967       break;
2968
2969     case GFC_ISYM_SIGN:
2970       gfc_conv_intrinsic_sign (se, expr);
2971       break;
2972
2973     case GFC_ISYM_SIZE:
2974       gfc_conv_intrinsic_size (se, expr);
2975       break;
2976
2977     case GFC_ISYM_SUM:
2978       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2979       break;
2980
2981     case GFC_ISYM_TRANSFER:
2982       gfc_conv_intrinsic_transfer (se, expr);
2983       break;
2984
2985     case GFC_ISYM_UBOUND:
2986       gfc_conv_intrinsic_bound (se, expr, 1);
2987       break;
2988
2989     case GFC_ISYM_DOT_PRODUCT:
2990     case GFC_ISYM_ETIME:
2991     case GFC_ISYM_FNUM:
2992     case GFC_ISYM_FSTAT:
2993     case GFC_ISYM_GETCWD:
2994     case GFC_ISYM_GETGID:
2995     case GFC_ISYM_GETPID:
2996     case GFC_ISYM_GETUID:
2997     case GFC_ISYM_IRAND:
2998     case GFC_ISYM_MATMUL:
2999     case GFC_ISYM_RAND:
3000     case GFC_ISYM_SECOND:
3001     case GFC_ISYM_STAT:
3002     case GFC_ISYM_SYSTEM:
3003     case GFC_ISYM_UMASK:
3004     case GFC_ISYM_UNLINK:
3005       gfc_conv_intrinsic_funcall (se, expr);
3006       break;
3007
3008     default:
3009       gfc_conv_intrinsic_lib_function (se, expr);
3010       break;
3011     }
3012 }
3013
3014
3015 /* This generates code to execute before entering the scalarization loop.
3016    Currently does nothing.  */
3017
3018 void
3019 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3020 {
3021   switch (ss->expr->value.function.isym->generic_id)
3022     {
3023     case GFC_ISYM_UBOUND:
3024     case GFC_ISYM_LBOUND:
3025       break;
3026
3027     default:
3028       gcc_unreachable ();
3029     }
3030 }
3031
3032
3033 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3034    inside the scalarization loop.  */
3035
3036 static gfc_ss *
3037 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3038 {
3039   gfc_ss *newss;
3040
3041   /* The two argument version returns a scalar.  */
3042   if (expr->value.function.actual->next->expr)
3043     return ss;
3044
3045   newss = gfc_get_ss ();
3046   newss->type = GFC_SS_INTRINSIC;
3047   newss->expr = expr;
3048   newss->next = ss;
3049
3050   return newss;
3051 }
3052
3053
3054 /* Walk an intrinsic array libcall.  */
3055
3056 static gfc_ss *
3057 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3058 {
3059   gfc_ss *newss;
3060
3061   gcc_assert (expr->rank > 0);
3062
3063   newss = gfc_get_ss ();
3064   newss->type = GFC_SS_FUNCTION;
3065   newss->expr = expr;
3066   newss->next = ss;
3067   newss->data.info.dimen = expr->rank;
3068
3069   return newss;
3070 }
3071
3072
3073 /* Returns nonzero if the specified intrinsic function call maps directly to a
3074    an external library call.  Should only be used for functions that return
3075    arrays.  */
3076
3077 int
3078 gfc_is_intrinsic_libcall (gfc_expr * expr)
3079 {
3080   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3081   gcc_assert (expr->rank > 0);
3082
3083   switch (expr->value.function.isym->generic_id)
3084     {
3085     case GFC_ISYM_ALL:
3086     case GFC_ISYM_ANY:
3087     case GFC_ISYM_COUNT:
3088     case GFC_ISYM_MATMUL:
3089     case GFC_ISYM_MAXLOC:
3090     case GFC_ISYM_MAXVAL:
3091     case GFC_ISYM_MINLOC:
3092     case GFC_ISYM_MINVAL:
3093     case GFC_ISYM_PRODUCT:
3094     case GFC_ISYM_SUM:
3095     case GFC_ISYM_SHAPE:
3096     case GFC_ISYM_SPREAD:
3097     case GFC_ISYM_TRANSPOSE:
3098       /* Ignore absent optional parameters.  */
3099       return 1;
3100
3101     case GFC_ISYM_RESHAPE:
3102     case GFC_ISYM_CSHIFT:
3103     case GFC_ISYM_EOSHIFT:
3104     case GFC_ISYM_PACK:
3105     case GFC_ISYM_UNPACK:
3106       /* Pass absent optional parameters.  */
3107       return 2;
3108
3109     default:
3110       return 0;
3111     }
3112 }
3113
3114 /* Walk an intrinsic function.  */
3115 gfc_ss *
3116 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3117                              gfc_intrinsic_sym * isym)
3118 {
3119   gcc_assert (isym);
3120
3121   if (isym->elemental)
3122     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
3123
3124   if (expr->rank == 0)
3125     return ss;
3126
3127   if (gfc_is_intrinsic_libcall (expr))
3128     return gfc_walk_intrinsic_libfunc (ss, expr);
3129
3130   /* Special cases.  */
3131   switch (isym->generic_id)
3132     {
3133     case GFC_ISYM_LBOUND:
3134     case GFC_ISYM_UBOUND:
3135       return gfc_walk_intrinsic_bound (ss, expr);
3136
3137     default:
3138       /* This probably meant someone forgot to add an intrinsic to the above
3139          list(s) when they implemented it, or something's gone horribly wrong.
3140        */
3141       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3142                       expr->value.function.name);
3143     }
3144 }
3145
3146 #include "gt-fortran-trans-intrinsic.h"