gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005 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    /* Calculate 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.  */
2653
2654 static void
2655 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
2656 {
2657   tree tmp;
2658   tree fndecl;
2659   tree type;
2660
2661   /* Call the library function.  This always returns an INTEGER(4).  */
2662   fndecl = gfor_fndecl_iargc;
2663   tmp = gfc_build_function_call (fndecl, NULL_TREE);
2664
2665   /* Convert it to the required type.  */
2666   type = gfc_typenode_for_spec (&expr->ts);
2667   tmp = fold_convert (type, tmp);
2668
2669   se->expr = tmp;
2670 }
2671
2672 /* Generate code for an intrinsic function.  Some map directly to library
2673    calls, others get special handling.  In some cases the name of the function
2674    used depends on the type specifiers.  */
2675
2676 void
2677 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2678 {
2679   gfc_intrinsic_sym *isym;
2680   const char *name;
2681   int lib;
2682
2683   isym = expr->value.function.isym;
2684
2685   name = &expr->value.function.name[2];
2686
2687   if (expr->rank > 0)
2688     {
2689       lib = gfc_is_intrinsic_libcall (expr);
2690       if (lib != 0)
2691         {
2692           if (lib == 1)
2693             se->ignore_optional = 1;
2694           gfc_conv_intrinsic_funcall (se, expr);
2695           return;
2696         }
2697     }
2698
2699   switch (expr->value.function.isym->generic_id)
2700     {
2701     case GFC_ISYM_NONE:
2702       gcc_unreachable ();
2703
2704     case GFC_ISYM_REPEAT:
2705       gfc_conv_intrinsic_repeat (se, expr);
2706       break;
2707
2708     case GFC_ISYM_TRIM:
2709       gfc_conv_intrinsic_trim (se, expr);
2710       break;
2711
2712     case GFC_ISYM_SI_KIND:
2713       gfc_conv_intrinsic_si_kind (se, expr);
2714       break;
2715
2716     case GFC_ISYM_SR_KIND:
2717       gfc_conv_intrinsic_sr_kind (se, expr);
2718       break;
2719
2720     case GFC_ISYM_EXPONENT:
2721       gfc_conv_intrinsic_exponent (se, expr);
2722       break;
2723
2724     case GFC_ISYM_SPACING:
2725       gfc_conv_intrinsic_spacing (se, expr);
2726       break;
2727
2728     case GFC_ISYM_RRSPACING:
2729       gfc_conv_intrinsic_rrspacing (se, expr);
2730       break;
2731
2732     case GFC_ISYM_SCAN:
2733       gfc_conv_intrinsic_scan (se, expr);
2734       break;
2735
2736     case GFC_ISYM_VERIFY:
2737       gfc_conv_intrinsic_verify (se, expr);
2738       break;
2739
2740     case GFC_ISYM_ALLOCATED:
2741       gfc_conv_allocated (se, expr);
2742       break;
2743
2744     case GFC_ISYM_ASSOCIATED:
2745       gfc_conv_associated(se, expr);
2746       break;
2747
2748     case GFC_ISYM_ABS:
2749       gfc_conv_intrinsic_abs (se, expr);
2750       break;
2751
2752     case GFC_ISYM_ADJUSTL:
2753       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2754       break;
2755
2756     case GFC_ISYM_ADJUSTR:
2757       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2758       break;
2759
2760     case GFC_ISYM_AIMAG:
2761       gfc_conv_intrinsic_imagpart (se, expr);
2762       break;
2763
2764     case GFC_ISYM_AINT:
2765       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2766       break;
2767
2768     case GFC_ISYM_ALL:
2769       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2770       break;
2771
2772     case GFC_ISYM_ANINT:
2773       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2774       break;
2775
2776     case GFC_ISYM_ANY:
2777       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2778       break;
2779
2780     case GFC_ISYM_BTEST:
2781       gfc_conv_intrinsic_btest (se, expr);
2782       break;
2783
2784     case GFC_ISYM_ACHAR:
2785     case GFC_ISYM_CHAR:
2786       gfc_conv_intrinsic_char (se, expr);
2787       break;
2788
2789     case GFC_ISYM_CONVERSION:
2790     case GFC_ISYM_REAL:
2791     case GFC_ISYM_LOGICAL:
2792     case GFC_ISYM_DBLE:
2793       gfc_conv_intrinsic_conversion (se, expr);
2794       break;
2795
2796       /* Integer conversions are handled separately to make sure we get the
2797          correct rounding mode.  */
2798     case GFC_ISYM_INT:
2799       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2800       break;
2801
2802     case GFC_ISYM_NINT:
2803       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2804       break;
2805
2806     case GFC_ISYM_CEILING:
2807       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2808       break;
2809
2810     case GFC_ISYM_FLOOR:
2811       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2812       break;
2813
2814     case GFC_ISYM_MOD:
2815       gfc_conv_intrinsic_mod (se, expr, 0);
2816       break;
2817
2818     case GFC_ISYM_MODULO:
2819       gfc_conv_intrinsic_mod (se, expr, 1);
2820       break;
2821
2822     case GFC_ISYM_CMPLX:
2823       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2824       break;
2825
2826     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2827       gfc_conv_intrinsic_iargc (se, expr);
2828       break;
2829
2830     case GFC_ISYM_CONJG:
2831       gfc_conv_intrinsic_conjg (se, expr);
2832       break;
2833
2834     case GFC_ISYM_COUNT:
2835       gfc_conv_intrinsic_count (se, expr);
2836       break;
2837
2838     case GFC_ISYM_DIM:
2839       gfc_conv_intrinsic_dim (se, expr);
2840       break;
2841
2842     case GFC_ISYM_DPROD:
2843       gfc_conv_intrinsic_dprod (se, expr);
2844       break;
2845
2846     case GFC_ISYM_IAND:
2847       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2848       break;
2849
2850     case GFC_ISYM_IBCLR:
2851       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2852       break;
2853
2854     case GFC_ISYM_IBITS:
2855       gfc_conv_intrinsic_ibits (se, expr);
2856       break;
2857
2858     case GFC_ISYM_IBSET:
2859       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2860       break;
2861
2862     case GFC_ISYM_IACHAR:
2863     case GFC_ISYM_ICHAR:
2864       /* We assume ASCII character sequence.  */
2865       gfc_conv_intrinsic_ichar (se, expr);
2866       break;
2867
2868     case GFC_ISYM_IARGC:
2869       gfc_conv_intrinsic_iargc (se, expr);
2870       break;
2871
2872     case GFC_ISYM_IEOR:
2873       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2874       break;
2875
2876     case GFC_ISYM_INDEX:
2877       gfc_conv_intrinsic_index (se, expr);
2878       break;
2879
2880     case GFC_ISYM_IOR:
2881       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2882       break;
2883
2884     case GFC_ISYM_ISHFT:
2885       gfc_conv_intrinsic_ishft (se, expr);
2886       break;
2887
2888     case GFC_ISYM_ISHFTC:
2889       gfc_conv_intrinsic_ishftc (se, expr);
2890       break;
2891
2892     case GFC_ISYM_LBOUND:
2893       gfc_conv_intrinsic_bound (se, expr, 0);
2894       break;
2895
2896     case GFC_ISYM_LEN:
2897       gfc_conv_intrinsic_len (se, expr);
2898       break;
2899
2900     case GFC_ISYM_LEN_TRIM:
2901       gfc_conv_intrinsic_len_trim (se, expr);
2902       break;
2903
2904     case GFC_ISYM_LGE:
2905       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2906       break;
2907
2908     case GFC_ISYM_LGT:
2909       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2910       break;
2911
2912     case GFC_ISYM_LLE:
2913       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2914       break;
2915
2916     case GFC_ISYM_LLT:
2917       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2918       break;
2919
2920     case GFC_ISYM_MAX:
2921       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2922       break;
2923
2924     case GFC_ISYM_MAXLOC:
2925       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2926       break;
2927
2928     case GFC_ISYM_MAXVAL:
2929       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2930       break;
2931
2932     case GFC_ISYM_MERGE:
2933       gfc_conv_intrinsic_merge (se, expr);
2934       break;
2935
2936     case GFC_ISYM_MIN:
2937       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2938       break;
2939
2940     case GFC_ISYM_MINLOC:
2941       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2942       break;
2943
2944     case GFC_ISYM_MINVAL:
2945       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2946       break;
2947
2948     case GFC_ISYM_NOT:
2949       gfc_conv_intrinsic_not (se, expr);
2950       break;
2951
2952     case GFC_ISYM_PRESENT:
2953       gfc_conv_intrinsic_present (se, expr);
2954       break;
2955
2956     case GFC_ISYM_PRODUCT:
2957       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2958       break;
2959
2960     case GFC_ISYM_SIGN:
2961       gfc_conv_intrinsic_sign (se, expr);
2962       break;
2963
2964     case GFC_ISYM_SIZE:
2965       gfc_conv_intrinsic_size (se, expr);
2966       break;
2967
2968     case GFC_ISYM_SUM:
2969       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2970       break;
2971
2972     case GFC_ISYM_TRANSFER:
2973       gfc_conv_intrinsic_transfer (se, expr);
2974       break;
2975
2976     case GFC_ISYM_UBOUND:
2977       gfc_conv_intrinsic_bound (se, expr, 1);
2978       break;
2979
2980     case GFC_ISYM_DOT_PRODUCT:
2981     case GFC_ISYM_ETIME:
2982     case GFC_ISYM_FNUM:
2983     case GFC_ISYM_FSTAT:
2984     case GFC_ISYM_GETCWD:
2985     case GFC_ISYM_GETGID:
2986     case GFC_ISYM_GETPID:
2987     case GFC_ISYM_GETUID:
2988     case GFC_ISYM_IRAND:
2989     case GFC_ISYM_MATMUL:
2990     case GFC_ISYM_RAND:
2991     case GFC_ISYM_SECOND:
2992     case GFC_ISYM_STAT:
2993     case GFC_ISYM_SYSTEM:
2994     case GFC_ISYM_UMASK:
2995     case GFC_ISYM_UNLINK:
2996       gfc_conv_intrinsic_funcall (se, expr);
2997       break;
2998
2999     default:
3000       gfc_conv_intrinsic_lib_function (se, expr);
3001       break;
3002     }
3003 }
3004
3005
3006 /* This generates code to execute before entering the scalarization loop.
3007    Currently does nothing.  */
3008
3009 void
3010 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3011 {
3012   switch (ss->expr->value.function.isym->generic_id)
3013     {
3014     case GFC_ISYM_UBOUND:
3015     case GFC_ISYM_LBOUND:
3016       break;
3017
3018     default:
3019       gcc_unreachable ();
3020     }
3021 }
3022
3023
3024 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3025    inside the scalarization loop.  */
3026
3027 static gfc_ss *
3028 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3029 {
3030   gfc_ss *newss;
3031
3032   /* The two argument version returns a scalar.  */
3033   if (expr->value.function.actual->next->expr)
3034     return ss;
3035
3036   newss = gfc_get_ss ();
3037   newss->type = GFC_SS_INTRINSIC;
3038   newss->expr = expr;
3039   newss->next = ss;
3040
3041   return newss;
3042 }
3043
3044
3045 /* Walk an intrinsic array libcall.  */
3046
3047 static gfc_ss *
3048 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3049 {
3050   gfc_ss *newss;
3051
3052   gcc_assert (expr->rank > 0);
3053
3054   newss = gfc_get_ss ();
3055   newss->type = GFC_SS_FUNCTION;
3056   newss->expr = expr;
3057   newss->next = ss;
3058   newss->data.info.dimen = expr->rank;
3059
3060   return newss;
3061 }
3062
3063
3064 /* Returns nonzero if the specified intrinsic function call maps directly to a
3065    an external library call.  Should only be used for functions that return
3066    arrays.  */
3067
3068 int
3069 gfc_is_intrinsic_libcall (gfc_expr * expr)
3070 {
3071   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3072   gcc_assert (expr->rank > 0);
3073
3074   switch (expr->value.function.isym->generic_id)
3075     {
3076     case GFC_ISYM_ALL:
3077     case GFC_ISYM_ANY:
3078     case GFC_ISYM_COUNT:
3079     case GFC_ISYM_MATMUL:
3080     case GFC_ISYM_MAXLOC:
3081     case GFC_ISYM_MAXVAL:
3082     case GFC_ISYM_MINLOC:
3083     case GFC_ISYM_MINVAL:
3084     case GFC_ISYM_PRODUCT:
3085     case GFC_ISYM_SUM:
3086     case GFC_ISYM_SHAPE:
3087     case GFC_ISYM_SPREAD:
3088     case GFC_ISYM_TRANSPOSE:
3089       /* Ignore absent optional parameters.  */
3090       return 1;
3091
3092     case GFC_ISYM_RESHAPE:
3093     case GFC_ISYM_CSHIFT:
3094     case GFC_ISYM_EOSHIFT:
3095     case GFC_ISYM_PACK:
3096     case GFC_ISYM_UNPACK:
3097       /* Pass absent optional parameters.  */
3098       return 2;
3099
3100     default:
3101       return 0;
3102     }
3103 }
3104
3105 /* Walk an intrinsic function.  */
3106 gfc_ss *
3107 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3108                              gfc_intrinsic_sym * isym)
3109 {
3110   gcc_assert (isym);
3111
3112   if (isym->elemental)
3113     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
3114
3115   if (expr->rank == 0)
3116     return ss;
3117
3118   if (gfc_is_intrinsic_libcall (expr))
3119     return gfc_walk_intrinsic_libfunc (ss, expr);
3120
3121   /* Special cases.  */
3122   switch (isym->generic_id)
3123     {
3124     case GFC_ISYM_LBOUND:
3125     case GFC_ISYM_UBOUND:
3126       return gfc_walk_intrinsic_bound (ss, expr);
3127
3128     default:
3129       /* This probably meant someone forgot to add an intrinsic to the above
3130          list(s) when they implemented it, or something's gone horribly wrong.
3131        */
3132       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3133                       expr->value.function.name);
3134     }
3135 }
3136
3137 #include "gt-fortran-trans-intrinsic.h"