gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 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 = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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, build_fold_addr_expr (var));
1057   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1058   arglist = chainon (arglist, tmp);
1059
1060   tmp = build_function_call_expr (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 = build_function_call_expr (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, build_fold_addr_expr (var));
1093   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1094   arglist = chainon (arglist, tmp);
1095
1096   tmp = build_function_call_expr (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 = build_function_call_expr (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, build_fold_addr_expr (var));
1131   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1132   arglist = chainon (arglist, tmp);
1133
1134   tmp = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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 = build_function_call_expr (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 = build_fold_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 = build_function_call_expr (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   tree arg2;
2271
2272   args = gfc_conv_intrinsic_function_args (se, expr);
2273   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2274
2275   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2276                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2277                 TREE_VALUE (TREE_CHAIN (arg2)));
2278
2279   type = gfc_typenode_for_spec (&expr->ts);
2280   se->expr = fold_build2 (op, type, se->expr,
2281                      build_int_cst (TREE_TYPE (se->expr), 0));
2282 }
2283
2284 /* Generate a call to the adjustl/adjustr library function.  */
2285 static void
2286 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2287 {
2288   tree args;
2289   tree len;
2290   tree type;
2291   tree var;
2292   tree tmp;
2293
2294   args = gfc_conv_intrinsic_function_args (se, expr);
2295   len = TREE_VALUE (args);
2296
2297   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2298   var = gfc_conv_string_tmp (se, type, len);
2299   args = tree_cons (NULL_TREE, var, args);
2300
2301   tmp = build_function_call_expr (fndecl, args);
2302   gfc_add_expr_to_block (&se->pre, tmp);
2303   se->expr = var;
2304   se->string_length = len;
2305 }
2306
2307
2308 /* Scalar transfer statement.
2309    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
2310
2311 static void
2312 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2313 {
2314   gfc_actual_arglist *arg;
2315   gfc_se argse;
2316   tree type;
2317   tree ptr;
2318   gfc_ss *ss;
2319
2320   gcc_assert (!se->ss);
2321
2322   /* Get a pointer to the source.  */
2323   arg = expr->value.function.actual;
2324   ss = gfc_walk_expr (arg->expr);
2325   gfc_init_se (&argse, NULL);
2326   if (ss == gfc_ss_terminator)
2327     gfc_conv_expr_reference (&argse, arg->expr);
2328   else
2329     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2330   gfc_add_block_to_block (&se->pre, &argse.pre);
2331   gfc_add_block_to_block (&se->post, &argse.post);
2332   ptr = argse.expr;
2333
2334   arg = arg->next;
2335   type = gfc_typenode_for_spec (&expr->ts);
2336   ptr = convert (build_pointer_type (type), ptr);
2337   if (expr->ts.type == BT_CHARACTER)
2338     {
2339       gfc_init_se (&argse, NULL);
2340       gfc_conv_expr (&argse, arg->expr);
2341       gfc_add_block_to_block (&se->pre, &argse.pre);
2342       gfc_add_block_to_block (&se->post, &argse.post);
2343       se->expr = ptr;
2344       se->string_length = argse.string_length;
2345     }
2346   else
2347     {
2348       se->expr = build_fold_indirect_ref (ptr);
2349     }
2350 }
2351
2352
2353 /* Generate code for the ALLOCATED intrinsic.
2354    Generate inline code that directly check the address of the argument.  */
2355
2356 static void
2357 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2358 {
2359   gfc_actual_arglist *arg1;
2360   gfc_se arg1se;
2361   gfc_ss *ss1;
2362   tree tmp;
2363
2364   gfc_init_se (&arg1se, NULL);
2365   arg1 = expr->value.function.actual;
2366   ss1 = gfc_walk_expr (arg1->expr);
2367   arg1se.descriptor_only = 1;
2368   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2369
2370   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2371   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2372                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2373   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2374 }
2375
2376
2377 /* Generate code for the ASSOCIATED intrinsic.
2378    If both POINTER and TARGET are arrays, generate a call to library function
2379    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2380    In other cases, generate inline code that directly compare the address of
2381    POINTER with the address of TARGET.  */
2382
2383 static void
2384 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2385 {
2386   gfc_actual_arglist *arg1;
2387   gfc_actual_arglist *arg2;
2388   gfc_se arg1se;
2389   gfc_se arg2se;
2390   tree tmp2;
2391   tree tmp;
2392   tree args, fndecl;
2393   gfc_ss *ss1, *ss2;
2394
2395   gfc_init_se (&arg1se, NULL);
2396   gfc_init_se (&arg2se, NULL);
2397   arg1 = expr->value.function.actual;
2398   arg2 = arg1->next;
2399   ss1 = gfc_walk_expr (arg1->expr);
2400
2401   if (!arg2->expr)
2402     {
2403       /* No optional target.  */
2404       if (ss1 == gfc_ss_terminator)
2405         {
2406           /* A pointer to a scalar.  */
2407           arg1se.want_pointer = 1;
2408           gfc_conv_expr (&arg1se, arg1->expr);
2409           tmp2 = arg1se.expr;
2410         }
2411       else
2412         {
2413           /* A pointer to an array.  */
2414           arg1se.descriptor_only = 1;
2415           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2416           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
2417         }
2418       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2419                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2420       se->expr = tmp;
2421     }
2422   else
2423     {
2424       /* An optional target.  */
2425       ss2 = gfc_walk_expr (arg2->expr);
2426       if (ss1 == gfc_ss_terminator)
2427         {
2428           /* A pointer to a scalar.  */
2429           gcc_assert (ss2 == gfc_ss_terminator);
2430           arg1se.want_pointer = 1;
2431           gfc_conv_expr (&arg1se, arg1->expr);
2432           arg2se.want_pointer = 1;
2433           gfc_conv_expr (&arg2se, arg2->expr);
2434           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2435           se->expr = tmp;
2436         }
2437       else
2438         {
2439           /* A pointer to an array, call library function _gfor_associated.  */
2440           gcc_assert (ss2 != gfc_ss_terminator);
2441           args = NULL_TREE;
2442           arg1se.want_pointer = 1;
2443           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2444           args = gfc_chainon_list (args, arg1se.expr);
2445           arg2se.want_pointer = 1;
2446           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2447           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2448           gfc_add_block_to_block (&se->post, &arg2se.post);
2449           args = gfc_chainon_list (args, arg2se.expr);
2450           fndecl = gfor_fndecl_associated;
2451           se->expr = build_function_call_expr (fndecl, args);
2452         }
2453      }
2454   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2455 }
2456
2457
2458 /* Scan a string for any one of the characters in a set of characters.  */
2459
2460 static void
2461 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2462 {
2463   tree logical4_type_node = gfc_get_logical_type (4);
2464   tree args;
2465   tree back;
2466   tree type;
2467   tree tmp;
2468
2469   args = gfc_conv_intrinsic_function_args (se, expr);
2470   type = gfc_typenode_for_spec (&expr->ts);
2471   tmp = gfc_advance_chain (args, 3);
2472   if (TREE_CHAIN (tmp) == NULL_TREE)
2473     {
2474       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2475                         NULL_TREE);
2476       TREE_CHAIN (tmp) = back;
2477     }
2478   else
2479     {
2480       back = TREE_CHAIN (tmp);
2481       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2482     }
2483
2484   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2485   se->expr = convert (type, se->expr);
2486 }
2487
2488
2489 /* Verify that a set of characters contains all the characters in a string
2490    by identifying the position of the first character in a string of
2491    characters that does not appear in a given set of characters.  */
2492
2493 static void
2494 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2495 {
2496   tree logical4_type_node = gfc_get_logical_type (4);
2497   tree args;
2498   tree back;
2499   tree type;
2500   tree tmp;
2501
2502   args = gfc_conv_intrinsic_function_args (se, expr);
2503   type = gfc_typenode_for_spec (&expr->ts);
2504   tmp = gfc_advance_chain (args, 3);
2505   if (TREE_CHAIN (tmp) == NULL_TREE)
2506     {
2507       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2508                         NULL_TREE);
2509       TREE_CHAIN (tmp) = back;
2510     }
2511   else
2512     {
2513       back = TREE_CHAIN (tmp);
2514       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2515     }
2516
2517   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2518   se->expr = convert (type, se->expr);
2519 }
2520
2521 /* Prepare components and related information of a real number which is
2522    the first argument of a elemental functions to manipulate reals.  */
2523
2524 static void
2525 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2526                   real_compnt_info * rcs, int all)
2527 {
2528    tree arg;
2529    tree masktype;
2530    tree tmp;
2531    tree wbits;
2532    tree one;
2533    tree exponent, fraction;
2534    int n;
2535    gfc_expr *a1;
2536
2537    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2538      gfc_todo_error ("Non-IEEE floating format");
2539
2540    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2541
2542    arg = gfc_conv_intrinsic_function_args (se, expr);
2543    arg = TREE_VALUE (arg);
2544    rcs->type = TREE_TYPE (arg);
2545
2546    /* Force arg'type to integer by unaffected convert  */
2547    a1 = expr->value.function.actual->expr;
2548    masktype = gfc_get_int_type (a1->ts.kind);
2549    rcs->mtype = masktype;
2550    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2551    arg = gfc_create_var (masktype, "arg");
2552    gfc_add_modify_expr(&se->pre, arg, tmp);
2553    rcs->arg = arg;
2554
2555    /* Calculate the numbers of bits of exponent, fraction and word  */
2556    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2557    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2558    rcs->fdigits = convert (masktype, tmp);
2559    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2560    wbits = convert (masktype, wbits);
2561    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
2562
2563    /* Form masks for exponent/fraction/sign  */
2564    one = gfc_build_const (masktype, integer_one_node);
2565    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
2566    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
2567    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
2568    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
2569    /* Form bias.  */
2570    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
2571    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
2572    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
2573
2574    if (all)
2575      {
2576        /* exponent, and fraction  */
2577        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2578        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2579        exponent = gfc_create_var (masktype, "exponent");
2580        gfc_add_modify_expr(&se->pre, exponent, tmp);
2581        rcs->expn = exponent;
2582
2583        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2584        fraction = gfc_create_var (masktype, "fraction");
2585        gfc_add_modify_expr(&se->pre, fraction, tmp);
2586        rcs->frac = fraction;
2587      }
2588 }
2589
2590 /* Build a call to __builtin_clz.  */
2591
2592 static tree
2593 call_builtin_clz (tree result_type, tree op0)
2594 {
2595   tree fn, parms, call;
2596   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2597
2598   if (op0_mode == TYPE_MODE (integer_type_node))
2599     fn = built_in_decls[BUILT_IN_CLZ];
2600   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2601     fn = built_in_decls[BUILT_IN_CLZL];
2602   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2603     fn = built_in_decls[BUILT_IN_CLZLL];
2604   else
2605     gcc_unreachable ();
2606
2607   parms = tree_cons (NULL, op0, NULL);
2608   call = build_function_call_expr (fn, parms);
2609
2610   return convert (result_type, call);
2611 }
2612
2613
2614 /* Generate code for SPACING (X) intrinsic function.
2615    SPACING (X) = POW (2, e-p)
2616
2617    We generate:
2618
2619     t = expn - fdigits // e - p.
2620     res = t << fdigits // Form the exponent. Fraction is zero.
2621     if (t < 0) // The result is out of range. Denormalized case.
2622       res = tiny(X)
2623  */
2624
2625 static void
2626 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2627 {
2628    tree arg;
2629    tree masktype;
2630    tree tmp, t1, cond;
2631    tree tiny, zero;
2632    tree fdigits;
2633    real_compnt_info rcs;
2634
2635    prepare_arg_info (se, expr, &rcs, 0);
2636    arg = rcs.arg;
2637    masktype = rcs.mtype;
2638    fdigits = rcs.fdigits;
2639    tiny = rcs.f1;
2640    zero = gfc_build_const (masktype, integer_zero_node);
2641    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2642    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2643    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2644    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2645    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2646    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2647    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2648
2649    se->expr = tmp;
2650 }
2651
2652 /* Generate code for RRSPACING (X) intrinsic function.
2653    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2654
2655    So the result's exponent is p. And if X is normalized, X's fraction part
2656    is the result's fraction. If X is denormalized, to get the X's fraction we
2657    shift X's fraction part to left until the first '1' is removed.
2658
2659    We generate:
2660
2661     if (expn == 0 && frac == 0)
2662        res = 0;
2663     else
2664     {
2665        // edigits is the number of exponent bits. Add the sign bit.
2666        sedigits = edigits + 1;
2667
2668        if (expn == 0) // Denormalized case.
2669        {
2670          t1 = leadzero (frac);
2671          frac = frac << (t1 + 1); //Remove the first '1'.
2672          frac = frac >> (sedigits); //Form the fraction.
2673        }
2674
2675        //fdigits is the number of fraction bits. Form the exponent.
2676        t = bias + fdigits;
2677
2678        res = (t << fdigits) | frac;
2679     }
2680 */
2681
2682 static void
2683 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2684 {
2685    tree masktype;
2686    tree tmp, t1, t2, cond, cond2;
2687    tree one, zero;
2688    tree fdigits, fraction;
2689    real_compnt_info rcs;
2690
2691    prepare_arg_info (se, expr, &rcs, 1);
2692    masktype = rcs.mtype;
2693    fdigits = rcs.fdigits;
2694    fraction = rcs.frac;
2695    one = gfc_build_const (masktype, integer_one_node);
2696    zero = gfc_build_const (masktype, integer_zero_node);
2697    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
2698
2699    t1 = call_builtin_clz (masktype, fraction);
2700    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2701    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2702    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2703    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2704    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2705
2706    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
2707    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2708    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2709
2710    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2711    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2712    tmp = build3 (COND_EXPR, masktype, cond,
2713                  build_int_cst (masktype, 0), tmp);
2714
2715    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2716    se->expr = tmp;
2717 }
2718
2719 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2720
2721 static void
2722 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2723 {
2724   tree args;
2725
2726   args = gfc_conv_intrinsic_function_args (se, expr);
2727   args = TREE_VALUE (args);
2728   args = build_fold_addr_expr (args);
2729   args = tree_cons (NULL_TREE, args, NULL_TREE);
2730   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
2731 }
2732
2733 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2734
2735 static void
2736 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2737 {
2738   gfc_actual_arglist *actual;
2739   tree args;
2740   gfc_se argse;
2741
2742   args = NULL_TREE;
2743   for (actual = expr->value.function.actual; actual; actual = actual->next)
2744     {
2745       gfc_init_se (&argse, se);
2746
2747       /* Pass a NULL pointer for an absent arg.  */
2748       if (actual->expr == NULL)
2749         argse.expr = null_pointer_node;
2750       else
2751         gfc_conv_expr_reference (&argse, actual->expr);
2752
2753       gfc_add_block_to_block (&se->pre, &argse.pre);
2754       gfc_add_block_to_block (&se->post, &argse.post);
2755       args = gfc_chainon_list (args, argse.expr);
2756     }
2757   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
2758 }
2759
2760
2761 /* Generate code for TRIM (A) intrinsic function.  */
2762
2763 static void
2764 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2765 {
2766   tree gfc_int4_type_node = gfc_get_int_type (4);
2767   tree var;
2768   tree len;
2769   tree addr;
2770   tree tmp;
2771   tree arglist;
2772   tree type;
2773   tree cond;
2774
2775   arglist = NULL_TREE;
2776
2777   type = build_pointer_type (gfc_character1_type_node);
2778   var = gfc_create_var (type, "pstr");
2779   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2780   len = gfc_create_var (gfc_int4_type_node, "len");
2781
2782   tmp = gfc_conv_intrinsic_function_args (se, expr);
2783   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
2784   arglist = gfc_chainon_list (arglist, addr);
2785   arglist = chainon (arglist, tmp);
2786
2787   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
2788   gfc_add_expr_to_block (&se->pre, tmp);
2789
2790   /* Free the temporary afterwards, if necessary.  */
2791   cond = build2 (GT_EXPR, boolean_type_node, len,
2792                  build_int_cst (TREE_TYPE (len), 0));
2793   arglist = gfc_chainon_list (NULL_TREE, var);
2794   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
2795   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2796   gfc_add_expr_to_block (&se->post, tmp);
2797
2798   se->expr = var;
2799   se->string_length = len;
2800 }
2801
2802
2803 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2804
2805 static void
2806 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2807 {
2808   tree gfc_int4_type_node = gfc_get_int_type (4);
2809   tree tmp;
2810   tree len;
2811   tree args;
2812   tree arglist;
2813   tree ncopies;
2814   tree var;
2815   tree type;
2816
2817   args = gfc_conv_intrinsic_function_args (se, expr);
2818   len = TREE_VALUE (args);
2819   tmp = gfc_advance_chain (args, 2);
2820   ncopies = TREE_VALUE (tmp);
2821   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
2822   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2823   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2824
2825   arglist = NULL_TREE;
2826   arglist = gfc_chainon_list (arglist, var);
2827   arglist = chainon (arglist, args);
2828   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
2829   gfc_add_expr_to_block (&se->pre, tmp);
2830
2831   se->expr = var;
2832   se->string_length = len;
2833 }
2834
2835
2836 /* Generate code for the IARGC intrinsic.  */
2837
2838 static void
2839 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
2840 {
2841   tree tmp;
2842   tree fndecl;
2843   tree type;
2844
2845   /* Call the library function.  This always returns an INTEGER(4).  */
2846   fndecl = gfor_fndecl_iargc;
2847   tmp = build_function_call_expr (fndecl, NULL_TREE);
2848
2849   /* Convert it to the required type.  */
2850   type = gfc_typenode_for_spec (&expr->ts);
2851   tmp = fold_convert (type, tmp);
2852
2853   se->expr = tmp;
2854 }
2855
2856
2857 /* The loc intrinsic returns the address of its argument as
2858    gfc_index_integer_kind integer.  */
2859
2860 static void
2861 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
2862 {
2863   tree temp_var;
2864   gfc_expr *arg_expr;
2865   gfc_ss *ss;
2866
2867   gcc_assert (!se->ss);
2868
2869   arg_expr = expr->value.function.actual->expr;
2870   ss = gfc_walk_expr (arg_expr);
2871   if (ss == gfc_ss_terminator)
2872     gfc_conv_expr_reference (se, arg_expr);
2873   else
2874     gfc_conv_array_parameter (se, arg_expr, ss, 1);
2875   se->expr= convert (gfc_unsigned_type (long_integer_type_node),
2876                      se->expr);
2877
2878   /* Create a temporary variable for loc return value.  Without this,
2879      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
2880   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
2881                              NULL);
2882   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
2883   se->expr = temp_var;
2884 }
2885
2886 /* Generate code for an intrinsic function.  Some map directly to library
2887    calls, others get special handling.  In some cases the name of the function
2888    used depends on the type specifiers.  */
2889
2890 void
2891 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2892 {
2893   gfc_intrinsic_sym *isym;
2894   const char *name;
2895   int lib;
2896
2897   isym = expr->value.function.isym;
2898
2899   name = &expr->value.function.name[2];
2900
2901   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
2902     {
2903       lib = gfc_is_intrinsic_libcall (expr);
2904       if (lib != 0)
2905         {
2906           if (lib == 1)
2907             se->ignore_optional = 1;
2908           gfc_conv_intrinsic_funcall (se, expr);
2909           return;
2910         }
2911     }
2912
2913   switch (expr->value.function.isym->generic_id)
2914     {
2915     case GFC_ISYM_NONE:
2916       gcc_unreachable ();
2917
2918     case GFC_ISYM_REPEAT:
2919       gfc_conv_intrinsic_repeat (se, expr);
2920       break;
2921
2922     case GFC_ISYM_TRIM:
2923       gfc_conv_intrinsic_trim (se, expr);
2924       break;
2925
2926     case GFC_ISYM_SI_KIND:
2927       gfc_conv_intrinsic_si_kind (se, expr);
2928       break;
2929
2930     case GFC_ISYM_SR_KIND:
2931       gfc_conv_intrinsic_sr_kind (se, expr);
2932       break;
2933
2934     case GFC_ISYM_EXPONENT:
2935       gfc_conv_intrinsic_exponent (se, expr);
2936       break;
2937
2938     case GFC_ISYM_SPACING:
2939       gfc_conv_intrinsic_spacing (se, expr);
2940       break;
2941
2942     case GFC_ISYM_RRSPACING:
2943       gfc_conv_intrinsic_rrspacing (se, expr);
2944       break;
2945
2946     case GFC_ISYM_SCAN:
2947       gfc_conv_intrinsic_scan (se, expr);
2948       break;
2949
2950     case GFC_ISYM_VERIFY:
2951       gfc_conv_intrinsic_verify (se, expr);
2952       break;
2953
2954     case GFC_ISYM_ALLOCATED:
2955       gfc_conv_allocated (se, expr);
2956       break;
2957
2958     case GFC_ISYM_ASSOCIATED:
2959       gfc_conv_associated(se, expr);
2960       break;
2961
2962     case GFC_ISYM_ABS:
2963       gfc_conv_intrinsic_abs (se, expr);
2964       break;
2965
2966     case GFC_ISYM_ADJUSTL:
2967       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2968       break;
2969
2970     case GFC_ISYM_ADJUSTR:
2971       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2972       break;
2973
2974     case GFC_ISYM_AIMAG:
2975       gfc_conv_intrinsic_imagpart (se, expr);
2976       break;
2977
2978     case GFC_ISYM_AINT:
2979       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2980       break;
2981
2982     case GFC_ISYM_ALL:
2983       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2984       break;
2985
2986     case GFC_ISYM_ANINT:
2987       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2988       break;
2989
2990     case GFC_ISYM_AND:
2991       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2992       break;
2993
2994     case GFC_ISYM_ANY:
2995       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2996       break;
2997
2998     case GFC_ISYM_BTEST:
2999       gfc_conv_intrinsic_btest (se, expr);
3000       break;
3001
3002     case GFC_ISYM_ACHAR:
3003     case GFC_ISYM_CHAR:
3004       gfc_conv_intrinsic_char (se, expr);
3005       break;
3006
3007     case GFC_ISYM_CONVERSION:
3008     case GFC_ISYM_REAL:
3009     case GFC_ISYM_LOGICAL:
3010     case GFC_ISYM_DBLE:
3011       gfc_conv_intrinsic_conversion (se, expr);
3012       break;
3013
3014       /* Integer conversions are handled separately to make sure we get the
3015          correct rounding mode.  */
3016     case GFC_ISYM_INT:
3017       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3018       break;
3019
3020     case GFC_ISYM_NINT:
3021       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3022       break;
3023
3024     case GFC_ISYM_CEILING:
3025       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3026       break;
3027
3028     case GFC_ISYM_FLOOR:
3029       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3030       break;
3031
3032     case GFC_ISYM_MOD:
3033       gfc_conv_intrinsic_mod (se, expr, 0);
3034       break;
3035
3036     case GFC_ISYM_MODULO:
3037       gfc_conv_intrinsic_mod (se, expr, 1);
3038       break;
3039
3040     case GFC_ISYM_CMPLX:
3041       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3042       break;
3043
3044     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3045       gfc_conv_intrinsic_iargc (se, expr);
3046       break;
3047
3048     case GFC_ISYM_COMPLEX:
3049       gfc_conv_intrinsic_cmplx (se, expr, 1);
3050       break;
3051
3052     case GFC_ISYM_CONJG:
3053       gfc_conv_intrinsic_conjg (se, expr);
3054       break;
3055
3056     case GFC_ISYM_COUNT:
3057       gfc_conv_intrinsic_count (se, expr);
3058       break;
3059
3060     case GFC_ISYM_CTIME:
3061       gfc_conv_intrinsic_ctime (se, expr);
3062       break;
3063
3064     case GFC_ISYM_DIM:
3065       gfc_conv_intrinsic_dim (se, expr);
3066       break;
3067
3068     case GFC_ISYM_DPROD:
3069       gfc_conv_intrinsic_dprod (se, expr);
3070       break;
3071
3072     case GFC_ISYM_FDATE:
3073       gfc_conv_intrinsic_fdate (se, expr);
3074       break;
3075
3076     case GFC_ISYM_IAND:
3077       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3078       break;
3079
3080     case GFC_ISYM_IBCLR:
3081       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3082       break;
3083
3084     case GFC_ISYM_IBITS:
3085       gfc_conv_intrinsic_ibits (se, expr);
3086       break;
3087
3088     case GFC_ISYM_IBSET:
3089       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3090       break;
3091
3092     case GFC_ISYM_IACHAR:
3093     case GFC_ISYM_ICHAR:
3094       /* We assume ASCII character sequence.  */
3095       gfc_conv_intrinsic_ichar (se, expr);
3096       break;
3097
3098     case GFC_ISYM_IARGC:
3099       gfc_conv_intrinsic_iargc (se, expr);
3100       break;
3101
3102     case GFC_ISYM_IEOR:
3103       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3104       break;
3105
3106     case GFC_ISYM_INDEX:
3107       gfc_conv_intrinsic_index (se, expr);
3108       break;
3109
3110     case GFC_ISYM_IOR:
3111       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3112       break;
3113
3114     case GFC_ISYM_ISHFT:
3115       gfc_conv_intrinsic_ishft (se, expr);
3116       break;
3117
3118     case GFC_ISYM_ISHFTC:
3119       gfc_conv_intrinsic_ishftc (se, expr);
3120       break;
3121
3122     case GFC_ISYM_LBOUND:
3123       gfc_conv_intrinsic_bound (se, expr, 0);
3124       break;
3125
3126     case GFC_ISYM_TRANSPOSE:
3127       if (se->ss && se->ss->useflags)
3128         {
3129           gfc_conv_tmp_array_ref (se);
3130           gfc_advance_se_ss_chain (se);
3131         }
3132       else
3133         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3134       break;
3135
3136     case GFC_ISYM_LEN:
3137       gfc_conv_intrinsic_len (se, expr);
3138       break;
3139
3140     case GFC_ISYM_LEN_TRIM:
3141       gfc_conv_intrinsic_len_trim (se, expr);
3142       break;
3143
3144     case GFC_ISYM_LGE:
3145       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3146       break;
3147
3148     case GFC_ISYM_LGT:
3149       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3150       break;
3151
3152     case GFC_ISYM_LLE:
3153       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3154       break;
3155
3156     case GFC_ISYM_LLT:
3157       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3158       break;
3159
3160     case GFC_ISYM_MAX:
3161       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3162       break;
3163
3164     case GFC_ISYM_MAXLOC:
3165       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3166       break;
3167
3168     case GFC_ISYM_MAXVAL:
3169       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3170       break;
3171
3172     case GFC_ISYM_MERGE:
3173       gfc_conv_intrinsic_merge (se, expr);
3174       break;
3175
3176     case GFC_ISYM_MIN:
3177       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3178       break;
3179
3180     case GFC_ISYM_MINLOC:
3181       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3182       break;
3183
3184     case GFC_ISYM_MINVAL:
3185       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3186       break;
3187
3188     case GFC_ISYM_NOT:
3189       gfc_conv_intrinsic_not (se, expr);
3190       break;
3191
3192     case GFC_ISYM_OR:
3193       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3194       break;
3195
3196     case GFC_ISYM_PRESENT:
3197       gfc_conv_intrinsic_present (se, expr);
3198       break;
3199
3200     case GFC_ISYM_PRODUCT:
3201       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3202       break;
3203
3204     case GFC_ISYM_SIGN:
3205       gfc_conv_intrinsic_sign (se, expr);
3206       break;
3207
3208     case GFC_ISYM_SIZE:
3209       gfc_conv_intrinsic_size (se, expr);
3210       break;
3211
3212     case GFC_ISYM_SUM:
3213       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3214       break;
3215
3216     case GFC_ISYM_TRANSFER:
3217       gfc_conv_intrinsic_transfer (se, expr);
3218       break;
3219
3220     case GFC_ISYM_TTYNAM:
3221       gfc_conv_intrinsic_ttynam (se, expr);
3222       break;
3223
3224     case GFC_ISYM_UBOUND:
3225       gfc_conv_intrinsic_bound (se, expr, 1);
3226       break;
3227
3228     case GFC_ISYM_XOR:
3229       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3230       break;
3231
3232     case GFC_ISYM_LOC:
3233       gfc_conv_intrinsic_loc (se, expr);
3234       break;
3235
3236     case GFC_ISYM_CHDIR:
3237     case GFC_ISYM_DOT_PRODUCT:
3238     case GFC_ISYM_ETIME:
3239     case GFC_ISYM_FGET:
3240     case GFC_ISYM_FGETC:
3241     case GFC_ISYM_FNUM:
3242     case GFC_ISYM_FPUT:
3243     case GFC_ISYM_FPUTC:
3244     case GFC_ISYM_FSTAT:
3245     case GFC_ISYM_FTELL:
3246     case GFC_ISYM_GETCWD:
3247     case GFC_ISYM_GETGID:
3248     case GFC_ISYM_GETPID:
3249     case GFC_ISYM_GETUID:
3250     case GFC_ISYM_HOSTNM:
3251     case GFC_ISYM_KILL:
3252     case GFC_ISYM_IERRNO:
3253     case GFC_ISYM_IRAND:
3254     case GFC_ISYM_ISATTY:
3255     case GFC_ISYM_LINK:
3256     case GFC_ISYM_MALLOC:
3257     case GFC_ISYM_MATMUL:
3258     case GFC_ISYM_RAND:
3259     case GFC_ISYM_RENAME:
3260     case GFC_ISYM_SECOND:
3261     case GFC_ISYM_SECNDS:
3262     case GFC_ISYM_SIGNAL:
3263     case GFC_ISYM_STAT:
3264     case GFC_ISYM_SYMLNK:
3265     case GFC_ISYM_SYSTEM:
3266     case GFC_ISYM_TIME:
3267     case GFC_ISYM_TIME8:
3268     case GFC_ISYM_UMASK:
3269     case GFC_ISYM_UNLINK:
3270       gfc_conv_intrinsic_funcall (se, expr);
3271       break;
3272
3273     default:
3274       gfc_conv_intrinsic_lib_function (se, expr);
3275       break;
3276     }
3277 }
3278
3279
3280 /* This generates code to execute before entering the scalarization loop.
3281    Currently does nothing.  */
3282
3283 void
3284 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3285 {
3286   switch (ss->expr->value.function.isym->generic_id)
3287     {
3288     case GFC_ISYM_UBOUND:
3289     case GFC_ISYM_LBOUND:
3290       break;
3291
3292     default:
3293       gcc_unreachable ();
3294     }
3295 }
3296
3297
3298 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3299    inside the scalarization loop.  */
3300
3301 static gfc_ss *
3302 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3303 {
3304   gfc_ss *newss;
3305
3306   /* The two argument version returns a scalar.  */
3307   if (expr->value.function.actual->next->expr)
3308     return ss;
3309
3310   newss = gfc_get_ss ();
3311   newss->type = GFC_SS_INTRINSIC;
3312   newss->expr = expr;
3313   newss->next = ss;
3314
3315   return newss;
3316 }
3317
3318
3319 /* Walk an intrinsic array libcall.  */
3320
3321 static gfc_ss *
3322 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3323 {
3324   gfc_ss *newss;
3325
3326   gcc_assert (expr->rank > 0);
3327
3328   newss = gfc_get_ss ();
3329   newss->type = GFC_SS_FUNCTION;
3330   newss->expr = expr;
3331   newss->next = ss;
3332   newss->data.info.dimen = expr->rank;
3333
3334   return newss;
3335 }
3336
3337
3338 /* Returns nonzero if the specified intrinsic function call maps directly to a
3339    an external library call.  Should only be used for functions that return
3340    arrays.  */
3341
3342 int
3343 gfc_is_intrinsic_libcall (gfc_expr * expr)
3344 {
3345   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3346   gcc_assert (expr->rank > 0);
3347
3348   switch (expr->value.function.isym->generic_id)
3349     {
3350     case GFC_ISYM_ALL:
3351     case GFC_ISYM_ANY:
3352     case GFC_ISYM_COUNT:
3353     case GFC_ISYM_MATMUL:
3354     case GFC_ISYM_MAXLOC:
3355     case GFC_ISYM_MAXVAL:
3356     case GFC_ISYM_MINLOC:
3357     case GFC_ISYM_MINVAL:
3358     case GFC_ISYM_PRODUCT:
3359     case GFC_ISYM_SUM:
3360     case GFC_ISYM_SHAPE:
3361     case GFC_ISYM_SPREAD:
3362     case GFC_ISYM_TRANSPOSE:
3363       /* Ignore absent optional parameters.  */
3364       return 1;
3365
3366     case GFC_ISYM_RESHAPE:
3367     case GFC_ISYM_CSHIFT:
3368     case GFC_ISYM_EOSHIFT:
3369     case GFC_ISYM_PACK:
3370     case GFC_ISYM_UNPACK:
3371       /* Pass absent optional parameters.  */
3372       return 2;
3373
3374     default:
3375       return 0;
3376     }
3377 }
3378
3379 /* Walk an intrinsic function.  */
3380 gfc_ss *
3381 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3382                              gfc_intrinsic_sym * isym)
3383 {
3384   gcc_assert (isym);
3385
3386   if (isym->elemental)
3387     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3388
3389   if (expr->rank == 0)
3390     return ss;
3391
3392   if (gfc_is_intrinsic_libcall (expr))
3393     return gfc_walk_intrinsic_libfunc (ss, expr);
3394
3395   /* Special cases.  */
3396   switch (isym->generic_id)
3397     {
3398     case GFC_ISYM_LBOUND:
3399     case GFC_ISYM_UBOUND:
3400       return gfc_walk_intrinsic_bound (ss, expr);
3401
3402     default:
3403       /* This probably meant someone forgot to add an intrinsic to the above
3404          list(s) when they implemented it, or something's gone horribly wrong.
3405        */
3406       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3407                       expr->value.function.name);
3408     }
3409 }
3410
3411 #include "gt-fortran-trans-intrinsic.h"