gcc/fortran/trans-intrinsic.c

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