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