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