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                 build_int_cst (type, 1));
 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, build_int_cst (TREE_TYPE (bound), 0)));
 688           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 689           tmp = fold (build2 (GE_EXPR, boolean_type_node, bound, tmp));
 690           cond = fold(build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
 691           gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
 692         }
 693     }
 694
 695   if (upper)
 696     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 697   else
 698     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 699
 700   type = gfc_typenode_for_spec (&expr->ts);
 701   se->expr = convert (type, se->expr);
 702 }
 703
 704
 705 static void
 706 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 707 {
 708   tree args;
 709   tree val;
 710   int n;
 711
 712   args = gfc_conv_intrinsic_function_args (se, expr);
 713   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
 714   val = TREE_VALUE (args);
 715
 716   switch (expr->value.function.actual->expr->ts.type)
 717     {
 718     case BT_INTEGER:
 719     case BT_REAL:
 720       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 721       break;
 722
 723     case BT_COMPLEX:
 724       switch (expr->ts.kind)
 725         {
 726         case 4:
 727           n = BUILT_IN_CABSF;
 728           break;
 729         case 8:
 730           n = BUILT_IN_CABS;
 731           break;
 732         default:
 733           gcc_unreachable ();
 734         }
 735       se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
 736       break;
 737
 738     default:
 739       gcc_unreachable ();
 740     }
 741 }
 742
 743
 744 /* Create a complex value from one or two real components.  */
 745
 746 static void
 747 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 748 {
 749   tree arg;
 750   tree real;
 751   tree imag;
 752   tree type;
 753
 754   type = gfc_typenode_for_spec (&expr->ts);
 755   arg = gfc_conv_intrinsic_function_args (se, expr);
 756   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 757   if (both)
 758     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 759   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 760     {
 761       arg = TREE_VALUE (arg);
 762       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 763       imag = convert (TREE_TYPE (type), imag);
 764     }
 765   else
 766     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 767
 768   se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
 769 }
 770
 771 /* Remainder function MOD(A, P) = A - INT(A / P) * P
 772                       MODULO(A, P) = A - FLOOR (A / P) * P  */
 773 /* TODO: MOD(x, 0)  */
 774
 775 static void
 776 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 777 {
 778   tree arg;
 779   tree arg2;
 780   tree type;
 781   tree itype;
 782   tree tmp;
 783   tree test;
 784   tree test2;
 785   mpfr_t huge;
 786   int n;
 787
 788   arg = gfc_conv_intrinsic_function_args (se, expr);
 789   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 790   arg = TREE_VALUE (arg);
 791   type = TREE_TYPE (arg);
 792
 793   switch (expr->ts.type)
 794     {
 795     case BT_INTEGER:
 796       /* Integer case is easy, we've got a builtin op.  */
 797       if (modulo)
 798        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
 799       else
 800        se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
 801       break;
 802
 803     case BT_REAL:
 804       /* Real values we have to do the hard way.  */
 805       arg = gfc_evaluate_now (arg, &se->pre);
 806       arg2 = gfc_evaluate_now (arg2, &se->pre);
 807
 808       tmp = build2 (RDIV_EXPR, type, arg, arg2);
 809       /* Test if the value is too large to handle sensibly.  */
 810       gfc_set_model_kind (expr->ts.kind);
 811       mpfr_init (huge);
 812       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
 813       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 814       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 815       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 816
 817       mpfr_neg (huge, huge, GFC_RND_MODE);
 818       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 819       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 820       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 821
 822       itype = gfc_get_int_type (expr->ts.kind);
 823       if (modulo)
 824        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
 825       else
 826        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 827       tmp = convert (type, tmp);
 828       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 829       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 830       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 831       mpfr_clear (huge);
 832       break;
 833
 834     default:
 835       gcc_unreachable ();
 836     }
 837 }
 838
 839 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 840
 841 static void
 842 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 843 {
 844   tree arg;
 845   tree arg2;
 846   tree val;
 847   tree tmp;
 848   tree type;
 849   tree zero;
 850
 851   arg = gfc_conv_intrinsic_function_args (se, expr);
 852   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 853   arg = TREE_VALUE (arg);
 854   type = TREE_TYPE (arg);
 855
 856   val = build2 (MINUS_EXPR, type, arg, arg2);
 857   val = gfc_evaluate_now (val, &se->pre);
 858
 859   zero = gfc_build_const (type, integer_zero_node);
 860   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 861   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 862 }
 863
 864
 865 /* SIGN(A, B) is absolute value of A times sign of B.
 866    The real value versions use library functions to ensure the correct
 867    handling of negative zero.  Integer case implemented as:
 868    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 869   */
 870
 871 static void
 872 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 873 {
 874   tree tmp;
 875   tree arg;
 876   tree arg2;
 877   tree type;
 878   tree zero;
 879   tree testa;
 880   tree testb;
 881
 882
 883   arg = gfc_conv_intrinsic_function_args (se, expr);
 884   if (expr->ts.type == BT_REAL)
 885     {
 886       switch (expr->ts.kind)
 887         {
 888         case 4:
 889           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 890           break;
 891         case 8:
 892           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 893           break;
 894         default:
 895           gcc_unreachable ();
 896         }
 897       se->expr = fold (gfc_build_function_call (tmp, arg));
 898       return;
 899     }
 900
 901   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 902   arg = TREE_VALUE (arg);
 903   type = TREE_TYPE (arg);
 904   zero = gfc_build_const (type, integer_zero_node);
 905
 906   testa = fold (build2 (GE_EXPR, boolean_type_node, arg, zero));
 907   testb = fold (build2 (GE_EXPR, boolean_type_node, arg2, zero));
 908   tmp = fold (build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
 909   se->expr = fold (build3 (COND_EXPR, type, tmp,
 910                            build1 (NEGATE_EXPR, type, arg), arg));
 911 }
 912
 913
 914 /* Test for the presence of an optional argument.  */
 915
 916 static void
 917 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 918 {
 919   gfc_expr *arg;
 920
 921   arg = expr->value.function.actual->expr;
 922   gcc_assert (arg->expr_type == EXPR_VARIABLE);
 923   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
 924   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 925 }
 926
 927
 928 /* Calculate the double precision product of two single precision values.  */
 929
 930 static void
 931 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 932 {
 933   tree arg;
 934   tree arg2;
 935   tree type;
 936
 937   arg = gfc_conv_intrinsic_function_args (se, expr);
 938   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 939   arg = TREE_VALUE (arg);
 940
 941   /* Convert the args to double precision before multiplying.  */
 942   type = gfc_typenode_for_spec (&expr->ts);
 943   arg = convert (type, arg);
 944   arg2 = convert (type, arg2);
 945   se->expr = build2 (MULT_EXPR, type, arg, arg2);
 946 }
 947
 948
 949 /* Return a length one character string containing an ascii character.  */
 950
 951 static void
 952 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 953 {
 954   tree arg;
 955   tree var;
 956   tree type;
 957
 958   arg = gfc_conv_intrinsic_function_args (se, expr);
 959   arg = TREE_VALUE (arg);
 960
 961   /* We currently don't support character types != 1.  */
 962   gcc_assert (expr->ts.kind == 1);
 963   type = gfc_character1_type_node;
 964   var = gfc_create_var (type, "char");
 965
 966   arg = convert (type, arg);
 967   gfc_add_modify_expr (&se->pre, var, arg);
 968   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
 969   se->string_length = integer_one_node;
 970 }
 971
 972
 973 /* Get the minimum/maximum value of all the parameters.
 974     minmax (a1, a2, a3, ...)
 975     {
 976       if (a2 .op. a1)
 977         mvar = a2;
 978       else
 979         mvar = a1;
 980       if (a3 .op. mvar)
 981         mvar = a3;
 982       ...
 983       return mvar
 984     }
 985  */
 986
 987 /* TODO: Mismatching types can occur when specific names are used.
 988    These should be handled during resolution.  */
 989 static void
 990 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 991 {
 992   tree limit;
 993   tree tmp;
 994   tree mvar;
 995   tree val;
 996   tree thencase;
 997   tree elsecase;
 998   tree arg;
 999   tree type;
1000
1001   arg = gfc_conv_intrinsic_function_args (se, expr);
1002   type = gfc_typenode_for_spec (&expr->ts);
1003
1004   limit = TREE_VALUE (arg);
1005   if (TREE_TYPE (limit) != type)
1006     limit = convert (type, limit);
1007   /* Only evaluate the argument once.  */
1008   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1009     limit = gfc_evaluate_now(limit, &se->pre);
1010
1011   mvar = gfc_create_var (type, "M");
1012   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1013   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1014     {
1015       val = TREE_VALUE (arg);
1016       if (TREE_TYPE (val) != type)
1017         val = convert (type, val);
1018
1019       /* Only evaluate the argument once.  */
1020       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1021         val = gfc_evaluate_now(val, &se->pre);
1022
1023       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1024
1025       tmp = build2 (op, boolean_type_node, val, limit);
1026       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1027       gfc_add_expr_to_block (&se->pre, tmp);
1028       elsecase = build_empty_stmt ();
1029       limit = mvar;
1030     }
1031   se->expr = mvar;
1032 }
1033
1034
1035 /* Create a symbol node for this intrinsic.  The symbol form the frontend
1036    is for the generic name.  */
1037
1038 static gfc_symbol *
1039 gfc_get_symbol_for_expr (gfc_expr * expr)
1040 {
1041   gfc_symbol *sym;
1042
1043   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1044   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1045   sym = gfc_new_symbol (expr->value.function.name, NULL);
1046
1047   sym->ts = expr->ts;
1048   sym->attr.external = 1;
1049   sym->attr.function = 1;
1050   sym->attr.always_explicit = 1;
1051   sym->attr.proc = PROC_INTRINSIC;
1052   sym->attr.flavor = FL_PROCEDURE;
1053   sym->result = sym;
1054   if (expr->rank > 0)
1055     {
1056       sym->attr.dimension = 1;
1057       sym->as = gfc_get_array_spec ();
1058       sym->as->type = AS_ASSUMED_SHAPE;
1059       sym->as->rank = expr->rank;
1060     }
1061
1062   /* TODO: proper argument lists for external intrinsics.  */
1063   return sym;
1064 }
1065
1066 /* Generate a call to an external intrinsic function.  */
1067 static void
1068 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1069 {
1070   gfc_symbol *sym;
1071
1072   gcc_assert (!se->ss || se->ss->expr == expr);
1073
1074   if (se->ss)
1075     gcc_assert (expr->rank > 0);
1076   else
1077     gcc_assert (expr->rank == 0);
1078
1079   sym = gfc_get_symbol_for_expr (expr);
1080   gfc_conv_function_call (se, sym, expr->value.function.actual);
1081   gfc_free (sym);
1082 }
1083
1084 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1085    Implemented as
1086     any(a)
1087     {
1088       forall (i=...)
1089         if (a[i] != 0)
1090           return 1
1091       end forall
1092       return 0
1093     }
1094     all(a)
1095     {
1096       forall (i=...)
1097         if (a[i] == 0)
1098           return 0
1099       end forall
1100       return 1
1101     }
1102  */
1103 static void
1104 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1105 {
1106   tree resvar;
1107   stmtblock_t block;
1108   stmtblock_t body;
1109   tree type;
1110   tree tmp;
1111   tree found;
1112   gfc_loopinfo loop;
1113   gfc_actual_arglist *actual;
1114   gfc_ss *arrayss;
1115   gfc_se arrayse;
1116   tree exit_label;
1117
1118   if (se->ss)
1119     {
1120       gfc_conv_intrinsic_funcall (se, expr);
1121       return;
1122     }
1123
1124   actual = expr->value.function.actual;
1125   type = gfc_typenode_for_spec (&expr->ts);
1126   /* Initialize the result.  */
1127   resvar = gfc_create_var (type, "test");
1128   if (op == EQ_EXPR)
1129     tmp = convert (type, boolean_true_node);
1130   else
1131     tmp = convert (type, boolean_false_node);
1132   gfc_add_modify_expr (&se->pre, resvar, tmp);
1133
1134   /* Walk the arguments.  */
1135   arrayss = gfc_walk_expr (actual->expr);
1136   gcc_assert (arrayss != gfc_ss_terminator);
1137
1138   /* Initialize the scalarizer.  */
1139   gfc_init_loopinfo (&loop);
1140   exit_label = gfc_build_label_decl (NULL_TREE);
1141   TREE_USED (exit_label) = 1;
1142   gfc_add_ss_to_loop (&loop, arrayss);
1143
1144   /* Initialize the loop.  */
1145   gfc_conv_ss_startstride (&loop);
1146   gfc_conv_loop_setup (&loop);
1147
1148   gfc_mark_ss_chain_used (arrayss, 1);
1149   /* Generate the loop body.  */
1150   gfc_start_scalarized_body (&loop, &body);
1151
1152   /* If the condition matches then set the return value.  */
1153   gfc_start_block (&block);
1154   if (op == EQ_EXPR)
1155     tmp = convert (type, boolean_false_node);
1156   else
1157     tmp = convert (type, boolean_true_node);
1158   gfc_add_modify_expr (&block, resvar, tmp);
1159
1160   /* And break out of the loop.  */
1161   tmp = build1_v (GOTO_EXPR, exit_label);
1162   gfc_add_expr_to_block (&block, tmp);
1163
1164   found = gfc_finish_block (&block);
1165
1166   /* Check this element.  */
1167   gfc_init_se (&arrayse, NULL);
1168   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1169   arrayse.ss = arrayss;
1170   gfc_conv_expr_val (&arrayse, actual->expr);
1171
1172   gfc_add_block_to_block (&body, &arrayse.pre);
1173   tmp = build2 (op, boolean_type_node, arrayse.expr,
1174                 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1175   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1176   gfc_add_expr_to_block (&body, tmp);
1177   gfc_add_block_to_block (&body, &arrayse.post);
1178
1179   gfc_trans_scalarizing_loops (&loop, &body);
1180
1181   /* Add the exit label.  */
1182   tmp = build1_v (LABEL_EXPR, exit_label);
1183   gfc_add_expr_to_block (&loop.pre, tmp);
1184
1185   gfc_add_block_to_block (&se->pre, &loop.pre);
1186   gfc_add_block_to_block (&se->pre, &loop.post);
1187   gfc_cleanup_loop (&loop);
1188
1189   se->expr = resvar;
1190 }
1191
1192 /* COUNT(A) = Number of true elements in A.  */
1193 static void
1194 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1195 {
1196   tree resvar;
1197   tree type;
1198   stmtblock_t body;
1199   tree tmp;
1200   gfc_loopinfo loop;
1201   gfc_actual_arglist *actual;
1202   gfc_ss *arrayss;
1203   gfc_se arrayse;
1204
1205   if (se->ss)
1206     {
1207       gfc_conv_intrinsic_funcall (se, expr);
1208       return;
1209     }
1210
1211   actual = expr->value.function.actual;
1212
1213   type = gfc_typenode_for_spec (&expr->ts);
1214   /* Initialize the result.  */
1215   resvar = gfc_create_var (type, "count");
1216   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1217
1218   /* Walk the arguments.  */
1219   arrayss = gfc_walk_expr (actual->expr);
1220   gcc_assert (arrayss != gfc_ss_terminator);
1221
1222   /* Initialize the scalarizer.  */
1223   gfc_init_loopinfo (&loop);
1224   gfc_add_ss_to_loop (&loop, arrayss);
1225
1226   /* Initialize the loop.  */
1227   gfc_conv_ss_startstride (&loop);
1228   gfc_conv_loop_setup (&loop);
1229
1230   gfc_mark_ss_chain_used (arrayss, 1);
1231   /* Generate the loop body.  */
1232   gfc_start_scalarized_body (&loop, &body);
1233
1234   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1235                 build_int_cst (TREE_TYPE (resvar), 1));
1236   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1237
1238   gfc_init_se (&arrayse, NULL);
1239   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1240   arrayse.ss = arrayss;
1241   gfc_conv_expr_val (&arrayse, actual->expr);
1242   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1243
1244   gfc_add_block_to_block (&body, &arrayse.pre);
1245   gfc_add_expr_to_block (&body, tmp);
1246   gfc_add_block_to_block (&body, &arrayse.post);
1247
1248   gfc_trans_scalarizing_loops (&loop, &body);
1249
1250   gfc_add_block_to_block (&se->pre, &loop.pre);
1251   gfc_add_block_to_block (&se->pre, &loop.post);
1252   gfc_cleanup_loop (&loop);
1253
1254   se->expr = resvar;
1255 }
1256
1257 /* Inline implementation of the sum and product intrinsics.  */
1258 static void
1259 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1260 {
1261   tree resvar;
1262   tree type;
1263   stmtblock_t body;
1264   stmtblock_t block;
1265   tree tmp;
1266   gfc_loopinfo loop;
1267   gfc_actual_arglist *actual;
1268   gfc_ss *arrayss;
1269   gfc_ss *maskss;
1270   gfc_se arrayse;
1271   gfc_se maskse;
1272   gfc_expr *arrayexpr;
1273   gfc_expr *maskexpr;
1274
1275   if (se->ss)
1276     {
1277       gfc_conv_intrinsic_funcall (se, expr);
1278       return;
1279     }
1280
1281   type = gfc_typenode_for_spec (&expr->ts);
1282   /* Initialize the result.  */
1283   resvar = gfc_create_var (type, "val");
1284   if (op == PLUS_EXPR)
1285     tmp = gfc_build_const (type, integer_zero_node);
1286   else
1287     tmp = gfc_build_const (type, integer_one_node);
1288
1289   gfc_add_modify_expr (&se->pre, resvar, tmp);
1290
1291   /* Walk the arguments.  */
1292   actual = expr->value.function.actual;
1293   arrayexpr = actual->expr;
1294   arrayss = gfc_walk_expr (arrayexpr);
1295   gcc_assert (arrayss != gfc_ss_terminator);
1296
1297   actual = actual->next->next;
1298   gcc_assert (actual);
1299   maskexpr = actual->expr;
1300   if (maskexpr)
1301     {
1302       maskss = gfc_walk_expr (maskexpr);
1303       gcc_assert (maskss != gfc_ss_terminator);
1304     }
1305   else
1306     maskss = NULL;
1307
1308   /* Initialize the scalarizer.  */
1309   gfc_init_loopinfo (&loop);
1310   gfc_add_ss_to_loop (&loop, arrayss);
1311   if (maskss)
1312     gfc_add_ss_to_loop (&loop, maskss);
1313
1314   /* Initialize the loop.  */
1315   gfc_conv_ss_startstride (&loop);
1316   gfc_conv_loop_setup (&loop);
1317
1318   gfc_mark_ss_chain_used (arrayss, 1);
1319   if (maskss)
1320     gfc_mark_ss_chain_used (maskss, 1);
1321   /* Generate the loop body.  */
1322   gfc_start_scalarized_body (&loop, &body);
1323
1324   /* If we have a mask, only add this element if the mask is set.  */
1325   if (maskss)
1326     {
1327       gfc_init_se (&maskse, NULL);
1328       gfc_copy_loopinfo_to_se (&maskse, &loop);
1329       maskse.ss = maskss;
1330       gfc_conv_expr_val (&maskse, maskexpr);
1331       gfc_add_block_to_block (&body, &maskse.pre);
1332
1333       gfc_start_block (&block);
1334     }
1335   else
1336     gfc_init_block (&block);
1337
1338   /* Do the actual summation/product.  */
1339   gfc_init_se (&arrayse, NULL);
1340   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1341   arrayse.ss = arrayss;
1342   gfc_conv_expr_val (&arrayse, arrayexpr);
1343   gfc_add_block_to_block (&block, &arrayse.pre);
1344
1345   tmp = build2 (op, type, resvar, arrayse.expr);
1346   gfc_add_modify_expr (&block, resvar, tmp);
1347   gfc_add_block_to_block (&block, &arrayse.post);
1348
1349   if (maskss)
1350     {
1351       /* We enclose the above in if (mask) {...} .  */
1352       tmp = gfc_finish_block (&block);
1353
1354       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1355     }
1356   else
1357     tmp = gfc_finish_block (&block);
1358   gfc_add_expr_to_block (&body, tmp);
1359
1360   gfc_trans_scalarizing_loops (&loop, &body);
1361   gfc_add_block_to_block (&se->pre, &loop.pre);
1362   gfc_add_block_to_block (&se->pre, &loop.post);
1363   gfc_cleanup_loop (&loop);
1364
1365   se->expr = resvar;
1366 }
1367
1368 static void
1369 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1370 {
1371   stmtblock_t body;
1372   stmtblock_t block;
1373   stmtblock_t ifblock;
1374   tree limit;
1375   tree type;
1376   tree tmp;
1377   tree ifbody;
1378   tree cond;
1379   gfc_loopinfo loop;
1380   gfc_actual_arglist *actual;
1381   gfc_ss *arrayss;
1382   gfc_ss *maskss;
1383   gfc_se arrayse;
1384   gfc_se maskse;
1385   gfc_expr *arrayexpr;
1386   gfc_expr *maskexpr;
1387   tree pos;
1388   int n;
1389
1390   if (se->ss)
1391     {
1392       gfc_conv_intrinsic_funcall (se, expr);
1393       return;
1394     }
1395
1396   /* Initialize the result.  */
1397   pos = gfc_create_var (gfc_array_index_type, "pos");
1398   type = gfc_typenode_for_spec (&expr->ts);
1399
1400   /* Walk the arguments.  */
1401   actual = expr->value.function.actual;
1402   arrayexpr = actual->expr;
1403   arrayss = gfc_walk_expr (arrayexpr);
1404   gcc_assert (arrayss != gfc_ss_terminator);
1405
1406   actual = actual->next->next;
1407   gcc_assert (actual);
1408   maskexpr = actual->expr;
1409   if (maskexpr)
1410     {
1411       maskss = gfc_walk_expr (maskexpr);
1412       gcc_assert (maskss != gfc_ss_terminator);
1413     }
1414   else
1415     maskss = NULL;
1416
1417   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1418   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1419   switch (arrayexpr->ts.type)
1420     {
1421     case BT_REAL:
1422       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1423       break;
1424
1425     case BT_INTEGER:
1426       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1427                                   arrayexpr->ts.kind);
1428       break;
1429
1430     default:
1431       gcc_unreachable ();
1432     }
1433
1434   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1435   if (op == GT_EXPR)
1436     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1437   gfc_add_modify_expr (&se->pre, limit, tmp);
1438
1439   /* Initialize the scalarizer.  */
1440   gfc_init_loopinfo (&loop);
1441   gfc_add_ss_to_loop (&loop, arrayss);
1442   if (maskss)
1443     gfc_add_ss_to_loop (&loop, maskss);
1444
1445   /* Initialize the loop.  */
1446   gfc_conv_ss_startstride (&loop);
1447   gfc_conv_loop_setup (&loop);
1448
1449   gcc_assert (loop.dimen == 1);
1450
1451   /* Initialize the position to the first element.  If the array has zero
1452      size we need to return zero.  Otherwise use the first element of the
1453      array, in case all elements are equal to the limit.
1454      i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1455   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1456                       loop.from[0], gfc_index_one_node));
1457   cond = fold (build2 (GE_EXPR, boolean_type_node,
1458                        loop.to[0], loop.from[0]));
1459   tmp = fold (build3 (COND_EXPR, gfc_array_index_type, cond,
1460                       loop.from[0], tmp));
1461   gfc_add_modify_expr (&loop.pre, pos, tmp);
1462
1463   gfc_mark_ss_chain_used (arrayss, 1);
1464   if (maskss)
1465     gfc_mark_ss_chain_used (maskss, 1);
1466   /* Generate the loop body.  */
1467   gfc_start_scalarized_body (&loop, &body);
1468
1469   /* If we have a mask, only check this element if the mask is set.  */
1470   if (maskss)
1471     {
1472       gfc_init_se (&maskse, NULL);
1473       gfc_copy_loopinfo_to_se (&maskse, &loop);
1474       maskse.ss = maskss;
1475       gfc_conv_expr_val (&maskse, maskexpr);
1476       gfc_add_block_to_block (&body, &maskse.pre);
1477
1478       gfc_start_block (&block);
1479     }
1480   else
1481     gfc_init_block (&block);
1482
1483   /* Compare with the current limit.  */
1484   gfc_init_se (&arrayse, NULL);
1485   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1486   arrayse.ss = arrayss;
1487   gfc_conv_expr_val (&arrayse, arrayexpr);
1488   gfc_add_block_to_block (&block, &arrayse.pre);
1489
1490   /* We do the following if this is a more extreme value.  */
1491   gfc_start_block (&ifblock);
1492
1493   /* Assign the value to the limit...  */
1494   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1495
1496   /* Remember where we are.  */
1497   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1498
1499   ifbody = gfc_finish_block (&ifblock);
1500
1501   /* If it is a more extreme value.  */
1502   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1503   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1504   gfc_add_expr_to_block (&block, tmp);
1505
1506   if (maskss)
1507     {
1508       /* We enclose the above in if (mask) {...}.  */
1509       tmp = gfc_finish_block (&block);
1510
1511       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1512     }
1513   else
1514     tmp = gfc_finish_block (&block);
1515   gfc_add_expr_to_block (&body, tmp);
1516
1517   gfc_trans_scalarizing_loops (&loop, &body);
1518
1519   gfc_add_block_to_block (&se->pre, &loop.pre);
1520   gfc_add_block_to_block (&se->pre, &loop.post);
1521   gfc_cleanup_loop (&loop);
1522
1523   /* Return a value in the range 1..SIZE(array).  */
1524   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1525                       gfc_index_one_node));
1526   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1527   /* And convert to the required type.  */
1528   se->expr = convert (type, tmp);
1529 }
1530
1531 static void
1532 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1533 {
1534   tree limit;
1535   tree type;
1536   tree tmp;
1537   tree ifbody;
1538   stmtblock_t body;
1539   stmtblock_t block;
1540   gfc_loopinfo loop;
1541   gfc_actual_arglist *actual;
1542   gfc_ss *arrayss;
1543   gfc_ss *maskss;
1544   gfc_se arrayse;
1545   gfc_se maskse;
1546   gfc_expr *arrayexpr;
1547   gfc_expr *maskexpr;
1548   int n;
1549
1550   if (se->ss)
1551     {
1552       gfc_conv_intrinsic_funcall (se, expr);
1553       return;
1554     }
1555
1556   type = gfc_typenode_for_spec (&expr->ts);
1557   /* Initialize the result.  */
1558   limit = gfc_create_var (type, "limit");
1559   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1560   switch (expr->ts.type)
1561     {
1562     case BT_REAL:
1563       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1564       break;
1565
1566     case BT_INTEGER:
1567       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1568       break;
1569
1570     default:
1571       gcc_unreachable ();
1572     }
1573
1574   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1575   if (op == GT_EXPR)
1576     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1577   gfc_add_modify_expr (&se->pre, limit, tmp);
1578
1579   /* Walk the arguments.  */
1580   actual = expr->value.function.actual;
1581   arrayexpr = actual->expr;
1582   arrayss = gfc_walk_expr (arrayexpr);
1583   gcc_assert (arrayss != gfc_ss_terminator);
1584
1585   actual = actual->next->next;
1586   gcc_assert (actual);
1587   maskexpr = actual->expr;
1588   if (maskexpr)
1589     {
1590       maskss = gfc_walk_expr (maskexpr);
1591       gcc_assert (maskss != gfc_ss_terminator);
1592     }
1593   else
1594     maskss = NULL;
1595
1596   /* Initialize the scalarizer.  */
1597   gfc_init_loopinfo (&loop);
1598   gfc_add_ss_to_loop (&loop, arrayss);
1599   if (maskss)
1600     gfc_add_ss_to_loop (&loop, maskss);
1601
1602   /* Initialize the loop.  */
1603   gfc_conv_ss_startstride (&loop);
1604   gfc_conv_loop_setup (&loop);
1605
1606   gfc_mark_ss_chain_used (arrayss, 1);
1607   if (maskss)
1608     gfc_mark_ss_chain_used (maskss, 1);
1609   /* Generate the loop body.  */
1610   gfc_start_scalarized_body (&loop, &body);
1611
1612   /* If we have a mask, only add this element if the mask is set.  */
1613   if (maskss)
1614     {
1615       gfc_init_se (&maskse, NULL);
1616       gfc_copy_loopinfo_to_se (&maskse, &loop);
1617       maskse.ss = maskss;
1618       gfc_conv_expr_val (&maskse, maskexpr);
1619       gfc_add_block_to_block (&body, &maskse.pre);
1620
1621       gfc_start_block (&block);
1622     }
1623   else
1624     gfc_init_block (&block);
1625
1626   /* Compare with the current limit.  */
1627   gfc_init_se (&arrayse, NULL);
1628   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1629   arrayse.ss = arrayss;
1630   gfc_conv_expr_val (&arrayse, arrayexpr);
1631   gfc_add_block_to_block (&block, &arrayse.pre);
1632
1633   /* Assign the value to the limit...  */
1634   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1635
1636   /* If it is a more extreme value.  */
1637   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1638   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1639   gfc_add_expr_to_block (&block, tmp);
1640   gfc_add_block_to_block (&block, &arrayse.post);
1641
1642   tmp = gfc_finish_block (&block);
1643   if (maskss)
1644     /* We enclose the above in if (mask) {...}.  */
1645     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1646   gfc_add_expr_to_block (&body, tmp);
1647
1648   gfc_trans_scalarizing_loops (&loop, &body);
1649
1650   gfc_add_block_to_block (&se->pre, &loop.pre);
1651   gfc_add_block_to_block (&se->pre, &loop.post);
1652   gfc_cleanup_loop (&loop);
1653
1654   se->expr = limit;
1655 }
1656
1657 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1658 static void
1659 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1660 {
1661   tree arg;
1662   tree arg2;
1663   tree type;
1664   tree tmp;
1665
1666   arg = gfc_conv_intrinsic_function_args (se, expr);
1667   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1668   arg = TREE_VALUE (arg);
1669   type = TREE_TYPE (arg);
1670
1671   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
1672   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1673   tmp = fold (build2 (NE_EXPR, boolean_type_node, tmp,
1674                       build_int_cst (type, 0)));
1675   type = gfc_typenode_for_spec (&expr->ts);
1676   se->expr = convert (type, tmp);
1677 }
1678
1679 /* Generate code to perform the specified operation.  */
1680 static void
1681 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1682 {
1683   tree arg;
1684   tree arg2;
1685   tree type;
1686
1687   arg = gfc_conv_intrinsic_function_args (se, expr);
1688   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1689   arg = TREE_VALUE (arg);
1690   type = TREE_TYPE (arg);
1691
1692   se->expr = fold (build2 (op, type, arg, arg2));
1693 }
1694
1695 /* Bitwise not.  */
1696 static void
1697 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1698 {
1699   tree arg;
1700
1701   arg = gfc_conv_intrinsic_function_args (se, expr);
1702   arg = TREE_VALUE (arg);
1703
1704   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1705 }
1706
1707 /* Set or clear a single bit.  */
1708 static void
1709 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1710 {
1711   tree arg;
1712   tree arg2;
1713   tree type;
1714   tree tmp;
1715   int op;
1716
1717   arg = gfc_conv_intrinsic_function_args (se, expr);
1718   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1719   arg = TREE_VALUE (arg);
1720   type = TREE_TYPE (arg);
1721
1722   tmp = fold (build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2));
1723   if (set)
1724     op = BIT_IOR_EXPR;
1725   else
1726     {
1727       op = BIT_AND_EXPR;
1728       tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1729     }
1730   se->expr = fold (build2 (op, type, arg, tmp));
1731 }
1732
1733 /* Extract a sequence of bits.
1734     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1735 static void
1736 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1737 {
1738   tree arg;
1739   tree arg2;
1740   tree arg3;
1741   tree type;
1742   tree tmp;
1743   tree mask;
1744
1745   arg = gfc_conv_intrinsic_function_args (se, expr);
1746   arg2 = TREE_CHAIN (arg);
1747   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1748   arg = TREE_VALUE (arg);
1749   arg2 = TREE_VALUE (arg2);
1750   type = TREE_TYPE (arg);
1751
1752   mask = build_int_cst (NULL_TREE, -1);
1753   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1754   mask = build1 (BIT_NOT_EXPR, type, mask);
1755
1756   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1757
1758   se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
1759 }
1760
1761 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1762                         ? 0
1763                         : ((shift >= 0) ? i << shift : i >> -shift)
1764    where all shifts are logical shifts.  */
1765 static void
1766 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1767 {
1768   tree arg;
1769   tree arg2;
1770   tree type;
1771   tree utype;
1772   tree tmp;
1773   tree width;
1774   tree num_bits;
1775   tree cond;
1776   tree lshift;
1777   tree rshift;
1778
1779   arg = gfc_conv_intrinsic_function_args (se, expr);
1780   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1781   arg = TREE_VALUE (arg);
1782   type = TREE_TYPE (arg);
1783   utype = gfc_unsigned_type (type);
1784
1785   width = fold (build1 (ABS_EXPR, TREE_TYPE (arg2), arg2));
1786
1787   /* Left shift if positive.  */
1788   lshift = fold (build2 (LSHIFT_EXPR, type, arg, width));
1789
1790   /* Right shift if negative.
1791      We convert to an unsigned type because we want a logical shift.
1792      The standard doesn't define the case of shifting negative
1793      numbers, and we try to be compatible with other compilers, most
1794      notably g77, here.  */
1795   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
1796                                        convert (type, arg), width));
1797
1798   tmp = fold (build2 (GE_EXPR, boolean_type_node, arg2,
1799                       build_int_cst (TREE_TYPE (arg2), 0)));
1800   tmp = fold (build3 (COND_EXPR, type, tmp, lshift, rshift));
1801
1802   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1803      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1804      special case.  */
1805   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
1806   cond = fold (build2 (GE_EXPR, boolean_type_node, width, num_bits));
1807
1808   se->expr = fold (build3 (COND_EXPR, type, cond,
1809                            build_int_cst (type, 0), tmp));
1810 }
1811
1812 /* Circular shift.  AKA rotate or barrel shift.  */
1813 static void
1814 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1815 {
1816   tree arg;
1817   tree arg2;
1818   tree arg3;
1819   tree type;
1820   tree tmp;
1821   tree lrot;
1822   tree rrot;
1823   tree zero;
1824
1825   arg = gfc_conv_intrinsic_function_args (se, expr);
1826   arg2 = TREE_CHAIN (arg);
1827   arg3 = TREE_CHAIN (arg2);
1828   if (arg3)
1829     {
1830       /* Use a library function for the 3 parameter version.  */
1831       tree int4type = gfc_get_int_type (4);
1832
1833       type = TREE_TYPE (TREE_VALUE (arg));
1834       /* We convert the first argument to at least 4 bytes, and
1835          convert back afterwards.  This removes the need for library
1836          functions for all argument sizes, and function will be
1837          aligned to at least 32 bits, so there's no loss.  */
1838       if (expr->ts.kind < 4)
1839         {
1840           tmp = convert (int4type, TREE_VALUE (arg));
1841           TREE_VALUE (arg) = tmp;
1842         }
1843       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1844          need loads of library  functions.  They cannot have values >
1845          BIT_SIZE (I) so the conversion is safe.  */
1846       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
1847       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
1848
1849       switch (expr->ts.kind)
1850         {
1851         case 1:
1852         case 2:
1853         case 4:
1854           tmp = gfor_fndecl_math_ishftc4;
1855           break;
1856         case 8:
1857           tmp = gfor_fndecl_math_ishftc8;
1858           break;
1859         default:
1860           gcc_unreachable ();
1861         }
1862       se->expr = gfc_build_function_call (tmp, arg);
1863       /* Convert the result back to the original type, if we extended
1864          the first argument's width above.  */
1865       if (expr->ts.kind < 4)
1866         se->expr = convert (type, se->expr);
1867
1868       return;
1869     }
1870   arg = TREE_VALUE (arg);
1871   arg2 = TREE_VALUE (arg2);
1872   type = TREE_TYPE (arg);
1873
1874   /* Rotate left if positive.  */
1875   lrot = fold (build2 (LROTATE_EXPR, type, arg, arg2));
1876
1877   /* Rotate right if negative.  */
1878   tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2));
1879   rrot = fold (build2 (RROTATE_EXPR, type, arg, tmp));
1880
1881   zero = build_int_cst (TREE_TYPE (arg2), 0);
1882   tmp = fold (build2 (GT_EXPR, boolean_type_node, arg2, zero));
1883   rrot = fold (build3 (COND_EXPR, type, tmp, lrot, rrot));
1884
1885   /* Do nothing if shift == 0.  */
1886   tmp = fold (build2 (EQ_EXPR, boolean_type_node, arg2, zero));
1887   se->expr = fold (build3 (COND_EXPR, type, tmp, arg, rrot));
1888 }
1889
1890 /* The length of a character string.  */
1891 static void
1892 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1893 {
1894   tree len;
1895   tree type;
1896   tree decl;
1897   gfc_symbol *sym;
1898   gfc_se argse;
1899   gfc_expr *arg;
1900
1901   gcc_assert (!se->ss);
1902
1903   arg = expr->value.function.actual->expr;
1904
1905   type = gfc_typenode_for_spec (&expr->ts);
1906   switch (arg->expr_type)
1907     {
1908     case EXPR_CONSTANT:
1909       len = build_int_cst (NULL_TREE, arg->value.character.length);
1910       break;
1911
1912     default:
1913         if (arg->expr_type == EXPR_VARIABLE
1914             && (arg->ref == NULL || (arg->ref->next == NULL
1915                                      && arg->ref->type == REF_ARRAY)))
1916           {
1917             /* This doesn't catch all cases.
1918                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1919                and the surrounding thread.  */
1920             sym = arg->symtree->n.sym;
1921             decl = gfc_get_symbol_decl (sym);
1922             if (decl == current_function_decl && sym->attr.function
1923                 && (sym->result == sym))
1924               decl = gfc_get_fake_result_decl (sym);
1925
1926             len = sym->ts.cl->backend_decl;
1927             gcc_assert (len);
1928           }
1929         else
1930           {
1931             /* Anybody stupid enough to do this deserves inefficient code.  */
1932             gfc_init_se (&argse, se);
1933             gfc_conv_expr (&argse, arg);
1934             gfc_add_block_to_block (&se->pre, &argse.pre);
1935             gfc_add_block_to_block (&se->post, &argse.post);
1936             len = argse.string_length;
1937         }
1938       break;
1939     }
1940   se->expr = convert (type, len);
1941 }
1942
1943 /* The length of a character string not including trailing blanks.  */
1944 static void
1945 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1946 {
1947   tree args;
1948   tree type;
1949
1950   args = gfc_conv_intrinsic_function_args (se, expr);
1951   type = gfc_typenode_for_spec (&expr->ts);
1952   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1953   se->expr = convert (type, se->expr);
1954 }
1955
1956
1957 /* Returns the starting position of a substring within a string.  */
1958
1959 static void
1960 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1961 {
1962   tree logical4_type_node = gfc_get_logical_type (4);
1963   tree args;
1964   tree back;
1965   tree type;
1966   tree tmp;
1967
1968   args = gfc_conv_intrinsic_function_args (se, expr);
1969   type = gfc_typenode_for_spec (&expr->ts);
1970   tmp = gfc_advance_chain (args, 3);
1971   if (TREE_CHAIN (tmp) == NULL_TREE)
1972     {
1973       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
1974                         NULL_TREE);
1975       TREE_CHAIN (tmp) = back;
1976     }
1977   else
1978     {
1979       back = TREE_CHAIN (tmp);
1980       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
1981     }
1982
1983   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1984   se->expr = convert (type, se->expr);
1985 }
1986
1987 /* The ascii value for a single character.  */
1988 static void
1989 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1990 {
1991   tree arg;
1992   tree type;
1993
1994   arg = gfc_conv_intrinsic_function_args (se, expr);
1995   arg = TREE_VALUE (TREE_CHAIN (arg));
1996   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
1997   arg = build1 (NOP_EXPR, pchar_type_node, arg);
1998   type = gfc_typenode_for_spec (&expr->ts);
1999
2000   se->expr = gfc_build_indirect_ref (arg);
2001   se->expr = convert (type, se->expr);
2002 }
2003
2004
2005 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2006
2007 static void
2008 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2009 {
2010   tree arg;
2011   tree tsource;
2012   tree fsource;
2013   tree mask;
2014   tree type;
2015   tree len;
2016
2017   arg = gfc_conv_intrinsic_function_args (se, expr);
2018   if (expr->ts.type != BT_CHARACTER)
2019     {
2020       tsource = TREE_VALUE (arg);
2021       arg = TREE_CHAIN (arg);
2022       fsource = TREE_VALUE (arg);
2023       mask = TREE_VALUE (TREE_CHAIN (arg));
2024     }
2025   else
2026     {
2027       /* We do the same as in the non-character case, but the argument
2028          list is different because of the string length arguments. We
2029          also have to set the string length for the result.  */
2030       len = TREE_VALUE (arg);
2031       arg = TREE_CHAIN (arg);
2032       tsource = TREE_VALUE (arg);
2033       arg = TREE_CHAIN (TREE_CHAIN (arg));
2034       fsource = TREE_VALUE (arg);
2035       mask = TREE_VALUE (TREE_CHAIN (arg));
2036
2037       se->string_length = len;
2038     }
2039   type = TREE_TYPE (tsource);
2040   se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
2041 }
2042
2043
2044 static void
2045 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2046 {
2047   gfc_actual_arglist *actual;
2048   tree args;
2049   tree type;
2050   tree fndecl;
2051   gfc_se argse;
2052   gfc_ss *ss;
2053
2054   gfc_init_se (&argse, NULL);
2055   actual = expr->value.function.actual;
2056
2057   ss = gfc_walk_expr (actual->expr);
2058   gcc_assert (ss != gfc_ss_terminator);
2059   argse.want_pointer = 1;
2060   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2061   gfc_add_block_to_block (&se->pre, &argse.pre);
2062   gfc_add_block_to_block (&se->post, &argse.post);
2063   args = gfc_chainon_list (NULL_TREE, argse.expr);
2064
2065   actual = actual->next;
2066   if (actual->expr)
2067     {
2068       gfc_init_se (&argse, NULL);
2069       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2070       gfc_add_block_to_block (&se->pre, &argse.pre);
2071       args = gfc_chainon_list (args, argse.expr);
2072       fndecl = gfor_fndecl_size1;
2073     }
2074   else
2075     fndecl = gfor_fndecl_size0;
2076
2077   se->expr = gfc_build_function_call (fndecl, args);
2078   type = gfc_typenode_for_spec (&expr->ts);
2079   se->expr = convert (type, se->expr);
2080 }
2081
2082
2083 /* Intrinsic string comparison functions.  */
2084
2085   static void
2086 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2087 {
2088   tree type;
2089   tree args;
2090
2091   args = gfc_conv_intrinsic_function_args (se, expr);
2092   /* Build a call for the comparison.  */
2093   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2094
2095   type = gfc_typenode_for_spec (&expr->ts);
2096   se->expr = build2 (op, type, se->expr,
2097                      build_int_cst (TREE_TYPE (se->expr), 0));
2098 }
2099
2100 /* Generate a call to the adjustl/adjustr library function.  */
2101 static void
2102 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2103 {
2104   tree args;
2105   tree len;
2106   tree type;
2107   tree var;
2108   tree tmp;
2109
2110   args = gfc_conv_intrinsic_function_args (se, expr);
2111   len = TREE_VALUE (args);
2112
2113   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2114   var = gfc_conv_string_tmp (se, type, len);
2115   args = tree_cons (NULL_TREE, var, args);
2116
2117   tmp = gfc_build_function_call (fndecl, args);
2118   gfc_add_expr_to_block (&se->pre, tmp);
2119   se->expr = var;
2120   se->string_length = len;
2121 }
2122
2123
2124 /* Scalar transfer statement.
2125    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2126
2127 static void
2128 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2129 {
2130   gfc_actual_arglist *arg;
2131   gfc_se argse;
2132   tree type;
2133   tree ptr;
2134   gfc_ss *ss;
2135
2136   gcc_assert (!se->ss);
2137
2138   /* Get a pointer to the source.  */
2139   arg = expr->value.function.actual;
2140   ss = gfc_walk_expr (arg->expr);
2141   gfc_init_se (&argse, NULL);
2142   if (ss == gfc_ss_terminator)
2143     gfc_conv_expr_reference (&argse, arg->expr);
2144   else
2145     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2146   gfc_add_block_to_block (&se->pre, &argse.pre);
2147   gfc_add_block_to_block (&se->post, &argse.post);
2148   ptr = argse.expr;
2149
2150   arg = arg->next;
2151   type = gfc_typenode_for_spec (&expr->ts);
2152   ptr = convert (build_pointer_type (type), ptr);
2153   if (expr->ts.type == BT_CHARACTER)
2154     {
2155       gfc_init_se (&argse, NULL);
2156       gfc_conv_expr (&argse, arg->expr);
2157       gfc_add_block_to_block (&se->pre, &argse.pre);
2158       gfc_add_block_to_block (&se->post, &argse.post);
2159       se->expr = ptr;
2160       se->string_length = argse.string_length;
2161     }
2162   else
2163     {
2164       se->expr = gfc_build_indirect_ref (ptr);
2165     }
2166 }
2167
2168
2169 /* Generate code for the ALLOCATED intrinsic.
2170    Generate inline code that directly check the address of the argument.  */
2171
2172 static void
2173 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2174 {
2175   gfc_actual_arglist *arg1;
2176   gfc_se arg1se;
2177   gfc_ss *ss1;
2178   tree tmp;
2179
2180   gfc_init_se (&arg1se, NULL);
2181   arg1 = expr->value.function.actual;
2182   ss1 = gfc_walk_expr (arg1->expr);
2183   arg1se.descriptor_only = 1;
2184   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2185
2186   tmp = gfc_conv_descriptor_data (arg1se.expr);
2187   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2188                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2189   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2190 }
2191
2192
2193 /* Generate code for the ASSOCIATED intrinsic.
2194    If both POINTER and TARGET are arrays, generate a call to library function
2195    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2196    In other cases, generate inline code that directly compare the address of
2197    POINTER with the address of TARGET.  */
2198
2199 static void
2200 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2201 {
2202   gfc_actual_arglist *arg1;
2203   gfc_actual_arglist *arg2;
2204   gfc_se arg1se;
2205   gfc_se arg2se;
2206   tree tmp2;
2207   tree tmp;
2208   tree args, fndecl;
2209   gfc_ss *ss1, *ss2;
2210
2211   gfc_init_se (&arg1se, NULL);
2212   gfc_init_se (&arg2se, NULL);
2213   arg1 = expr->value.function.actual;
2214   arg2 = arg1->next;
2215   ss1 = gfc_walk_expr (arg1->expr);
2216
2217   if (!arg2->expr)
2218     {
2219       /* No optional target.  */
2220       if (ss1 == gfc_ss_terminator)
2221         {
2222           /* A pointer to a scalar.  */
2223           arg1se.want_pointer = 1;
2224           gfc_conv_expr (&arg1se, arg1->expr);
2225           tmp2 = arg1se.expr;
2226         }
2227       else
2228         {
2229           /* A pointer to an array.  */
2230           arg1se.descriptor_only = 1;
2231           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2232           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2233         }
2234       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2235                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2236       se->expr = tmp;
2237     }
2238   else
2239     {
2240       /* An optional target.  */
2241       ss2 = gfc_walk_expr (arg2->expr);
2242       if (ss1 == gfc_ss_terminator)
2243         {
2244           /* A pointer to a scalar.  */
2245           gcc_assert (ss2 == gfc_ss_terminator);
2246           arg1se.want_pointer = 1;
2247           gfc_conv_expr (&arg1se, arg1->expr);
2248           arg2se.want_pointer = 1;
2249           gfc_conv_expr (&arg2se, arg2->expr);
2250           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2251           se->expr = tmp;
2252         }
2253       else
2254         {
2255           /* A pointer to an array, call library function _gfor_associated.  */
2256           gcc_assert (ss2 != gfc_ss_terminator);
2257           args = NULL_TREE;
2258           arg1se.want_pointer = 1;
2259           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2260           args = gfc_chainon_list (args, arg1se.expr);
2261           arg2se.want_pointer = 1;
2262           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2263           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2264           gfc_add_block_to_block (&se->post, &arg2se.post);
2265           args = gfc_chainon_list (args, arg2se.expr);
2266           fndecl = gfor_fndecl_associated;
2267           se->expr = gfc_build_function_call (fndecl, args);
2268         }
2269      }
2270   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2271 }
2272
2273
2274 /* Scan a string for any one of the characters in a set of characters.  */
2275
2276 static void
2277 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2278 {
2279   tree logical4_type_node = gfc_get_logical_type (4);
2280   tree args;
2281   tree back;
2282   tree type;
2283   tree tmp;
2284
2285   args = gfc_conv_intrinsic_function_args (se, expr);
2286   type = gfc_typenode_for_spec (&expr->ts);
2287   tmp = gfc_advance_chain (args, 3);
2288   if (TREE_CHAIN (tmp) == NULL_TREE)
2289     {
2290       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2291                         NULL_TREE);
2292       TREE_CHAIN (tmp) = back;
2293     }
2294   else
2295     {
2296       back = TREE_CHAIN (tmp);
2297       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2298     }
2299
2300   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2301   se->expr = convert (type, se->expr);
2302 }
2303
2304
2305 /* Verify that a set of characters contains all the characters in a string
2306    by identifying the position of the first character in a string of
2307    characters that does not appear in a given set of characters.  */
2308
2309 static void
2310 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2311 {
2312   tree logical4_type_node = gfc_get_logical_type (4);
2313   tree args;
2314   tree back;
2315   tree type;
2316   tree tmp;
2317
2318   args = gfc_conv_intrinsic_function_args (se, expr);
2319   type = gfc_typenode_for_spec (&expr->ts);
2320   tmp = gfc_advance_chain (args, 3);
2321   if (TREE_CHAIN (tmp) == NULL_TREE)
2322     {
2323       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2324                         NULL_TREE);
2325       TREE_CHAIN (tmp) = back;
2326     }
2327   else
2328     {
2329       back = TREE_CHAIN (tmp);
2330       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2331     }
2332
2333   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2334   se->expr = convert (type, se->expr);
2335 }
2336
2337 /* Prepare components and related information of a real number which is
2338    the first argument of a elemental functions to manipulate reals.  */
2339
2340 static void
2341 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2342                   real_compnt_info * rcs, int all)
2343 {
2344    tree arg;
2345    tree masktype;
2346    tree tmp;
2347    tree wbits;
2348    tree one;
2349    tree exponent, fraction;
2350    int n;
2351    gfc_expr *a1;
2352
2353    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2354      gfc_todo_error ("Non-IEEE floating format");
2355
2356    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2357
2358    arg = gfc_conv_intrinsic_function_args (se, expr);
2359    arg = TREE_VALUE (arg);
2360    rcs->type = TREE_TYPE (arg);
2361
2362    /* Force arg'type to integer by unaffected convert  */
2363    a1 = expr->value.function.actual->expr;
2364    masktype = gfc_get_int_type (a1->ts.kind);
2365    rcs->mtype = masktype;
2366    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2367    arg = gfc_create_var (masktype, "arg");
2368    gfc_add_modify_expr(&se->pre, arg, tmp);
2369    rcs->arg = arg;
2370
2371    /* Caculate the numbers of bits of exponent, fraction and word  */
2372    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2373    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2374    rcs->fdigits = convert (masktype, tmp);
2375    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2376    wbits = convert (masktype, wbits);
2377    rcs->edigits = fold (build2 (MINUS_EXPR, masktype, wbits, tmp));
2378
2379    /* Form masks for exponent/fraction/sign  */
2380    one = gfc_build_const (masktype, integer_one_node);
2381    rcs->smask = fold (build2 (LSHIFT_EXPR, masktype, one, wbits));
2382    rcs->f1 = fold (build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2383    rcs->emask = fold (build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2384    rcs->fmask = fold (build2 (MINUS_EXPR, masktype, rcs->f1, one));
2385    /* Form bias.  */
2386    tmp = fold (build2 (MINUS_EXPR, masktype, rcs->edigits, one));
2387    tmp = fold (build2 (LSHIFT_EXPR, masktype, one, tmp));
2388    rcs->bias = fold (build2 (MINUS_EXPR, masktype, tmp ,one));
2389
2390    if (all)
2391      {
2392        /* exponent, and fraction  */
2393        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2394        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2395        exponent = gfc_create_var (masktype, "exponent");
2396        gfc_add_modify_expr(&se->pre, exponent, tmp);
2397        rcs->expn = exponent;
2398
2399        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2400        fraction = gfc_create_var (masktype, "fraction");
2401        gfc_add_modify_expr(&se->pre, fraction, tmp);
2402        rcs->frac = fraction;
2403      }
2404 }
2405
2406 /* Build a call to __builtin_clz.  */
2407
2408 static tree
2409 call_builtin_clz (tree result_type, tree op0)
2410 {
2411   tree fn, parms, call;
2412   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2413
2414   if (op0_mode == TYPE_MODE (integer_type_node))
2415     fn = built_in_decls[BUILT_IN_CLZ];
2416   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2417     fn = built_in_decls[BUILT_IN_CLZL];
2418   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2419     fn = built_in_decls[BUILT_IN_CLZLL];
2420   else
2421     gcc_unreachable ();
2422
2423   parms = tree_cons (NULL, op0, NULL);
2424   call = gfc_build_function_call (fn, parms);
2425
2426   return convert (result_type, call);
2427 }
2428
2429
2430 /* Generate code for SPACING (X) intrinsic function.
2431    SPACING (X) = POW (2, e-p)
2432
2433    We generate:
2434
2435     t = expn - fdigits // e - p.
2436     res = t << fdigits // Form the exponent. Fraction is zero.
2437     if (t < 0) // The result is out of range. Denormalized case.
2438       res = tiny(X)
2439  */
2440
2441 static void
2442 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2443 {
2444    tree arg;
2445    tree masktype;
2446    tree tmp, t1, cond;
2447    tree tiny, zero;
2448    tree fdigits;
2449    real_compnt_info rcs;
2450
2451    prepare_arg_info (se, expr, &rcs, 0);
2452    arg = rcs.arg;
2453    masktype = rcs.mtype;
2454    fdigits = rcs.fdigits;
2455    tiny = rcs.f1;
2456    zero = gfc_build_const (masktype, integer_zero_node);
2457    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2458    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2459    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2460    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2461    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2462    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2463    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2464
2465    se->expr = tmp;
2466 }
2467
2468 /* Generate code for RRSPACING (X) intrinsic function.
2469    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2470
2471    So the result's exponent is p. And if X is normalized, X's fraction part
2472    is the result's fraction. If X is denormalized, to get the X's fraction we
2473    shift X's fraction part to left until the first '1' is removed.
2474
2475    We generate:
2476
2477     if (expn == 0 && frac == 0)
2478        res = 0;
2479     else
2480     {
2481        // edigits is the number of exponent bits. Add the sign bit.
2482        sedigits = edigits + 1;
2483
2484        if (expn == 0) // Denormalized case.
2485        {
2486          t1 = leadzero (frac);
2487          frac = frac << (t1 + 1); //Remove the first '1'.
2488          frac = frac >> (sedigits); //Form the fraction.
2489        }
2490
2491        //fdigits is the number of fraction bits. Form the exponent.
2492        t = bias + fdigits;
2493
2494        res = (t << fdigits) | frac;
2495     }
2496 */
2497
2498 static void
2499 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2500 {
2501    tree masktype;
2502    tree tmp, t1, t2, cond, cond2;
2503    tree one, zero;
2504    tree fdigits, fraction;
2505    real_compnt_info rcs;
2506
2507    prepare_arg_info (se, expr, &rcs, 1);
2508    masktype = rcs.mtype;
2509    fdigits = rcs.fdigits;
2510    fraction = rcs.frac;
2511    one = gfc_build_const (masktype, integer_one_node);
2512    zero = gfc_build_const (masktype, integer_zero_node);
2513    t2 = fold (build2 (PLUS_EXPR, masktype, rcs.edigits, one));
2514
2515    t1 = call_builtin_clz (masktype, fraction);
2516    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2517    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2518    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2519    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2520    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2521
2522    tmp = fold (build2 (PLUS_EXPR, masktype, rcs.bias, fdigits));
2523    tmp = fold (build2 (LSHIFT_EXPR, masktype, tmp, fdigits));
2524    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2525
2526    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2527    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2528    tmp = build3 (COND_EXPR, masktype, cond,
2529                  build_int_cst (masktype, 0), tmp);
2530
2531    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2532    se->expr = tmp;
2533 }
2534
2535 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2536
2537 static void
2538 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2539 {
2540   tree args;
2541
2542   args = gfc_conv_intrinsic_function_args (se, expr);
2543   args = TREE_VALUE (args);
2544   args = gfc_build_addr_expr (NULL, args);
2545   args = tree_cons (NULL_TREE, args, NULL_TREE);
2546   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2547 }
2548
2549 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2550
2551 static void
2552 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2553 {
2554   gfc_actual_arglist *actual;
2555   tree args;
2556   gfc_se argse;
2557
2558   args = NULL_TREE;
2559   for (actual = expr->value.function.actual; actual; actual = actual->next)
2560     {
2561       gfc_init_se (&argse, se);
2562
2563       /* Pass a NULL pointer for an absent arg.  */
2564       if (actual->expr == NULL)
2565         argse.expr = null_pointer_node;
2566       else
2567         gfc_conv_expr_reference (&argse, actual->expr);
2568
2569       gfc_add_block_to_block (&se->pre, &argse.pre);
2570       gfc_add_block_to_block (&se->post, &argse.post);
2571       args = gfc_chainon_list (args, argse.expr);
2572     }
2573   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2574 }
2575
2576
2577 /* Generate code for TRIM (A) intrinsic function.  */
2578
2579 static void
2580 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2581 {
2582   tree gfc_int4_type_node = gfc_get_int_type (4);
2583   tree var;
2584   tree len;
2585   tree addr;
2586   tree tmp;
2587   tree arglist;
2588   tree type;
2589   tree cond;
2590
2591   arglist = NULL_TREE;
2592
2593   type = build_pointer_type (gfc_character1_type_node);
2594   var = gfc_create_var (type, "pstr");
2595   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2596   len = gfc_create_var (gfc_int4_type_node, "len");
2597
2598   tmp = gfc_conv_intrinsic_function_args (se, expr);
2599   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2600   arglist = gfc_chainon_list (arglist, addr);
2601   arglist = chainon (arglist, tmp);
2602
2603   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2604   gfc_add_expr_to_block (&se->pre, tmp);
2605
2606   /* Free the temporary afterwards, if necessary.  */
2607   cond = build2 (GT_EXPR, boolean_type_node, len,
2608                  build_int_cst (TREE_TYPE (len), 0));
2609   arglist = gfc_chainon_list (NULL_TREE, var);
2610   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2611   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2612   gfc_add_expr_to_block (&se->post, tmp);
2613
2614   se->expr = var;
2615   se->string_length = len;
2616 }
2617
2618
2619 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2620
2621 static void
2622 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2623 {
2624   tree gfc_int4_type_node = gfc_get_int_type (4);
2625   tree tmp;
2626   tree len;
2627   tree args;
2628   tree arglist;
2629   tree ncopies;
2630   tree var;
2631   tree type;
2632
2633   args = gfc_conv_intrinsic_function_args (se, expr);
2634   len = TREE_VALUE (args);
2635   tmp = gfc_advance_chain (args, 2);
2636   ncopies = TREE_VALUE (tmp);
2637   len = fold (build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2638   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2639   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2640
2641   arglist = NULL_TREE;
2642   arglist = gfc_chainon_list (arglist, var);
2643   arglist = chainon (arglist, args);
2644   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2645   gfc_add_expr_to_block (&se->pre, tmp);
2646
2647   se->expr = var;
2648   se->string_length = len;
2649 }
2650
2651
2652 /* Generate code for the IARGC intrinsic.  If args_only is true this is
2653    actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1.  */
2654
2655 static void
2656 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
2657 {
2658   tree tmp;
2659   tree fndecl;
2660   tree type;
2661
2662   /* Call the library function.  This always returns an INTEGER(4).  */
2663   fndecl = gfor_fndecl_iargc;
2664   tmp = gfc_build_function_call (fndecl, NULL_TREE);
2665
2666   /* Convert it to the required type.  */
2667   type = gfc_typenode_for_spec (&expr->ts);
2668   tmp = fold_convert (type, tmp);
2669
2670   if (args_only)
2671     tmp = build2 (MINUS_EXPR, type, tmp, build_int_cst (type, 1));
2672   se->expr = tmp;
2673 }
2674
2675 /* Generate code for an intrinsic function.  Some map directly to library
2676    calls, others get special handling.  In some cases the name of the function
2677    used depends on the type specifiers.  */
2678
2679 void
2680 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2681 {
2682   gfc_intrinsic_sym *isym;
2683   const char *name;
2684   int lib;
2685
2686   isym = expr->value.function.isym;
2687
2688   name = &expr->value.function.name[2];
2689
2690   if (expr->rank > 0)
2691     {
2692       lib = gfc_is_intrinsic_libcall (expr);
2693       if (lib != 0)
2694         {
2695           if (lib == 1)
2696             se->ignore_optional = 1;
2697           gfc_conv_intrinsic_funcall (se, expr);
2698           return;
2699         }
2700     }
2701
2702   switch (expr->value.function.isym->generic_id)
2703     {
2704     case GFC_ISYM_NONE:
2705       gcc_unreachable ();
2706
2707     case GFC_ISYM_REPEAT:
2708       gfc_conv_intrinsic_repeat (se, expr);
2709       break;
2710
2711     case GFC_ISYM_TRIM:
2712       gfc_conv_intrinsic_trim (se, expr);
2713       break;
2714
2715     case GFC_ISYM_SI_KIND:
2716       gfc_conv_intrinsic_si_kind (se, expr);
2717       break;
2718
2719     case GFC_ISYM_SR_KIND:
2720       gfc_conv_intrinsic_sr_kind (se, expr);
2721       break;
2722
2723     case GFC_ISYM_EXPONENT:
2724       gfc_conv_intrinsic_exponent (se, expr);
2725       break;
2726
2727     case GFC_ISYM_SPACING:
2728       gfc_conv_intrinsic_spacing (se, expr);
2729       break;
2730
2731     case GFC_ISYM_RRSPACING:
2732       gfc_conv_intrinsic_rrspacing (se, expr);
2733       break;
2734
2735     case GFC_ISYM_SCAN:
2736       gfc_conv_intrinsic_scan (se, expr);
2737       break;
2738
2739     case GFC_ISYM_VERIFY:
2740       gfc_conv_intrinsic_verify (se, expr);
2741       break;
2742
2743     case GFC_ISYM_ALLOCATED:
2744       gfc_conv_allocated (se, expr);
2745       break;
2746
2747     case GFC_ISYM_ASSOCIATED:
2748       gfc_conv_associated(se, expr);
2749       break;
2750
2751     case GFC_ISYM_ABS:
2752       gfc_conv_intrinsic_abs (se, expr);
2753       break;
2754
2755     case GFC_ISYM_ADJUSTL:
2756       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2757       break;
2758
2759     case GFC_ISYM_ADJUSTR:
2760       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2761       break;
2762
2763     case GFC_ISYM_AIMAG:
2764       gfc_conv_intrinsic_imagpart (se, expr);
2765       break;
2766
2767     case GFC_ISYM_AINT:
2768       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2769       break;
2770
2771     case GFC_ISYM_ALL:
2772       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2773       break;
2774
2775     case GFC_ISYM_ANINT:
2776       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2777       break;
2778
2779     case GFC_ISYM_ANY:
2780       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2781       break;
2782
2783     case GFC_ISYM_BTEST:
2784       gfc_conv_intrinsic_btest (se, expr);
2785       break;
2786
2787     case GFC_ISYM_ACHAR:
2788     case GFC_ISYM_CHAR:
2789       gfc_conv_intrinsic_char (se, expr);
2790       break;
2791
2792     case GFC_ISYM_CONVERSION:
2793     case GFC_ISYM_REAL:
2794     case GFC_ISYM_LOGICAL:
2795     case GFC_ISYM_DBLE:
2796       gfc_conv_intrinsic_conversion (se, expr);
2797       break;
2798
2799       /* Integer conversions are handled seperately to make sure we get the
2800          correct rounding mode.  */
2801     case GFC_ISYM_INT:
2802       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2803       break;
2804
2805     case GFC_ISYM_NINT:
2806       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2807       break;
2808
2809     case GFC_ISYM_CEILING:
2810       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2811       break;
2812
2813     case GFC_ISYM_FLOOR:
2814       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2815       break;
2816
2817     case GFC_ISYM_MOD:
2818       gfc_conv_intrinsic_mod (se, expr, 0);
2819       break;
2820
2821     case GFC_ISYM_MODULO:
2822       gfc_conv_intrinsic_mod (se, expr, 1);
2823       break;
2824
2825     case GFC_ISYM_CMPLX:
2826       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2827       break;
2828
2829     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2830       gfc_conv_intrinsic_iargc (se, expr, TRUE);
2831       break;
2832
2833     case GFC_ISYM_CONJG:
2834       gfc_conv_intrinsic_conjg (se, expr);
2835       break;
2836
2837     case GFC_ISYM_COUNT:
2838       gfc_conv_intrinsic_count (se, expr);
2839       break;
2840
2841     case GFC_ISYM_DIM:
2842       gfc_conv_intrinsic_dim (se, expr);
2843       break;
2844
2845     case GFC_ISYM_DPROD:
2846       gfc_conv_intrinsic_dprod (se, expr);
2847       break;
2848
2849     case GFC_ISYM_IAND:
2850       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2851       break;
2852
2853     case GFC_ISYM_IBCLR:
2854       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2855       break;
2856
2857     case GFC_ISYM_IBITS:
2858       gfc_conv_intrinsic_ibits (se, expr);
2859       break;
2860
2861     case GFC_ISYM_IBSET:
2862       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2863       break;
2864
2865     case GFC_ISYM_IACHAR:
2866     case GFC_ISYM_ICHAR:
2867       /* We assume ASCII character sequence.  */
2868       gfc_conv_intrinsic_ichar (se, expr);
2869       break;
2870
2871     case GFC_ISYM_IARGC:
2872       gfc_conv_intrinsic_iargc (se, expr, FALSE);
2873       break;
2874
2875     case GFC_ISYM_IEOR:
2876       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2877       break;
2878
2879     case GFC_ISYM_INDEX:
2880       gfc_conv_intrinsic_index (se, expr);
2881       break;
2882
2883     case GFC_ISYM_IOR:
2884       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2885       break;
2886
2887     case GFC_ISYM_ISHFT:
2888       gfc_conv_intrinsic_ishft (se, expr);
2889       break;
2890
2891     case GFC_ISYM_ISHFTC:
2892       gfc_conv_intrinsic_ishftc (se, expr);
2893       break;
2894
2895     case GFC_ISYM_LBOUND:
2896       gfc_conv_intrinsic_bound (se, expr, 0);
2897       break;
2898
2899     case GFC_ISYM_LEN:
2900       gfc_conv_intrinsic_len (se, expr);
2901       break;
2902
2903     case GFC_ISYM_LEN_TRIM:
2904       gfc_conv_intrinsic_len_trim (se, expr);
2905       break;
2906
2907     case GFC_ISYM_LGE:
2908       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2909       break;
2910
2911     case GFC_ISYM_LGT:
2912       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2913       break;
2914
2915     case GFC_ISYM_LLE:
2916       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2917       break;
2918
2919     case GFC_ISYM_LLT:
2920       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2921       break;
2922
2923     case GFC_ISYM_MAX:
2924       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2925       break;
2926
2927     case GFC_ISYM_MAXLOC:
2928       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2929       break;
2930
2931     case GFC_ISYM_MAXVAL:
2932       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2933       break;
2934
2935     case GFC_ISYM_MERGE:
2936       gfc_conv_intrinsic_merge (se, expr);
2937       break;
2938
2939     case GFC_ISYM_MIN:
2940       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2941       break;
2942
2943     case GFC_ISYM_MINLOC:
2944       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2945       break;
2946
2947     case GFC_ISYM_MINVAL:
2948       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2949       break;
2950
2951     case GFC_ISYM_NOT:
2952       gfc_conv_intrinsic_not (se, expr);
2953       break;
2954
2955     case GFC_ISYM_PRESENT:
2956       gfc_conv_intrinsic_present (se, expr);
2957       break;
2958
2959     case GFC_ISYM_PRODUCT:
2960       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2961       break;
2962
2963     case GFC_ISYM_SIGN:
2964       gfc_conv_intrinsic_sign (se, expr);
2965       break;
2966
2967     case GFC_ISYM_SIZE:
2968       gfc_conv_intrinsic_size (se, expr);
2969       break;
2970
2971     case GFC_ISYM_SUM:
2972       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2973       break;
2974
2975     case GFC_ISYM_TRANSFER:
2976       gfc_conv_intrinsic_transfer (se, expr);
2977       break;
2978
2979     case GFC_ISYM_UBOUND:
2980       gfc_conv_intrinsic_bound (se, expr, 1);
2981       break;
2982
2983     case GFC_ISYM_DOT_PRODUCT:
2984     case GFC_ISYM_ETIME:
2985     case GFC_ISYM_FNUM:
2986     case GFC_ISYM_FSTAT:
2987     case GFC_ISYM_GETCWD:
2988     case GFC_ISYM_GETGID:
2989     case GFC_ISYM_GETPID:
2990     case GFC_ISYM_GETUID:
2991     case GFC_ISYM_IRAND:
2992     case GFC_ISYM_MATMUL:
2993     case GFC_ISYM_RAND:
2994     case GFC_ISYM_SECOND:
2995     case GFC_ISYM_STAT:
2996     case GFC_ISYM_SYSTEM:
2997     case GFC_ISYM_UMASK:
2998     case GFC_ISYM_UNLINK:
2999       gfc_conv_intrinsic_funcall (se, expr);
3000       break;
3001
3002     default:
3003       gfc_conv_intrinsic_lib_function (se, expr);
3004       break;
3005     }
3006 }
3007
3008
3009 /* This generates code to execute before entering the scalarization loop.
3010    Currently does nothing.  */
3011
3012 void
3013 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3014 {
3015   switch (ss->expr->value.function.isym->generic_id)
3016     {
3017     case GFC_ISYM_UBOUND:
3018     case GFC_ISYM_LBOUND:
3019       break;
3020
3021     default:
3022       gcc_unreachable ();
3023     }
3024 }
3025
3026
3027 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3028    inside the scalarization loop.  */
3029
3030 static gfc_ss *
3031 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3032 {
3033   gfc_ss *newss;
3034
3035   /* The two argument version returns a scalar.  */
3036   if (expr->value.function.actual->next->expr)
3037     return ss;
3038
3039   newss = gfc_get_ss ();
3040   newss->type = GFC_SS_INTRINSIC;
3041   newss->expr = expr;
3042   newss->next = ss;
3043
3044   return newss;
3045 }
3046
3047
3048 /* Walk an intrinsic array libcall.  */
3049
3050 static gfc_ss *
3051 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3052 {
3053   gfc_ss *newss;
3054
3055   gcc_assert (expr->rank > 0);
3056
3057   newss = gfc_get_ss ();
3058   newss->type = GFC_SS_FUNCTION;
3059   newss->expr = expr;
3060   newss->next = ss;
3061   newss->data.info.dimen = expr->rank;
3062
3063   return newss;
3064 }
3065
3066
3067 /* Returns nonzero if the specified intrinsic function call maps directly to a
3068    an external library call.  Should only be used for functions that return
3069    arrays.  */
3070
3071 int
3072 gfc_is_intrinsic_libcall (gfc_expr * expr)
3073 {
3074   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3075   gcc_assert (expr->rank > 0);
3076
3077   switch (expr->value.function.isym->generic_id)
3078     {
3079     case GFC_ISYM_ALL:
3080     case GFC_ISYM_ANY:
3081     case GFC_ISYM_COUNT:
3082     case GFC_ISYM_MATMUL:
3083     case GFC_ISYM_MAXLOC:
3084     case GFC_ISYM_MAXVAL:
3085     case GFC_ISYM_MINLOC:
3086     case GFC_ISYM_MINVAL:
3087     case GFC_ISYM_PRODUCT:
3088     case GFC_ISYM_SUM:
3089     case GFC_ISYM_SHAPE:
3090     case GFC_ISYM_SPREAD:
3091     case GFC_ISYM_TRANSPOSE:
3092       /* Ignore absent optional parameters.  */
3093       return 1;
3094
3095     case GFC_ISYM_RESHAPE:
3096     case GFC_ISYM_CSHIFT:
3097     case GFC_ISYM_EOSHIFT:
3098     case GFC_ISYM_PACK:
3099     case GFC_ISYM_UNPACK:
3100       /* Pass absent optional parameters.  */
3101       return 2;
3102
3103     default:
3104       return 0;
3105     }
3106 }
3107
3108 /* Walk an intrinsic function.  */
3109 gfc_ss *
3110 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3111                              gfc_intrinsic_sym * isym)
3112 {
3113   gcc_assert (isym);
3114
3115   if (isym->elemental)
3116     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
3117
3118   if (expr->rank == 0)
3119     return ss;
3120
3121   if (gfc_is_intrinsic_libcall (expr))
3122     return gfc_walk_intrinsic_libfunc (ss, expr);
3123
3124   /* Special cases.  */
3125   switch (isym->generic_id)
3126     {
3127     case GFC_ISYM_LBOUND:
3128     case GFC_ISYM_UBOUND:
3129       return gfc_walk_intrinsic_bound (ss, expr);
3130
3131     default:
3132       /* This probably meant someone forgot to add an intrinsic to the above
3133          list(s) when they implemented it, or something's gone horribly wrong.
3134        */
3135       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3136                       expr->value.function.name);
3137     }
3138 }
3139
3140 #include "gt-fortran-trans-intrinsic.h"