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 && maskexpr->rank != 0)
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
1539   /* For a scalar mask, enclose the loop in an if statement.  */
1540   if (maskexpr && maskss == NULL)
1541     {
1542       gfc_init_se (&maskse, NULL);
1543       gfc_conv_expr_val (&maskse, maskexpr);
1544       gfc_init_block (&block);
1545       gfc_add_block_to_block (&block, &loop.pre);
1546       gfc_add_block_to_block (&block, &loop.post);
1547       tmp = gfc_finish_block (&block);
1548
1549       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1550       gfc_add_expr_to_block (&block, tmp);
1551       gfc_add_block_to_block (&se->pre, &block);
1552     }
1553   else
1554     {
1555       gfc_add_block_to_block (&se->pre, &loop.pre);
1556       gfc_add_block_to_block (&se->pre, &loop.post);
1557     }
1558
1559   gfc_cleanup_loop (&loop);
1560
1561   se->expr = resvar;
1562 }
1563
1564 static void
1565 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1566 {
1567   stmtblock_t body;
1568   stmtblock_t block;
1569   stmtblock_t ifblock;
1570   tree limit;
1571   tree type;
1572   tree tmp;
1573   tree ifbody;
1574   tree cond;
1575   gfc_loopinfo loop;
1576   gfc_actual_arglist *actual;
1577   gfc_ss *arrayss;
1578   gfc_ss *maskss;
1579   gfc_se arrayse;
1580   gfc_se maskse;
1581   gfc_expr *arrayexpr;
1582   gfc_expr *maskexpr;
1583   tree pos;
1584   int n;
1585
1586   if (se->ss)
1587     {
1588       gfc_conv_intrinsic_funcall (se, expr);
1589       return;
1590     }
1591
1592   /* Initialize the result.  */
1593   pos = gfc_create_var (gfc_array_index_type, "pos");
1594   type = gfc_typenode_for_spec (&expr->ts);
1595
1596   /* Walk the arguments.  */
1597   actual = expr->value.function.actual;
1598   arrayexpr = actual->expr;
1599   arrayss = gfc_walk_expr (arrayexpr);
1600   gcc_assert (arrayss != gfc_ss_terminator);
1601
1602   actual = actual->next->next;
1603   gcc_assert (actual);
1604   maskexpr = actual->expr;
1605   if (maskexpr)
1606     {
1607       maskss = gfc_walk_expr (maskexpr);
1608       gcc_assert (maskss != gfc_ss_terminator);
1609     }
1610   else
1611     maskss = NULL;
1612
1613   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1614   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1615   switch (arrayexpr->ts.type)
1616     {
1617     case BT_REAL:
1618       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1619       break;
1620
1621     case BT_INTEGER:
1622       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1623                                   arrayexpr->ts.kind);
1624       break;
1625
1626     default:
1627       gcc_unreachable ();
1628     }
1629
1630   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1631   if (op == GT_EXPR)
1632     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1633   gfc_add_modify_expr (&se->pre, limit, tmp);
1634
1635   /* Initialize the scalarizer.  */
1636   gfc_init_loopinfo (&loop);
1637   gfc_add_ss_to_loop (&loop, arrayss);
1638   if (maskss)
1639     gfc_add_ss_to_loop (&loop, maskss);
1640
1641   /* Initialize the loop.  */
1642   gfc_conv_ss_startstride (&loop);
1643   gfc_conv_loop_setup (&loop);
1644
1645   gcc_assert (loop.dimen == 1);
1646
1647   /* Initialize the position to the first element.  If the array has zero
1648      size we need to return zero.  Otherwise use the first element of the
1649      array, in case all elements are equal to the limit.
1650      i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1651   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1652                      loop.from[0], gfc_index_one_node);
1653   cond = fold_build2 (GE_EXPR, boolean_type_node,
1654                       loop.to[0], loop.from[0]);
1655   tmp = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1656                      loop.from[0], tmp);
1657   gfc_add_modify_expr (&loop.pre, pos, tmp);
1658
1659   gfc_mark_ss_chain_used (arrayss, 1);
1660   if (maskss)
1661     gfc_mark_ss_chain_used (maskss, 1);
1662   /* Generate the loop body.  */
1663   gfc_start_scalarized_body (&loop, &body);
1664
1665   /* If we have a mask, only check this element if the mask is set.  */
1666   if (maskss)
1667     {
1668       gfc_init_se (&maskse, NULL);
1669       gfc_copy_loopinfo_to_se (&maskse, &loop);
1670       maskse.ss = maskss;
1671       gfc_conv_expr_val (&maskse, maskexpr);
1672       gfc_add_block_to_block (&body, &maskse.pre);
1673
1674       gfc_start_block (&block);
1675     }
1676   else
1677     gfc_init_block (&block);
1678
1679   /* Compare with the current limit.  */
1680   gfc_init_se (&arrayse, NULL);
1681   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1682   arrayse.ss = arrayss;
1683   gfc_conv_expr_val (&arrayse, arrayexpr);
1684   gfc_add_block_to_block (&block, &arrayse.pre);
1685
1686   /* We do the following if this is a more extreme value.  */
1687   gfc_start_block (&ifblock);
1688
1689   /* Assign the value to the limit...  */
1690   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1691
1692   /* Remember where we are.  */
1693   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1694
1695   ifbody = gfc_finish_block (&ifblock);
1696
1697   /* If it is a more extreme value.  */
1698   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1699   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1700   gfc_add_expr_to_block (&block, tmp);
1701
1702   if (maskss)
1703     {
1704       /* We enclose the above in if (mask) {...}.  */
1705       tmp = gfc_finish_block (&block);
1706
1707       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1708     }
1709   else
1710     tmp = gfc_finish_block (&block);
1711   gfc_add_expr_to_block (&body, tmp);
1712
1713   gfc_trans_scalarizing_loops (&loop, &body);
1714
1715   gfc_add_block_to_block (&se->pre, &loop.pre);
1716   gfc_add_block_to_block (&se->pre, &loop.post);
1717   gfc_cleanup_loop (&loop);
1718
1719   /* Return a value in the range 1..SIZE(array).  */
1720   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1721                      gfc_index_one_node);
1722   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
1723   /* And convert to the required type.  */
1724   se->expr = convert (type, tmp);
1725 }
1726
1727 static void
1728 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1729 {
1730   tree limit;
1731   tree type;
1732   tree tmp;
1733   tree ifbody;
1734   stmtblock_t body;
1735   stmtblock_t block;
1736   gfc_loopinfo loop;
1737   gfc_actual_arglist *actual;
1738   gfc_ss *arrayss;
1739   gfc_ss *maskss;
1740   gfc_se arrayse;
1741   gfc_se maskse;
1742   gfc_expr *arrayexpr;
1743   gfc_expr *maskexpr;
1744   int n;
1745
1746   if (se->ss)
1747     {
1748       gfc_conv_intrinsic_funcall (se, expr);
1749       return;
1750     }
1751
1752   type = gfc_typenode_for_spec (&expr->ts);
1753   /* Initialize the result.  */
1754   limit = gfc_create_var (type, "limit");
1755   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1756   switch (expr->ts.type)
1757     {
1758     case BT_REAL:
1759       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1760       break;
1761
1762     case BT_INTEGER:
1763       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1764       break;
1765
1766     default:
1767       gcc_unreachable ();
1768     }
1769
1770   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1771   if (op == GT_EXPR)
1772     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1773   gfc_add_modify_expr (&se->pre, limit, tmp);
1774
1775   /* Walk the arguments.  */
1776   actual = expr->value.function.actual;
1777   arrayexpr = actual->expr;
1778   arrayss = gfc_walk_expr (arrayexpr);
1779   gcc_assert (arrayss != gfc_ss_terminator);
1780
1781   actual = actual->next->next;
1782   gcc_assert (actual);
1783   maskexpr = actual->expr;
1784   if (maskexpr && maskexpr->rank != 0)
1785     {
1786       maskss = gfc_walk_expr (maskexpr);
1787       gcc_assert (maskss != gfc_ss_terminator);
1788     }
1789   else
1790     maskss = NULL;
1791
1792   /* Initialize the scalarizer.  */
1793   gfc_init_loopinfo (&loop);
1794   gfc_add_ss_to_loop (&loop, arrayss);
1795   if (maskss)
1796     gfc_add_ss_to_loop (&loop, maskss);
1797
1798   /* Initialize the loop.  */
1799   gfc_conv_ss_startstride (&loop);
1800   gfc_conv_loop_setup (&loop);
1801
1802   gfc_mark_ss_chain_used (arrayss, 1);
1803   if (maskss)
1804     gfc_mark_ss_chain_used (maskss, 1);
1805   /* Generate the loop body.  */
1806   gfc_start_scalarized_body (&loop, &body);
1807
1808   /* If we have a mask, only add this element if the mask is set.  */
1809   if (maskss)
1810     {
1811       gfc_init_se (&maskse, NULL);
1812       gfc_copy_loopinfo_to_se (&maskse, &loop);
1813       maskse.ss = maskss;
1814       gfc_conv_expr_val (&maskse, maskexpr);
1815       gfc_add_block_to_block (&body, &maskse.pre);
1816
1817       gfc_start_block (&block);
1818     }
1819   else
1820     gfc_init_block (&block);
1821
1822   /* Compare with the current limit.  */
1823   gfc_init_se (&arrayse, NULL);
1824   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1825   arrayse.ss = arrayss;
1826   gfc_conv_expr_val (&arrayse, arrayexpr);
1827   gfc_add_block_to_block (&block, &arrayse.pre);
1828
1829   /* Assign the value to the limit...  */
1830   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1831
1832   /* If it is a more extreme value.  */
1833   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1834   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1835   gfc_add_expr_to_block (&block, tmp);
1836   gfc_add_block_to_block (&block, &arrayse.post);
1837
1838   tmp = gfc_finish_block (&block);
1839   if (maskss)
1840     /* We enclose the above in if (mask) {...}.  */
1841     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1842   gfc_add_expr_to_block (&body, tmp);
1843
1844   gfc_trans_scalarizing_loops (&loop, &body);
1845
1846   /* For a scalar mask, enclose the loop in an if statement.  */
1847   if (maskexpr && maskss == NULL)
1848     {
1849       gfc_init_se (&maskse, NULL);
1850       gfc_conv_expr_val (&maskse, maskexpr);
1851       gfc_init_block (&block);
1852       gfc_add_block_to_block (&block, &loop.pre);
1853       gfc_add_block_to_block (&block, &loop.post);
1854       tmp = gfc_finish_block (&block);
1855
1856       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1857       gfc_add_expr_to_block (&block, tmp);
1858       gfc_add_block_to_block (&se->pre, &block);
1859     }
1860   else
1861     {
1862       gfc_add_block_to_block (&se->pre, &loop.pre);
1863       gfc_add_block_to_block (&se->pre, &loop.post);
1864     }
1865
1866   gfc_cleanup_loop (&loop);
1867
1868   se->expr = limit;
1869 }
1870
1871 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1872 static void
1873 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1874 {
1875   tree arg;
1876   tree arg2;
1877   tree type;
1878   tree tmp;
1879
1880   arg = gfc_conv_intrinsic_function_args (se, expr);
1881   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1882   arg = TREE_VALUE (arg);
1883   type = TREE_TYPE (arg);
1884
1885   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
1886   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1887   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
1888                      build_int_cst (type, 0));
1889   type = gfc_typenode_for_spec (&expr->ts);
1890   se->expr = convert (type, tmp);
1891 }
1892
1893 /* Generate code to perform the specified operation.  */
1894 static void
1895 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1896 {
1897   tree arg;
1898   tree arg2;
1899   tree type;
1900
1901   arg = gfc_conv_intrinsic_function_args (se, expr);
1902   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1903   arg = TREE_VALUE (arg);
1904   type = TREE_TYPE (arg);
1905
1906   se->expr = fold_build2 (op, type, arg, arg2);
1907 }
1908
1909 /* Bitwise not.  */
1910 static void
1911 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1912 {
1913   tree arg;
1914
1915   arg = gfc_conv_intrinsic_function_args (se, expr);
1916   arg = TREE_VALUE (arg);
1917
1918   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1919 }
1920
1921 /* Set or clear a single bit.  */
1922 static void
1923 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1924 {
1925   tree arg;
1926   tree arg2;
1927   tree type;
1928   tree tmp;
1929   int op;
1930
1931   arg = gfc_conv_intrinsic_function_args (se, expr);
1932   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1933   arg = TREE_VALUE (arg);
1934   type = TREE_TYPE (arg);
1935
1936   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
1937   if (set)
1938     op = BIT_IOR_EXPR;
1939   else
1940     {
1941       op = BIT_AND_EXPR;
1942       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
1943     }
1944   se->expr = fold_build2 (op, type, arg, tmp);
1945 }
1946
1947 /* Extract a sequence of bits.
1948     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1949 static void
1950 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1951 {
1952   tree arg;
1953   tree arg2;
1954   tree arg3;
1955   tree type;
1956   tree tmp;
1957   tree mask;
1958
1959   arg = gfc_conv_intrinsic_function_args (se, expr);
1960   arg2 = TREE_CHAIN (arg);
1961   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1962   arg = TREE_VALUE (arg);
1963   arg2 = TREE_VALUE (arg2);
1964   type = TREE_TYPE (arg);
1965
1966   mask = build_int_cst (NULL_TREE, -1);
1967   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1968   mask = build1 (BIT_NOT_EXPR, type, mask);
1969
1970   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1971
1972   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
1973 }
1974
1975 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1976                         ? 0
1977                         : ((shift >= 0) ? i << shift : i >> -shift)
1978    where all shifts are logical shifts.  */
1979 static void
1980 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1981 {
1982   tree arg;
1983   tree arg2;
1984   tree type;
1985   tree utype;
1986   tree tmp;
1987   tree width;
1988   tree num_bits;
1989   tree cond;
1990   tree lshift;
1991   tree rshift;
1992
1993   arg = gfc_conv_intrinsic_function_args (se, expr);
1994   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1995   arg = TREE_VALUE (arg);
1996   type = TREE_TYPE (arg);
1997   utype = gfc_unsigned_type (type);
1998
1999   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2000
2001   /* Left shift if positive.  */
2002   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2003
2004   /* Right shift if negative.
2005      We convert to an unsigned type because we want a logical shift.
2006      The standard doesn't define the case of shifting negative
2007      numbers, and we try to be compatible with other compilers, most
2008      notably g77, here.  */
2009   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2010                                        convert (utype, arg), width));
2011
2012   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2013                      build_int_cst (TREE_TYPE (arg2), 0));
2014   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2015
2016   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2017      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2018      special case.  */
2019   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2020   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2021
2022   se->expr = fold_build3 (COND_EXPR, type, cond,
2023                           build_int_cst (type, 0), tmp);
2024 }
2025
2026 /* Circular shift.  AKA rotate or barrel shift.  */
2027 static void
2028 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2029 {
2030   tree arg;
2031   tree arg2;
2032   tree arg3;
2033   tree type;
2034   tree tmp;
2035   tree lrot;
2036   tree rrot;
2037   tree zero;
2038
2039   arg = gfc_conv_intrinsic_function_args (se, expr);
2040   arg2 = TREE_CHAIN (arg);
2041   arg3 = TREE_CHAIN (arg2);
2042   if (arg3)
2043     {
2044       /* Use a library function for the 3 parameter version.  */
2045       tree int4type = gfc_get_int_type (4);
2046
2047       type = TREE_TYPE (TREE_VALUE (arg));
2048       /* We convert the first argument to at least 4 bytes, and
2049          convert back afterwards.  This removes the need for library
2050          functions for all argument sizes, and function will be
2051          aligned to at least 32 bits, so there's no loss.  */
2052       if (expr->ts.kind < 4)
2053         {
2054           tmp = convert (int4type, TREE_VALUE (arg));
2055           TREE_VALUE (arg) = tmp;
2056         }
2057       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2058          need loads of library  functions.  They cannot have values >
2059          BIT_SIZE (I) so the conversion is safe.  */
2060       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2061       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2062
2063       switch (expr->ts.kind)
2064         {
2065         case 1:
2066         case 2:
2067         case 4:
2068           tmp = gfor_fndecl_math_ishftc4;
2069           break;
2070         case 8:
2071           tmp = gfor_fndecl_math_ishftc8;
2072           break;
2073         case 16:
2074           tmp = gfor_fndecl_math_ishftc16;
2075           break;
2076         default:
2077           gcc_unreachable ();
2078         }
2079       se->expr = build_function_call_expr (tmp, arg);
2080       /* Convert the result back to the original type, if we extended
2081          the first argument's width above.  */
2082       if (expr->ts.kind < 4)
2083         se->expr = convert (type, se->expr);
2084
2085       return;
2086     }
2087   arg = TREE_VALUE (arg);
2088   arg2 = TREE_VALUE (arg2);
2089   type = TREE_TYPE (arg);
2090
2091   /* Rotate left if positive.  */
2092   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2093
2094   /* Rotate right if negative.  */
2095   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2096   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2097
2098   zero = build_int_cst (TREE_TYPE (arg2), 0);
2099   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2100   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2101
2102   /* Do nothing if shift == 0.  */
2103   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2104   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2105 }
2106
2107 /* The length of a character string.  */
2108 static void
2109 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2110 {
2111   tree len;
2112   tree type;
2113   tree decl;
2114   gfc_symbol *sym;
2115   gfc_se argse;
2116   gfc_expr *arg;
2117
2118   gcc_assert (!se->ss);
2119
2120   arg = expr->value.function.actual->expr;
2121
2122   type = gfc_typenode_for_spec (&expr->ts);
2123   switch (arg->expr_type)
2124     {
2125     case EXPR_CONSTANT:
2126       len = build_int_cst (NULL_TREE, arg->value.character.length);
2127       break;
2128
2129     default:
2130         if (arg->expr_type == EXPR_VARIABLE
2131             && (arg->ref == NULL || (arg->ref->next == NULL
2132                                      && arg->ref->type == REF_ARRAY)))
2133           {
2134             /* This doesn't catch all cases.
2135                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2136                and the surrounding thread.  */
2137             sym = arg->symtree->n.sym;
2138             decl = gfc_get_symbol_decl (sym);
2139             if (decl == current_function_decl && sym->attr.function
2140                 && (sym->result == sym))
2141               decl = gfc_get_fake_result_decl (sym);
2142
2143             len = sym->ts.cl->backend_decl;
2144             gcc_assert (len);
2145           }
2146         else
2147           {
2148             /* Anybody stupid enough to do this deserves inefficient code.  */
2149             gfc_init_se (&argse, se);
2150             gfc_conv_expr (&argse, arg);
2151             gfc_add_block_to_block (&se->pre, &argse.pre);
2152             gfc_add_block_to_block (&se->post, &argse.post);
2153             len = argse.string_length;
2154         }
2155       break;
2156     }
2157   se->expr = convert (type, len);
2158 }
2159
2160 /* The length of a character string not including trailing blanks.  */
2161 static void
2162 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2163 {
2164   tree args;
2165   tree type;
2166
2167   args = gfc_conv_intrinsic_function_args (se, expr);
2168   type = gfc_typenode_for_spec (&expr->ts);
2169   se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2170   se->expr = convert (type, se->expr);
2171 }
2172
2173
2174 /* Returns the starting position of a substring within a string.  */
2175
2176 static void
2177 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2178 {
2179   tree logical4_type_node = gfc_get_logical_type (4);
2180   tree args;
2181   tree back;
2182   tree type;
2183   tree tmp;
2184
2185   args = gfc_conv_intrinsic_function_args (se, expr);
2186   type = gfc_typenode_for_spec (&expr->ts);
2187   tmp = gfc_advance_chain (args, 3);
2188   if (TREE_CHAIN (tmp) == NULL_TREE)
2189     {
2190       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2191                         NULL_TREE);
2192       TREE_CHAIN (tmp) = back;
2193     }
2194   else
2195     {
2196       back = TREE_CHAIN (tmp);
2197       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2198     }
2199
2200   se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2201   se->expr = convert (type, se->expr);
2202 }
2203
2204 /* The ascii value for a single character.  */
2205 static void
2206 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2207 {
2208   tree arg;
2209   tree type;
2210
2211   arg = gfc_conv_intrinsic_function_args (se, expr);
2212   arg = TREE_VALUE (TREE_CHAIN (arg));
2213   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2214   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2215   type = gfc_typenode_for_spec (&expr->ts);
2216
2217   se->expr = build_fold_indirect_ref (arg);
2218   se->expr = convert (type, se->expr);
2219 }
2220
2221
2222 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2223
2224 static void
2225 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2226 {
2227   tree arg;
2228   tree tsource;
2229   tree fsource;
2230   tree mask;
2231   tree type;
2232   tree len;
2233
2234   arg = gfc_conv_intrinsic_function_args (se, expr);
2235   if (expr->ts.type != BT_CHARACTER)
2236     {
2237       tsource = TREE_VALUE (arg);
2238       arg = TREE_CHAIN (arg);
2239       fsource = TREE_VALUE (arg);
2240       mask = TREE_VALUE (TREE_CHAIN (arg));
2241     }
2242   else
2243     {
2244       /* We do the same as in the non-character case, but the argument
2245          list is different because of the string length arguments. We
2246          also have to set the string length for the result.  */
2247       len = TREE_VALUE (arg);
2248       arg = TREE_CHAIN (arg);
2249       tsource = TREE_VALUE (arg);
2250       arg = TREE_CHAIN (TREE_CHAIN (arg));
2251       fsource = TREE_VALUE (arg);
2252       mask = TREE_VALUE (TREE_CHAIN (arg));
2253
2254       se->string_length = len;
2255     }
2256   type = TREE_TYPE (tsource);
2257   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2258 }
2259
2260
2261 static void
2262 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2263 {
2264   gfc_actual_arglist *actual;
2265   tree args;
2266   tree type;
2267   tree fndecl;
2268   gfc_se argse;
2269   gfc_ss *ss;
2270
2271   gfc_init_se (&argse, NULL);
2272   actual = expr->value.function.actual;
2273
2274   ss = gfc_walk_expr (actual->expr);
2275   gcc_assert (ss != gfc_ss_terminator);
2276   argse.want_pointer = 1;
2277   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2278   gfc_add_block_to_block (&se->pre, &argse.pre);
2279   gfc_add_block_to_block (&se->post, &argse.post);
2280   args = gfc_chainon_list (NULL_TREE, argse.expr);
2281
2282   actual = actual->next;
2283   if (actual->expr)
2284     {
2285       gfc_init_se (&argse, NULL);
2286       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2287       gfc_add_block_to_block (&se->pre, &argse.pre);
2288       args = gfc_chainon_list (args, argse.expr);
2289       fndecl = gfor_fndecl_size1;
2290     }
2291   else
2292     fndecl = gfor_fndecl_size0;
2293
2294   se->expr = build_function_call_expr (fndecl, args);
2295   type = gfc_typenode_for_spec (&expr->ts);
2296   se->expr = convert (type, se->expr);
2297 }
2298
2299
2300 /* Intrinsic string comparison functions.  */
2301
2302   static void
2303 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2304 {
2305   tree type;
2306   tree args;
2307   tree arg2;
2308
2309   args = gfc_conv_intrinsic_function_args (se, expr);
2310   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2311
2312   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2313                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2314                 TREE_VALUE (TREE_CHAIN (arg2)));
2315
2316   type = gfc_typenode_for_spec (&expr->ts);
2317   se->expr = fold_build2 (op, type, se->expr,
2318                      build_int_cst (TREE_TYPE (se->expr), 0));
2319 }
2320
2321 /* Generate a call to the adjustl/adjustr library function.  */
2322 static void
2323 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2324 {
2325   tree args;
2326   tree len;
2327   tree type;
2328   tree var;
2329   tree tmp;
2330
2331   args = gfc_conv_intrinsic_function_args (se, expr);
2332   len = TREE_VALUE (args);
2333
2334   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2335   var = gfc_conv_string_tmp (se, type, len);
2336   args = tree_cons (NULL_TREE, var, args);
2337
2338   tmp = build_function_call_expr (fndecl, args);
2339   gfc_add_expr_to_block (&se->pre, tmp);
2340   se->expr = var;
2341   se->string_length = len;
2342 }
2343
2344
2345 /* Scalar transfer statement.
2346    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
2347
2348 static void
2349 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2350 {
2351   gfc_actual_arglist *arg;
2352   gfc_se argse;
2353   tree type;
2354   tree ptr;
2355   gfc_ss *ss;
2356
2357   gcc_assert (!se->ss);
2358
2359   /* Get a pointer to the source.  */
2360   arg = expr->value.function.actual;
2361   ss = gfc_walk_expr (arg->expr);
2362   gfc_init_se (&argse, NULL);
2363   if (ss == gfc_ss_terminator)
2364     gfc_conv_expr_reference (&argse, arg->expr);
2365   else
2366     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2367   gfc_add_block_to_block (&se->pre, &argse.pre);
2368   gfc_add_block_to_block (&se->post, &argse.post);
2369   ptr = argse.expr;
2370
2371   arg = arg->next;
2372   type = gfc_typenode_for_spec (&expr->ts);
2373   ptr = convert (build_pointer_type (type), ptr);
2374   if (expr->ts.type == BT_CHARACTER)
2375     {
2376       gfc_init_se (&argse, NULL);
2377       gfc_conv_expr (&argse, arg->expr);
2378       gfc_add_block_to_block (&se->pre, &argse.pre);
2379       gfc_add_block_to_block (&se->post, &argse.post);
2380       se->expr = ptr;
2381       se->string_length = argse.string_length;
2382     }
2383   else
2384     {
2385       se->expr = build_fold_indirect_ref (ptr);
2386     }
2387 }
2388
2389
2390 /* Generate code for the ALLOCATED intrinsic.
2391    Generate inline code that directly check the address of the argument.  */
2392
2393 static void
2394 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2395 {
2396   gfc_actual_arglist *arg1;
2397   gfc_se arg1se;
2398   gfc_ss *ss1;
2399   tree tmp;
2400
2401   gfc_init_se (&arg1se, NULL);
2402   arg1 = expr->value.function.actual;
2403   ss1 = gfc_walk_expr (arg1->expr);
2404   arg1se.descriptor_only = 1;
2405   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2406
2407   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2408   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2409                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2410   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2411 }
2412
2413
2414 /* Generate code for the ASSOCIATED intrinsic.
2415    If both POINTER and TARGET are arrays, generate a call to library function
2416    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2417    In other cases, generate inline code that directly compare the address of
2418    POINTER with the address of TARGET.  */
2419
2420 static void
2421 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2422 {
2423   gfc_actual_arglist *arg1;
2424   gfc_actual_arglist *arg2;
2425   gfc_se arg1se;
2426   gfc_se arg2se;
2427   tree tmp2;
2428   tree tmp;
2429   tree args, fndecl;
2430   gfc_ss *ss1, *ss2;
2431
2432   gfc_init_se (&arg1se, NULL);
2433   gfc_init_se (&arg2se, NULL);
2434   arg1 = expr->value.function.actual;
2435   arg2 = arg1->next;
2436   ss1 = gfc_walk_expr (arg1->expr);
2437
2438   if (!arg2->expr)
2439     {
2440       /* No optional target.  */
2441       if (ss1 == gfc_ss_terminator)
2442         {
2443           /* A pointer to a scalar.  */
2444           arg1se.want_pointer = 1;
2445           gfc_conv_expr (&arg1se, arg1->expr);
2446           tmp2 = arg1se.expr;
2447         }
2448       else
2449         {
2450           /* A pointer to an array.  */
2451           arg1se.descriptor_only = 1;
2452           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2453           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
2454         }
2455       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2456                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2457       se->expr = tmp;
2458     }
2459   else
2460     {
2461       /* An optional target.  */
2462       ss2 = gfc_walk_expr (arg2->expr);
2463       if (ss1 == gfc_ss_terminator)
2464         {
2465           /* A pointer to a scalar.  */
2466           gcc_assert (ss2 == gfc_ss_terminator);
2467           arg1se.want_pointer = 1;
2468           gfc_conv_expr (&arg1se, arg1->expr);
2469           arg2se.want_pointer = 1;
2470           gfc_conv_expr (&arg2se, arg2->expr);
2471           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2472           se->expr = tmp;
2473         }
2474       else
2475         {
2476           /* A pointer to an array, call library function _gfor_associated.  */
2477           gcc_assert (ss2 != gfc_ss_terminator);
2478           args = NULL_TREE;
2479           arg1se.want_pointer = 1;
2480           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2481           args = gfc_chainon_list (args, arg1se.expr);
2482           arg2se.want_pointer = 1;
2483           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2484           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2485           gfc_add_block_to_block (&se->post, &arg2se.post);
2486           args = gfc_chainon_list (args, arg2se.expr);
2487           fndecl = gfor_fndecl_associated;
2488           se->expr = build_function_call_expr (fndecl, args);
2489         }
2490      }
2491   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2492 }
2493
2494
2495 /* Scan a string for any one of the characters in a set of characters.  */
2496
2497 static void
2498 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2499 {
2500   tree logical4_type_node = gfc_get_logical_type (4);
2501   tree args;
2502   tree back;
2503   tree type;
2504   tree tmp;
2505
2506   args = gfc_conv_intrinsic_function_args (se, expr);
2507   type = gfc_typenode_for_spec (&expr->ts);
2508   tmp = gfc_advance_chain (args, 3);
2509   if (TREE_CHAIN (tmp) == NULL_TREE)
2510     {
2511       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2512                         NULL_TREE);
2513       TREE_CHAIN (tmp) = back;
2514     }
2515   else
2516     {
2517       back = TREE_CHAIN (tmp);
2518       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2519     }
2520
2521   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2522   se->expr = convert (type, se->expr);
2523 }
2524
2525
2526 /* Verify that a set of characters contains all the characters in a string
2527    by identifying the position of the first character in a string of
2528    characters that does not appear in a given set of characters.  */
2529
2530 static void
2531 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2532 {
2533   tree logical4_type_node = gfc_get_logical_type (4);
2534   tree args;
2535   tree back;
2536   tree type;
2537   tree tmp;
2538
2539   args = gfc_conv_intrinsic_function_args (se, expr);
2540   type = gfc_typenode_for_spec (&expr->ts);
2541   tmp = gfc_advance_chain (args, 3);
2542   if (TREE_CHAIN (tmp) == NULL_TREE)
2543     {
2544       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2545                         NULL_TREE);
2546       TREE_CHAIN (tmp) = back;
2547     }
2548   else
2549     {
2550       back = TREE_CHAIN (tmp);
2551       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2552     }
2553
2554   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2555   se->expr = convert (type, se->expr);
2556 }
2557
2558 /* Prepare components and related information of a real number which is
2559    the first argument of a elemental functions to manipulate reals.  */
2560
2561 static void
2562 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2563                   real_compnt_info * rcs, int all)
2564 {
2565    tree arg;
2566    tree masktype;
2567    tree tmp;
2568    tree wbits;
2569    tree one;
2570    tree exponent, fraction;
2571    int n;
2572    gfc_expr *a1;
2573
2574    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2575      gfc_todo_error ("Non-IEEE floating format");
2576
2577    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2578
2579    arg = gfc_conv_intrinsic_function_args (se, expr);
2580    arg = TREE_VALUE (arg);
2581    rcs->type = TREE_TYPE (arg);
2582
2583    /* Force arg'type to integer by unaffected convert  */
2584    a1 = expr->value.function.actual->expr;
2585    masktype = gfc_get_int_type (a1->ts.kind);
2586    rcs->mtype = masktype;
2587    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2588    arg = gfc_create_var (masktype, "arg");
2589    gfc_add_modify_expr(&se->pre, arg, tmp);
2590    rcs->arg = arg;
2591
2592    /* Calculate the numbers of bits of exponent, fraction and word  */
2593    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2594    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2595    rcs->fdigits = convert (masktype, tmp);
2596    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2597    wbits = convert (masktype, wbits);
2598    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
2599
2600    /* Form masks for exponent/fraction/sign  */
2601    one = gfc_build_const (masktype, integer_one_node);
2602    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
2603    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
2604    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
2605    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
2606    /* Form bias.  */
2607    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
2608    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
2609    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
2610
2611    if (all)
2612      {
2613        /* exponent, and fraction  */
2614        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2615        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2616        exponent = gfc_create_var (masktype, "exponent");
2617        gfc_add_modify_expr(&se->pre, exponent, tmp);
2618        rcs->expn = exponent;
2619
2620        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2621        fraction = gfc_create_var (masktype, "fraction");
2622        gfc_add_modify_expr(&se->pre, fraction, tmp);
2623        rcs->frac = fraction;
2624      }
2625 }
2626
2627 /* Build a call to __builtin_clz.  */
2628
2629 static tree
2630 call_builtin_clz (tree result_type, tree op0)
2631 {
2632   tree fn, parms, call;
2633   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2634
2635   if (op0_mode == TYPE_MODE (integer_type_node))
2636     fn = built_in_decls[BUILT_IN_CLZ];
2637   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2638     fn = built_in_decls[BUILT_IN_CLZL];
2639   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2640     fn = built_in_decls[BUILT_IN_CLZLL];
2641   else
2642     gcc_unreachable ();
2643
2644   parms = tree_cons (NULL, op0, NULL);
2645   call = build_function_call_expr (fn, parms);
2646
2647   return convert (result_type, call);
2648 }
2649
2650
2651 /* Generate code for SPACING (X) intrinsic function.
2652    SPACING (X) = POW (2, e-p)
2653
2654    We generate:
2655
2656     t = expn - fdigits // e - p.
2657     res = t << fdigits // Form the exponent. Fraction is zero.
2658     if (t < 0) // The result is out of range. Denormalized case.
2659       res = tiny(X)
2660  */
2661
2662 static void
2663 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2664 {
2665    tree arg;
2666    tree masktype;
2667    tree tmp, t1, cond;
2668    tree tiny, zero;
2669    tree fdigits;
2670    real_compnt_info rcs;
2671
2672    prepare_arg_info (se, expr, &rcs, 0);
2673    arg = rcs.arg;
2674    masktype = rcs.mtype;
2675    fdigits = rcs.fdigits;
2676    tiny = rcs.f1;
2677    zero = gfc_build_const (masktype, integer_zero_node);
2678    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2679    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2680    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2681    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2682    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2683    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2684    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2685
2686    se->expr = tmp;
2687 }
2688
2689 /* Generate code for RRSPACING (X) intrinsic function.
2690    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2691
2692    So the result's exponent is p. And if X is normalized, X's fraction part
2693    is the result's fraction. If X is denormalized, to get the X's fraction we
2694    shift X's fraction part to left until the first '1' is removed.
2695
2696    We generate:
2697
2698     if (expn == 0 && frac == 0)
2699        res = 0;
2700     else
2701     {
2702        // edigits is the number of exponent bits. Add the sign bit.
2703        sedigits = edigits + 1;
2704
2705        if (expn == 0) // Denormalized case.
2706        {
2707          t1 = leadzero (frac);
2708          frac = frac << (t1 + 1); //Remove the first '1'.
2709          frac = frac >> (sedigits); //Form the fraction.
2710        }
2711
2712        //fdigits is the number of fraction bits. Form the exponent.
2713        t = bias + fdigits;
2714
2715        res = (t << fdigits) | frac;
2716     }
2717 */
2718
2719 static void
2720 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2721 {
2722    tree masktype;
2723    tree tmp, t1, t2, cond, cond2;
2724    tree one, zero;
2725    tree fdigits, fraction;
2726    real_compnt_info rcs;
2727
2728    prepare_arg_info (se, expr, &rcs, 1);
2729    masktype = rcs.mtype;
2730    fdigits = rcs.fdigits;
2731    fraction = rcs.frac;
2732    one = gfc_build_const (masktype, integer_one_node);
2733    zero = gfc_build_const (masktype, integer_zero_node);
2734    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
2735
2736    t1 = call_builtin_clz (masktype, fraction);
2737    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2738    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2739    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2740    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2741    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2742
2743    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
2744    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2745    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2746
2747    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2748    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2749    tmp = build3 (COND_EXPR, masktype, cond,
2750                  build_int_cst (masktype, 0), tmp);
2751
2752    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2753    se->expr = tmp;
2754 }
2755
2756 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2757
2758 static void
2759 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2760 {
2761   tree args;
2762
2763   args = gfc_conv_intrinsic_function_args (se, expr);
2764   args = TREE_VALUE (args);
2765   args = build_fold_addr_expr (args);
2766   args = tree_cons (NULL_TREE, args, NULL_TREE);
2767   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
2768 }
2769
2770 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2771
2772 static void
2773 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2774 {
2775   gfc_actual_arglist *actual;
2776   tree args;
2777   gfc_se argse;
2778
2779   args = NULL_TREE;
2780   for (actual = expr->value.function.actual; actual; actual = actual->next)
2781     {
2782       gfc_init_se (&argse, se);
2783
2784       /* Pass a NULL pointer for an absent arg.  */
2785       if (actual->expr == NULL)
2786         argse.expr = null_pointer_node;
2787       else
2788         gfc_conv_expr_reference (&argse, actual->expr);
2789
2790       gfc_add_block_to_block (&se->pre, &argse.pre);
2791       gfc_add_block_to_block (&se->post, &argse.post);
2792       args = gfc_chainon_list (args, argse.expr);
2793     }
2794   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
2795 }
2796
2797
2798 /* Generate code for TRIM (A) intrinsic function.  */
2799
2800 static void
2801 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2802 {
2803   tree gfc_int4_type_node = gfc_get_int_type (4);
2804   tree var;
2805   tree len;
2806   tree addr;
2807   tree tmp;
2808   tree arglist;
2809   tree type;
2810   tree cond;
2811
2812   arglist = NULL_TREE;
2813
2814   type = build_pointer_type (gfc_character1_type_node);
2815   var = gfc_create_var (type, "pstr");
2816   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2817   len = gfc_create_var (gfc_int4_type_node, "len");
2818
2819   tmp = gfc_conv_intrinsic_function_args (se, expr);
2820   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
2821   arglist = gfc_chainon_list (arglist, addr);
2822   arglist = chainon (arglist, tmp);
2823
2824   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
2825   gfc_add_expr_to_block (&se->pre, tmp);
2826
2827   /* Free the temporary afterwards, if necessary.  */
2828   cond = build2 (GT_EXPR, boolean_type_node, len,
2829                  build_int_cst (TREE_TYPE (len), 0));
2830   arglist = gfc_chainon_list (NULL_TREE, var);
2831   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
2832   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2833   gfc_add_expr_to_block (&se->post, tmp);
2834
2835   se->expr = var;
2836   se->string_length = len;
2837 }
2838
2839
2840 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2841
2842 static void
2843 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2844 {
2845   tree gfc_int4_type_node = gfc_get_int_type (4);
2846   tree tmp;
2847   tree len;
2848   tree args;
2849   tree arglist;
2850   tree ncopies;
2851   tree var;
2852   tree type;
2853
2854   args = gfc_conv_intrinsic_function_args (se, expr);
2855   len = TREE_VALUE (args);
2856   tmp = gfc_advance_chain (args, 2);
2857   ncopies = TREE_VALUE (tmp);
2858   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
2859   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2860   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2861
2862   arglist = NULL_TREE;
2863   arglist = gfc_chainon_list (arglist, var);
2864   arglist = chainon (arglist, args);
2865   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
2866   gfc_add_expr_to_block (&se->pre, tmp);
2867
2868   se->expr = var;
2869   se->string_length = len;
2870 }
2871
2872
2873 /* Generate code for the IARGC intrinsic.  */
2874
2875 static void
2876 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
2877 {
2878   tree tmp;
2879   tree fndecl;
2880   tree type;
2881
2882   /* Call the library function.  This always returns an INTEGER(4).  */
2883   fndecl = gfor_fndecl_iargc;
2884   tmp = build_function_call_expr (fndecl, NULL_TREE);
2885
2886   /* Convert it to the required type.  */
2887   type = gfc_typenode_for_spec (&expr->ts);
2888   tmp = fold_convert (type, tmp);
2889
2890   se->expr = tmp;
2891 }
2892
2893
2894 /* The loc intrinsic returns the address of its argument as
2895    gfc_index_integer_kind integer.  */
2896
2897 static void
2898 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
2899 {
2900   tree temp_var;
2901   gfc_expr *arg_expr;
2902   gfc_ss *ss;
2903
2904   gcc_assert (!se->ss);
2905
2906   arg_expr = expr->value.function.actual->expr;
2907   ss = gfc_walk_expr (arg_expr);
2908   if (ss == gfc_ss_terminator)
2909     gfc_conv_expr_reference (se, arg_expr);
2910   else
2911     gfc_conv_array_parameter (se, arg_expr, ss, 1);
2912   se->expr= convert (gfc_unsigned_type (long_integer_type_node),
2913                      se->expr);
2914
2915   /* Create a temporary variable for loc return value.  Without this,
2916      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
2917   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
2918                              NULL);
2919   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
2920   se->expr = temp_var;
2921 }
2922
2923 /* Generate code for an intrinsic function.  Some map directly to library
2924    calls, others get special handling.  In some cases the name of the function
2925    used depends on the type specifiers.  */
2926
2927 void
2928 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2929 {
2930   gfc_intrinsic_sym *isym;
2931   const char *name;
2932   int lib;
2933
2934   isym = expr->value.function.isym;
2935
2936   name = &expr->value.function.name[2];
2937
2938   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
2939     {
2940       lib = gfc_is_intrinsic_libcall (expr);
2941       if (lib != 0)
2942         {
2943           if (lib == 1)
2944             se->ignore_optional = 1;
2945           gfc_conv_intrinsic_funcall (se, expr);
2946           return;
2947         }
2948     }
2949
2950   switch (expr->value.function.isym->generic_id)
2951     {
2952     case GFC_ISYM_NONE:
2953       gcc_unreachable ();
2954
2955     case GFC_ISYM_REPEAT:
2956       gfc_conv_intrinsic_repeat (se, expr);
2957       break;
2958
2959     case GFC_ISYM_TRIM:
2960       gfc_conv_intrinsic_trim (se, expr);
2961       break;
2962
2963     case GFC_ISYM_SI_KIND:
2964       gfc_conv_intrinsic_si_kind (se, expr);
2965       break;
2966
2967     case GFC_ISYM_SR_KIND:
2968       gfc_conv_intrinsic_sr_kind (se, expr);
2969       break;
2970
2971     case GFC_ISYM_EXPONENT:
2972       gfc_conv_intrinsic_exponent (se, expr);
2973       break;
2974
2975     case GFC_ISYM_SPACING:
2976       gfc_conv_intrinsic_spacing (se, expr);
2977       break;
2978
2979     case GFC_ISYM_RRSPACING:
2980       gfc_conv_intrinsic_rrspacing (se, expr);
2981       break;
2982
2983     case GFC_ISYM_SCAN:
2984       gfc_conv_intrinsic_scan (se, expr);
2985       break;
2986
2987     case GFC_ISYM_VERIFY:
2988       gfc_conv_intrinsic_verify (se, expr);
2989       break;
2990
2991     case GFC_ISYM_ALLOCATED:
2992       gfc_conv_allocated (se, expr);
2993       break;
2994
2995     case GFC_ISYM_ASSOCIATED:
2996       gfc_conv_associated(se, expr);
2997       break;
2998
2999     case GFC_ISYM_ABS:
3000       gfc_conv_intrinsic_abs (se, expr);
3001       break;
3002
3003     case GFC_ISYM_ADJUSTL:
3004       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3005       break;
3006
3007     case GFC_ISYM_ADJUSTR:
3008       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3009       break;
3010
3011     case GFC_ISYM_AIMAG:
3012       gfc_conv_intrinsic_imagpart (se, expr);
3013       break;
3014
3015     case GFC_ISYM_AINT:
3016       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3017       break;
3018
3019     case GFC_ISYM_ALL:
3020       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3021       break;
3022
3023     case GFC_ISYM_ANINT:
3024       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3025       break;
3026
3027     case GFC_ISYM_AND:
3028       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3029       break;
3030
3031     case GFC_ISYM_ANY:
3032       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3033       break;
3034
3035     case GFC_ISYM_BTEST:
3036       gfc_conv_intrinsic_btest (se, expr);
3037       break;
3038
3039     case GFC_ISYM_ACHAR:
3040     case GFC_ISYM_CHAR:
3041       gfc_conv_intrinsic_char (se, expr);
3042       break;
3043
3044     case GFC_ISYM_CONVERSION:
3045     case GFC_ISYM_REAL:
3046     case GFC_ISYM_LOGICAL:
3047     case GFC_ISYM_DBLE:
3048       gfc_conv_intrinsic_conversion (se, expr);
3049       break;
3050
3051       /* Integer conversions are handled separately to make sure we get the
3052          correct rounding mode.  */
3053     case GFC_ISYM_INT:
3054       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3055       break;
3056
3057     case GFC_ISYM_NINT:
3058       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3059       break;
3060
3061     case GFC_ISYM_CEILING:
3062       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3063       break;
3064
3065     case GFC_ISYM_FLOOR:
3066       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3067       break;
3068
3069     case GFC_ISYM_MOD:
3070       gfc_conv_intrinsic_mod (se, expr, 0);
3071       break;
3072
3073     case GFC_ISYM_MODULO:
3074       gfc_conv_intrinsic_mod (se, expr, 1);
3075       break;
3076
3077     case GFC_ISYM_CMPLX:
3078       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3079       break;
3080
3081     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3082       gfc_conv_intrinsic_iargc (se, expr);
3083       break;
3084
3085     case GFC_ISYM_COMPLEX:
3086       gfc_conv_intrinsic_cmplx (se, expr, 1);
3087       break;
3088
3089     case GFC_ISYM_CONJG:
3090       gfc_conv_intrinsic_conjg (se, expr);
3091       break;
3092
3093     case GFC_ISYM_COUNT:
3094       gfc_conv_intrinsic_count (se, expr);
3095       break;
3096
3097     case GFC_ISYM_CTIME:
3098       gfc_conv_intrinsic_ctime (se, expr);
3099       break;
3100
3101     case GFC_ISYM_DIM:
3102       gfc_conv_intrinsic_dim (se, expr);
3103       break;
3104
3105     case GFC_ISYM_DPROD:
3106       gfc_conv_intrinsic_dprod (se, expr);
3107       break;
3108
3109     case GFC_ISYM_FDATE:
3110       gfc_conv_intrinsic_fdate (se, expr);
3111       break;
3112
3113     case GFC_ISYM_IAND:
3114       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3115       break;
3116
3117     case GFC_ISYM_IBCLR:
3118       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3119       break;
3120
3121     case GFC_ISYM_IBITS:
3122       gfc_conv_intrinsic_ibits (se, expr);
3123       break;
3124
3125     case GFC_ISYM_IBSET:
3126       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3127       break;
3128
3129     case GFC_ISYM_IACHAR:
3130     case GFC_ISYM_ICHAR:
3131       /* We assume ASCII character sequence.  */
3132       gfc_conv_intrinsic_ichar (se, expr);
3133       break;
3134
3135     case GFC_ISYM_IARGC:
3136       gfc_conv_intrinsic_iargc (se, expr);
3137       break;
3138
3139     case GFC_ISYM_IEOR:
3140       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3141       break;
3142
3143     case GFC_ISYM_INDEX:
3144       gfc_conv_intrinsic_index (se, expr);
3145       break;
3146
3147     case GFC_ISYM_IOR:
3148       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3149       break;
3150
3151     case GFC_ISYM_ISHFT:
3152       gfc_conv_intrinsic_ishft (se, expr);
3153       break;
3154
3155     case GFC_ISYM_ISHFTC:
3156       gfc_conv_intrinsic_ishftc (se, expr);
3157       break;
3158
3159     case GFC_ISYM_LBOUND:
3160       gfc_conv_intrinsic_bound (se, expr, 0);
3161       break;
3162
3163     case GFC_ISYM_TRANSPOSE:
3164       if (se->ss && se->ss->useflags)
3165         {
3166           gfc_conv_tmp_array_ref (se);
3167           gfc_advance_se_ss_chain (se);
3168         }
3169       else
3170         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3171       break;
3172
3173     case GFC_ISYM_LEN:
3174       gfc_conv_intrinsic_len (se, expr);
3175       break;
3176
3177     case GFC_ISYM_LEN_TRIM:
3178       gfc_conv_intrinsic_len_trim (se, expr);
3179       break;
3180
3181     case GFC_ISYM_LGE:
3182       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3183       break;
3184
3185     case GFC_ISYM_LGT:
3186       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3187       break;
3188
3189     case GFC_ISYM_LLE:
3190       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3191       break;
3192
3193     case GFC_ISYM_LLT:
3194       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3195       break;
3196
3197     case GFC_ISYM_MAX:
3198       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3199       break;
3200
3201     case GFC_ISYM_MAXLOC:
3202       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3203       break;
3204
3205     case GFC_ISYM_MAXVAL:
3206       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3207       break;
3208
3209     case GFC_ISYM_MERGE:
3210       gfc_conv_intrinsic_merge (se, expr);
3211       break;
3212
3213     case GFC_ISYM_MIN:
3214       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3215       break;
3216
3217     case GFC_ISYM_MINLOC:
3218       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3219       break;
3220
3221     case GFC_ISYM_MINVAL:
3222       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3223       break;
3224
3225     case GFC_ISYM_NOT:
3226       gfc_conv_intrinsic_not (se, expr);
3227       break;
3228
3229     case GFC_ISYM_OR:
3230       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3231       break;
3232
3233     case GFC_ISYM_PRESENT:
3234       gfc_conv_intrinsic_present (se, expr);
3235       break;
3236
3237     case GFC_ISYM_PRODUCT:
3238       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3239       break;
3240
3241     case GFC_ISYM_SIGN:
3242       gfc_conv_intrinsic_sign (se, expr);
3243       break;
3244
3245     case GFC_ISYM_SIZE:
3246       gfc_conv_intrinsic_size (se, expr);
3247       break;
3248
3249     case GFC_ISYM_SUM:
3250       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3251       break;
3252
3253     case GFC_ISYM_TRANSFER:
3254       gfc_conv_intrinsic_transfer (se, expr);
3255       break;
3256
3257     case GFC_ISYM_TTYNAM:
3258       gfc_conv_intrinsic_ttynam (se, expr);
3259       break;
3260
3261     case GFC_ISYM_UBOUND:
3262       gfc_conv_intrinsic_bound (se, expr, 1);
3263       break;
3264
3265     case GFC_ISYM_XOR:
3266       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3267       break;
3268
3269     case GFC_ISYM_LOC:
3270       gfc_conv_intrinsic_loc (se, expr);
3271       break;
3272
3273     case GFC_ISYM_CHDIR:
3274     case GFC_ISYM_DOT_PRODUCT:
3275     case GFC_ISYM_ETIME:
3276     case GFC_ISYM_FGET:
3277     case GFC_ISYM_FGETC:
3278     case GFC_ISYM_FNUM:
3279     case GFC_ISYM_FPUT:
3280     case GFC_ISYM_FPUTC:
3281     case GFC_ISYM_FSTAT:
3282     case GFC_ISYM_FTELL:
3283     case GFC_ISYM_GETCWD:
3284     case GFC_ISYM_GETGID:
3285     case GFC_ISYM_GETPID:
3286     case GFC_ISYM_GETUID:
3287     case GFC_ISYM_HOSTNM:
3288     case GFC_ISYM_KILL:
3289     case GFC_ISYM_IERRNO:
3290     case GFC_ISYM_IRAND:
3291     case GFC_ISYM_ISATTY:
3292     case GFC_ISYM_LINK:
3293     case GFC_ISYM_MALLOC:
3294     case GFC_ISYM_MATMUL:
3295     case GFC_ISYM_RAND:
3296     case GFC_ISYM_RENAME:
3297     case GFC_ISYM_SECOND:
3298     case GFC_ISYM_SECNDS:
3299     case GFC_ISYM_SIGNAL:
3300     case GFC_ISYM_STAT:
3301     case GFC_ISYM_SYMLNK:
3302     case GFC_ISYM_SYSTEM:
3303     case GFC_ISYM_TIME:
3304     case GFC_ISYM_TIME8:
3305     case GFC_ISYM_UMASK:
3306     case GFC_ISYM_UNLINK:
3307       gfc_conv_intrinsic_funcall (se, expr);
3308       break;
3309
3310     default:
3311       gfc_conv_intrinsic_lib_function (se, expr);
3312       break;
3313     }
3314 }
3315
3316
3317 /* This generates code to execute before entering the scalarization loop.
3318    Currently does nothing.  */
3319
3320 void
3321 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3322 {
3323   switch (ss->expr->value.function.isym->generic_id)
3324     {
3325     case GFC_ISYM_UBOUND:
3326     case GFC_ISYM_LBOUND:
3327       break;
3328
3329     default:
3330       gcc_unreachable ();
3331     }
3332 }
3333
3334
3335 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3336    inside the scalarization loop.  */
3337
3338 static gfc_ss *
3339 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3340 {
3341   gfc_ss *newss;
3342
3343   /* The two argument version returns a scalar.  */
3344   if (expr->value.function.actual->next->expr)
3345     return ss;
3346
3347   newss = gfc_get_ss ();
3348   newss->type = GFC_SS_INTRINSIC;
3349   newss->expr = expr;
3350   newss->next = ss;
3351
3352   return newss;
3353 }
3354
3355
3356 /* Walk an intrinsic array libcall.  */
3357
3358 static gfc_ss *
3359 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3360 {
3361   gfc_ss *newss;
3362
3363   gcc_assert (expr->rank > 0);
3364
3365   newss = gfc_get_ss ();
3366   newss->type = GFC_SS_FUNCTION;
3367   newss->expr = expr;
3368   newss->next = ss;
3369   newss->data.info.dimen = expr->rank;
3370
3371   return newss;
3372 }
3373
3374
3375 /* Returns nonzero if the specified intrinsic function call maps directly to a
3376    an external library call.  Should only be used for functions that return
3377    arrays.  */
3378
3379 int
3380 gfc_is_intrinsic_libcall (gfc_expr * expr)
3381 {
3382   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3383   gcc_assert (expr->rank > 0);
3384
3385   switch (expr->value.function.isym->generic_id)
3386     {
3387     case GFC_ISYM_ALL:
3388     case GFC_ISYM_ANY:
3389     case GFC_ISYM_COUNT:
3390     case GFC_ISYM_MATMUL:
3391     case GFC_ISYM_MAXLOC:
3392     case GFC_ISYM_MAXVAL:
3393     case GFC_ISYM_MINLOC:
3394     case GFC_ISYM_MINVAL:
3395     case GFC_ISYM_PRODUCT:
3396     case GFC_ISYM_SUM:
3397     case GFC_ISYM_SHAPE:
3398     case GFC_ISYM_SPREAD:
3399     case GFC_ISYM_TRANSPOSE:
3400       /* Ignore absent optional parameters.  */
3401       return 1;
3402
3403     case GFC_ISYM_RESHAPE:
3404     case GFC_ISYM_CSHIFT:
3405     case GFC_ISYM_EOSHIFT:
3406     case GFC_ISYM_PACK:
3407     case GFC_ISYM_UNPACK:
3408       /* Pass absent optional parameters.  */
3409       return 2;
3410
3411     default:
3412       return 0;
3413     }
3414 }
3415
3416 /* Walk an intrinsic function.  */
3417 gfc_ss *
3418 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3419                              gfc_intrinsic_sym * isym)
3420 {
3421   gcc_assert (isym);
3422
3423   if (isym->elemental)
3424     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3425
3426   if (expr->rank == 0)
3427     return ss;
3428
3429   if (gfc_is_intrinsic_libcall (expr))
3430     return gfc_walk_intrinsic_libfunc (ss, expr);
3431
3432   /* Special cases.  */
3433   switch (isym->generic_id)
3434     {
3435     case GFC_ISYM_LBOUND:
3436     case GFC_ISYM_UBOUND:
3437       return gfc_walk_intrinsic_bound (ss, expr);
3438
3439     default:
3440       /* This probably meant someone forgot to add an intrinsic to the above
3441          list(s) when they implemented it, or something's gone horribly wrong.
3442        */
3443       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3444                       expr->value.function.name);
3445     }
3446 }
3447
3448 #include "gt-fortran-trans-intrinsic.h"