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, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, 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   gfc_init_se (&argse, NULL);
 643   arg = expr->value.function.actual;
 644   arg2 = arg->next;
 645
 646   if (se->ss)
 647     {
 648       /* Create an implicit second parameter from the loop variable.  */
 649       gcc_assert (!arg2->expr);
 650       gcc_assert (se->loop->dimen == 1);
 651       gcc_assert (se->ss->expr == expr);
 652       gfc_advance_se_ss_chain (se);
 653       bound = se->loop->loopvar[0];
 654       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 655                            se->loop->from[0]);
 656     }
 657   else
 658     {
 659       /* use the passed argument.  */
 660       gcc_assert (arg->next->expr);
 661       gfc_init_se (&argse, NULL);
 662       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 663       gfc_add_block_to_block (&se->pre, &argse.pre);
 664       bound = argse.expr;
 665       /* Convert from one based to zero based.  */
 666       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 667                            gfc_index_one_node);
 668     }
 669
 670   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 671   /* Get a descriptor for the first parameter.  */
 672   ss = gfc_walk_expr (arg->expr);
 673   gcc_assert (ss != gfc_ss_terminator);
 674   argse.want_pointer = 0;
 675   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 676   gfc_add_block_to_block (&se->pre, &argse.pre);
 677   gfc_add_block_to_block (&se->post, &argse.post);
 678
 679   desc = argse.expr;
 680
 681   if (INTEGER_CST_P (bound))
 682     {
 683       gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
 684       i = TREE_INT_CST_LOW (bound);
 685       gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
 686     }
 687   else
 688     {
 689       if (flag_bounds_check)
 690         {
 691           bound = gfc_evaluate_now (bound, &se->pre);
 692           cond = fold_build2 (LT_EXPR, boolean_type_node,
 693                               bound, build_int_cst (TREE_TYPE (bound), 0));
 694           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 695           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 696           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 697           gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
 698         }
 699     }
 700
 701   if (upper)
 702     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 703   else
 704     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 705
 706   type = gfc_typenode_for_spec (&expr->ts);
 707   se->expr = convert (type, se->expr);
 708 }
 709
 710
 711 static void
 712 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 713 {
 714   tree args;
 715   tree val;
 716   int n;
 717
 718   args = gfc_conv_intrinsic_function_args (se, expr);
 719   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
 720   val = TREE_VALUE (args);
 721
 722   switch (expr->value.function.actual->expr->ts.type)
 723     {
 724     case BT_INTEGER:
 725     case BT_REAL:
 726       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 727       break;
 728
 729     case BT_COMPLEX:
 730       switch (expr->ts.kind)
 731         {
 732         case 4:
 733           n = BUILT_IN_CABSF;
 734           break;
 735         case 8:
 736           n = BUILT_IN_CABS;
 737           break;
 738         default:
 739           gcc_unreachable ();
 740         }
 741       se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
 742       break;
 743
 744     default:
 745       gcc_unreachable ();
 746     }
 747 }
 748
 749
 750 /* Create a complex value from one or two real components.  */
 751
 752 static void
 753 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 754 {
 755   tree arg;
 756   tree real;
 757   tree imag;
 758   tree type;
 759
 760   type = gfc_typenode_for_spec (&expr->ts);
 761   arg = gfc_conv_intrinsic_function_args (se, expr);
 762   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 763   if (both)
 764     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 765   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 766     {
 767       arg = TREE_VALUE (arg);
 768       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 769       imag = convert (TREE_TYPE (type), imag);
 770     }
 771   else
 772     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 773
 774   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
 775 }
 776
 777 /* Remainder function MOD(A, P) = A - INT(A / P) * P
 778                       MODULO(A, P) = A - FLOOR (A / P) * P  */
 779 /* TODO: MOD(x, 0)  */
 780
 781 static void
 782 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 783 {
 784   tree arg;
 785   tree arg2;
 786   tree type;
 787   tree itype;
 788   tree tmp;
 789   tree test;
 790   tree test2;
 791   mpfr_t huge;
 792   int n;
 793
 794   arg = gfc_conv_intrinsic_function_args (se, expr);
 795   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 796   arg = TREE_VALUE (arg);
 797   type = TREE_TYPE (arg);
 798
 799   switch (expr->ts.type)
 800     {
 801     case BT_INTEGER:
 802       /* Integer case is easy, we've got a builtin op.  */
 803       if (modulo)
 804        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
 805       else
 806        se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
 807       break;
 808
 809     case BT_REAL:
 810       /* Real values we have to do the hard way.  */
 811       arg = gfc_evaluate_now (arg, &se->pre);
 812       arg2 = gfc_evaluate_now (arg2, &se->pre);
 813
 814       tmp = build2 (RDIV_EXPR, type, arg, arg2);
 815       /* Test if the value is too large to handle sensibly.  */
 816       gfc_set_model_kind (expr->ts.kind);
 817       mpfr_init (huge);
 818       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
 819       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 820       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 821       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 822
 823       mpfr_neg (huge, huge, GFC_RND_MODE);
 824       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 825       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 826       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 827
 828       itype = gfc_get_int_type (expr->ts.kind);
 829       if (modulo)
 830        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
 831       else
 832        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 833       tmp = convert (type, tmp);
 834       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 835       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 836       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 837       mpfr_clear (huge);
 838       break;
 839
 840     default:
 841       gcc_unreachable ();
 842     }
 843 }
 844
 845 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 846
 847 static void
 848 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 849 {
 850   tree arg;
 851   tree arg2;
 852   tree val;
 853   tree tmp;
 854   tree type;
 855   tree zero;
 856
 857   arg = gfc_conv_intrinsic_function_args (se, expr);
 858   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 859   arg = TREE_VALUE (arg);
 860   type = TREE_TYPE (arg);
 861
 862   val = build2 (MINUS_EXPR, type, arg, arg2);
 863   val = gfc_evaluate_now (val, &se->pre);
 864
 865   zero = gfc_build_const (type, integer_zero_node);
 866   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 867   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 868 }
 869
 870
 871 /* SIGN(A, B) is absolute value of A times sign of B.
 872    The real value versions use library functions to ensure the correct
 873    handling of negative zero.  Integer case implemented as:
 874    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 875   */
 876
 877 static void
 878 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 879 {
 880   tree tmp;
 881   tree arg;
 882   tree arg2;
 883   tree type;
 884   tree zero;
 885   tree testa;
 886   tree testb;
 887
 888
 889   arg = gfc_conv_intrinsic_function_args (se, expr);
 890   if (expr->ts.type == BT_REAL)
 891     {
 892       switch (expr->ts.kind)
 893         {
 894         case 4:
 895           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 896           break;
 897         case 8:
 898           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 899           break;
 900         default:
 901           gcc_unreachable ();
 902         }
 903       se->expr = fold (gfc_build_function_call (tmp, arg));
 904       return;
 905     }
 906
 907   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 908   arg = TREE_VALUE (arg);
 909   type = TREE_TYPE (arg);
 910   zero = gfc_build_const (type, integer_zero_node);
 911
 912   testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
 913   testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
 914   tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
 915   se->expr = fold_build3 (COND_EXPR, type, tmp,
 916                           build1 (NEGATE_EXPR, type, arg), arg);
 917 }
 918
 919
 920 /* Test for the presence of an optional argument.  */
 921
 922 static void
 923 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 924 {
 925   gfc_expr *arg;
 926
 927   arg = expr->value.function.actual->expr;
 928   gcc_assert (arg->expr_type == EXPR_VARIABLE);
 929   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
 930   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 931 }
 932
 933
 934 /* Calculate the double precision product of two single precision values.  */
 935
 936 static void
 937 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 938 {
 939   tree arg;
 940   tree arg2;
 941   tree type;
 942
 943   arg = gfc_conv_intrinsic_function_args (se, expr);
 944   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 945   arg = TREE_VALUE (arg);
 946
 947   /* Convert the args to double precision before multiplying.  */
 948   type = gfc_typenode_for_spec (&expr->ts);
 949   arg = convert (type, arg);
 950   arg2 = convert (type, arg2);
 951   se->expr = build2 (MULT_EXPR, type, arg, arg2);
 952 }
 953
 954
 955 /* Return a length one character string containing an ascii character.  */
 956
 957 static void
 958 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 959 {
 960   tree arg;
 961   tree var;
 962   tree type;
 963
 964   arg = gfc_conv_intrinsic_function_args (se, expr);
 965   arg = TREE_VALUE (arg);
 966
 967   /* We currently don't support character types != 1.  */
 968   gcc_assert (expr->ts.kind == 1);
 969   type = gfc_character1_type_node;
 970   var = gfc_create_var (type, "char");
 971
 972   arg = convert (type, arg);
 973   gfc_add_modify_expr (&se->pre, var, arg);
 974   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
 975   se->string_length = integer_one_node;
 976 }
 977
 978
 979 /* Get the minimum/maximum value of all the parameters.
 980     minmax (a1, a2, a3, ...)
 981     {
 982       if (a2 .op. a1)
 983         mvar = a2;
 984       else
 985         mvar = a1;
 986       if (a3 .op. mvar)
 987         mvar = a3;
 988       ...
 989       return mvar
 990     }
 991  */
 992
 993 /* TODO: Mismatching types can occur when specific names are used.
 994    These should be handled during resolution.  */
 995 static void
 996 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 997 {
 998   tree limit;
 999   tree tmp;
1000   tree mvar;
1001   tree val;
1002   tree thencase;
1003   tree elsecase;
1004   tree arg;
1005   tree type;
1006
1007   arg = gfc_conv_intrinsic_function_args (se, expr);
1008   type = gfc_typenode_for_spec (&expr->ts);
1009
1010   limit = TREE_VALUE (arg);
1011   if (TREE_TYPE (limit) != type)
1012     limit = convert (type, limit);
1013   /* Only evaluate the argument once.  */
1014   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1015     limit = gfc_evaluate_now(limit, &se->pre);
1016
1017   mvar = gfc_create_var (type, "M");
1018   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1019   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1020     {
1021       val = TREE_VALUE (arg);
1022       if (TREE_TYPE (val) != type)
1023         val = convert (type, val);
1024
1025       /* Only evaluate the argument once.  */
1026       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1027         val = gfc_evaluate_now(val, &se->pre);
1028
1029       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1030
1031       tmp = build2 (op, boolean_type_node, val, limit);
1032       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1033       gfc_add_expr_to_block (&se->pre, tmp);
1034       elsecase = build_empty_stmt ();
1035       limit = mvar;
1036     }
1037   se->expr = mvar;
1038 }
1039
1040
1041 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1042    has the generic name.  */
1043
1044 static gfc_symbol *
1045 gfc_get_symbol_for_expr (gfc_expr * expr)
1046 {
1047   gfc_symbol *sym;
1048
1049   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1050   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1051   sym = gfc_new_symbol (expr->value.function.name, NULL);
1052
1053   sym->ts = expr->ts;
1054   sym->attr.external = 1;
1055   sym->attr.function = 1;
1056   sym->attr.always_explicit = 1;
1057   sym->attr.proc = PROC_INTRINSIC;
1058   sym->attr.flavor = FL_PROCEDURE;
1059   sym->result = sym;
1060   if (expr->rank > 0)
1061     {
1062       sym->attr.dimension = 1;
1063       sym->as = gfc_get_array_spec ();
1064       sym->as->type = AS_ASSUMED_SHAPE;
1065       sym->as->rank = expr->rank;
1066     }
1067
1068   /* TODO: proper argument lists for external intrinsics.  */
1069   return sym;
1070 }
1071
1072 /* Generate a call to an external intrinsic function.  */
1073 static void
1074 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1075 {
1076   gfc_symbol *sym;
1077
1078   gcc_assert (!se->ss || se->ss->expr == expr);
1079
1080   if (se->ss)
1081     gcc_assert (expr->rank > 0);
1082   else
1083     gcc_assert (expr->rank == 0);
1084
1085   sym = gfc_get_symbol_for_expr (expr);
1086   gfc_conv_function_call (se, sym, expr->value.function.actual);
1087   gfc_free (sym);
1088 }
1089
1090 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1091    Implemented as
1092     any(a)
1093     {
1094       forall (i=...)
1095         if (a[i] != 0)
1096           return 1
1097       end forall
1098       return 0
1099     }
1100     all(a)
1101     {
1102       forall (i=...)
1103         if (a[i] == 0)
1104           return 0
1105       end forall
1106       return 1
1107     }
1108  */
1109 static void
1110 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1111 {
1112   tree resvar;
1113   stmtblock_t block;
1114   stmtblock_t body;
1115   tree type;
1116   tree tmp;
1117   tree found;
1118   gfc_loopinfo loop;
1119   gfc_actual_arglist *actual;
1120   gfc_ss *arrayss;
1121   gfc_se arrayse;
1122   tree exit_label;
1123
1124   if (se->ss)
1125     {
1126       gfc_conv_intrinsic_funcall (se, expr);
1127       return;
1128     }
1129
1130   actual = expr->value.function.actual;
1131   type = gfc_typenode_for_spec (&expr->ts);
1132   /* Initialize the result.  */
1133   resvar = gfc_create_var (type, "test");
1134   if (op == EQ_EXPR)
1135     tmp = convert (type, boolean_true_node);
1136   else
1137     tmp = convert (type, boolean_false_node);
1138   gfc_add_modify_expr (&se->pre, resvar, tmp);
1139
1140   /* Walk the arguments.  */
1141   arrayss = gfc_walk_expr (actual->expr);
1142   gcc_assert (arrayss != gfc_ss_terminator);
1143
1144   /* Initialize the scalarizer.  */
1145   gfc_init_loopinfo (&loop);
1146   exit_label = gfc_build_label_decl (NULL_TREE);
1147   TREE_USED (exit_label) = 1;
1148   gfc_add_ss_to_loop (&loop, arrayss);
1149
1150   /* Initialize the loop.  */
1151   gfc_conv_ss_startstride (&loop);
1152   gfc_conv_loop_setup (&loop);
1153
1154   gfc_mark_ss_chain_used (arrayss, 1);
1155   /* Generate the loop body.  */
1156   gfc_start_scalarized_body (&loop, &body);
1157
1158   /* If the condition matches then set the return value.  */
1159   gfc_start_block (&block);
1160   if (op == EQ_EXPR)
1161     tmp = convert (type, boolean_false_node);
1162   else
1163     tmp = convert (type, boolean_true_node);
1164   gfc_add_modify_expr (&block, resvar, tmp);
1165
1166   /* And break out of the loop.  */
1167   tmp = build1_v (GOTO_EXPR, exit_label);
1168   gfc_add_expr_to_block (&block, tmp);
1169
1170   found = gfc_finish_block (&block);
1171
1172   /* Check this element.  */
1173   gfc_init_se (&arrayse, NULL);
1174   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1175   arrayse.ss = arrayss;
1176   gfc_conv_expr_val (&arrayse, actual->expr);
1177
1178   gfc_add_block_to_block (&body, &arrayse.pre);
1179   tmp = build2 (op, boolean_type_node, arrayse.expr,
1180                 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1181   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1182   gfc_add_expr_to_block (&body, tmp);
1183   gfc_add_block_to_block (&body, &arrayse.post);
1184
1185   gfc_trans_scalarizing_loops (&loop, &body);
1186
1187   /* Add the exit label.  */
1188   tmp = build1_v (LABEL_EXPR, exit_label);
1189   gfc_add_expr_to_block (&loop.pre, tmp);
1190
1191   gfc_add_block_to_block (&se->pre, &loop.pre);
1192   gfc_add_block_to_block (&se->pre, &loop.post);
1193   gfc_cleanup_loop (&loop);
1194
1195   se->expr = resvar;
1196 }
1197
1198 /* COUNT(A) = Number of true elements in A.  */
1199 static void
1200 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1201 {
1202   tree resvar;
1203   tree type;
1204   stmtblock_t body;
1205   tree tmp;
1206   gfc_loopinfo loop;
1207   gfc_actual_arglist *actual;
1208   gfc_ss *arrayss;
1209   gfc_se arrayse;
1210
1211   if (se->ss)
1212     {
1213       gfc_conv_intrinsic_funcall (se, expr);
1214       return;
1215     }
1216
1217   actual = expr->value.function.actual;
1218
1219   type = gfc_typenode_for_spec (&expr->ts);
1220   /* Initialize the result.  */
1221   resvar = gfc_create_var (type, "count");
1222   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1223
1224   /* Walk the arguments.  */
1225   arrayss = gfc_walk_expr (actual->expr);
1226   gcc_assert (arrayss != gfc_ss_terminator);
1227
1228   /* Initialize the scalarizer.  */
1229   gfc_init_loopinfo (&loop);
1230   gfc_add_ss_to_loop (&loop, arrayss);
1231
1232   /* Initialize the loop.  */
1233   gfc_conv_ss_startstride (&loop);
1234   gfc_conv_loop_setup (&loop);
1235
1236   gfc_mark_ss_chain_used (arrayss, 1);
1237   /* Generate the loop body.  */
1238   gfc_start_scalarized_body (&loop, &body);
1239
1240   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1241                 build_int_cst (TREE_TYPE (resvar), 1));
1242   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1243
1244   gfc_init_se (&arrayse, NULL);
1245   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1246   arrayse.ss = arrayss;
1247   gfc_conv_expr_val (&arrayse, actual->expr);
1248   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1249
1250   gfc_add_block_to_block (&body, &arrayse.pre);
1251   gfc_add_expr_to_block (&body, tmp);
1252   gfc_add_block_to_block (&body, &arrayse.post);
1253
1254   gfc_trans_scalarizing_loops (&loop, &body);
1255
1256   gfc_add_block_to_block (&se->pre, &loop.pre);
1257   gfc_add_block_to_block (&se->pre, &loop.post);
1258   gfc_cleanup_loop (&loop);
1259
1260   se->expr = resvar;
1261 }
1262
1263 /* Inline implementation of the sum and product intrinsics.  */
1264 static void
1265 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1266 {
1267   tree resvar;
1268   tree type;
1269   stmtblock_t body;
1270   stmtblock_t block;
1271   tree tmp;
1272   gfc_loopinfo loop;
1273   gfc_actual_arglist *actual;
1274   gfc_ss *arrayss;
1275   gfc_ss *maskss;
1276   gfc_se arrayse;
1277   gfc_se maskse;
1278   gfc_expr *arrayexpr;
1279   gfc_expr *maskexpr;
1280
1281   if (se->ss)
1282     {
1283       gfc_conv_intrinsic_funcall (se, expr);
1284       return;
1285     }
1286
1287   type = gfc_typenode_for_spec (&expr->ts);
1288   /* Initialize the result.  */
1289   resvar = gfc_create_var (type, "val");
1290   if (op == PLUS_EXPR)
1291     tmp = gfc_build_const (type, integer_zero_node);
1292   else
1293     tmp = gfc_build_const (type, integer_one_node);
1294
1295   gfc_add_modify_expr (&se->pre, resvar, tmp);
1296
1297   /* Walk the arguments.  */
1298   actual = expr->value.function.actual;
1299   arrayexpr = actual->expr;
1300   arrayss = gfc_walk_expr (arrayexpr);
1301   gcc_assert (arrayss != gfc_ss_terminator);
1302
1303   actual = actual->next->next;
1304   gcc_assert (actual);
1305   maskexpr = actual->expr;
1306   if (maskexpr)
1307     {
1308       maskss = gfc_walk_expr (maskexpr);
1309       gcc_assert (maskss != gfc_ss_terminator);
1310     }
1311   else
1312     maskss = NULL;
1313
1314   /* Initialize the scalarizer.  */
1315   gfc_init_loopinfo (&loop);
1316   gfc_add_ss_to_loop (&loop, arrayss);
1317   if (maskss)
1318     gfc_add_ss_to_loop (&loop, maskss);
1319
1320   /* Initialize the loop.  */
1321   gfc_conv_ss_startstride (&loop);
1322   gfc_conv_loop_setup (&loop);
1323
1324   gfc_mark_ss_chain_used (arrayss, 1);
1325   if (maskss)
1326     gfc_mark_ss_chain_used (maskss, 1);
1327   /* Generate the loop body.  */
1328   gfc_start_scalarized_body (&loop, &body);
1329
1330   /* If we have a mask, only add this element if the mask is set.  */
1331   if (maskss)
1332     {
1333       gfc_init_se (&maskse, NULL);
1334       gfc_copy_loopinfo_to_se (&maskse, &loop);
1335       maskse.ss = maskss;
1336       gfc_conv_expr_val (&maskse, maskexpr);
1337       gfc_add_block_to_block (&body, &maskse.pre);
1338
1339       gfc_start_block (&block);
1340     }
1341   else
1342     gfc_init_block (&block);
1343
1344   /* Do the actual summation/product.  */
1345   gfc_init_se (&arrayse, NULL);
1346   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1347   arrayse.ss = arrayss;
1348   gfc_conv_expr_val (&arrayse, arrayexpr);
1349   gfc_add_block_to_block (&block, &arrayse.pre);
1350
1351   tmp = build2 (op, type, resvar, arrayse.expr);
1352   gfc_add_modify_expr (&block, resvar, tmp);
1353   gfc_add_block_to_block (&block, &arrayse.post);
1354
1355   if (maskss)
1356     {
1357       /* We enclose the above in if (mask) {...} .  */
1358       tmp = gfc_finish_block (&block);
1359
1360       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1361     }
1362   else
1363     tmp = gfc_finish_block (&block);
1364   gfc_add_expr_to_block (&body, tmp);
1365
1366   gfc_trans_scalarizing_loops (&loop, &body);
1367   gfc_add_block_to_block (&se->pre, &loop.pre);
1368   gfc_add_block_to_block (&se->pre, &loop.post);
1369   gfc_cleanup_loop (&loop);
1370
1371   se->expr = resvar;
1372 }
1373
1374 static void
1375 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1376 {
1377   stmtblock_t body;
1378   stmtblock_t block;
1379   stmtblock_t ifblock;
1380   tree limit;
1381   tree type;
1382   tree tmp;
1383   tree ifbody;
1384   tree cond;
1385   gfc_loopinfo loop;
1386   gfc_actual_arglist *actual;
1387   gfc_ss *arrayss;
1388   gfc_ss *maskss;
1389   gfc_se arrayse;
1390   gfc_se maskse;
1391   gfc_expr *arrayexpr;
1392   gfc_expr *maskexpr;
1393   tree pos;
1394   int n;
1395
1396   if (se->ss)
1397     {
1398       gfc_conv_intrinsic_funcall (se, expr);
1399       return;
1400     }
1401
1402   /* Initialize the result.  */
1403   pos = gfc_create_var (gfc_array_index_type, "pos");
1404   type = gfc_typenode_for_spec (&expr->ts);
1405
1406   /* Walk the arguments.  */
1407   actual = expr->value.function.actual;
1408   arrayexpr = actual->expr;
1409   arrayss = gfc_walk_expr (arrayexpr);
1410   gcc_assert (arrayss != gfc_ss_terminator);
1411
1412   actual = actual->next->next;
1413   gcc_assert (actual);
1414   maskexpr = actual->expr;
1415   if (maskexpr)
1416     {
1417       maskss = gfc_walk_expr (maskexpr);
1418       gcc_assert (maskss != gfc_ss_terminator);
1419     }
1420   else
1421     maskss = NULL;
1422
1423   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1424   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1425   switch (arrayexpr->ts.type)
1426     {
1427     case BT_REAL:
1428       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1429       break;
1430
1431     case BT_INTEGER:
1432       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1433                                   arrayexpr->ts.kind);
1434       break;
1435
1436     default:
1437       gcc_unreachable ();
1438     }
1439
1440   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1441   if (op == GT_EXPR)
1442     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1443   gfc_add_modify_expr (&se->pre, limit, tmp);
1444
1445   /* Initialize the scalarizer.  */
1446   gfc_init_loopinfo (&loop);
1447   gfc_add_ss_to_loop (&loop, arrayss);
1448   if (maskss)
1449     gfc_add_ss_to_loop (&loop, maskss);
1450
1451   /* Initialize the loop.  */
1452   gfc_conv_ss_startstride (&loop);
1453   gfc_conv_loop_setup (&loop);
1454
1455   gcc_assert (loop.dimen == 1);
1456
1457   /* Initialize the position to the first element.  If the array has zero
1458      size we need to return zero.  Otherwise use the first element of the
1459      array, in case all elements are equal to the limit.
1460      i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1461   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1462                      loop.from[0], gfc_index_one_node);
1463   cond = fold_build2 (GE_EXPR, boolean_type_node,
1464                       loop.to[0], loop.from[0]);
1465   tmp = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1466                      loop.from[0], tmp);
1467   gfc_add_modify_expr (&loop.pre, pos, tmp);
1468
1469   gfc_mark_ss_chain_used (arrayss, 1);
1470   if (maskss)
1471     gfc_mark_ss_chain_used (maskss, 1);
1472   /* Generate the loop body.  */
1473   gfc_start_scalarized_body (&loop, &body);
1474
1475   /* If we have a mask, only check this element if the mask is set.  */
1476   if (maskss)
1477     {
1478       gfc_init_se (&maskse, NULL);
1479       gfc_copy_loopinfo_to_se (&maskse, &loop);
1480       maskse.ss = maskss;
1481       gfc_conv_expr_val (&maskse, maskexpr);
1482       gfc_add_block_to_block (&body, &maskse.pre);
1483
1484       gfc_start_block (&block);
1485     }
1486   else
1487     gfc_init_block (&block);
1488
1489   /* Compare with the current limit.  */
1490   gfc_init_se (&arrayse, NULL);
1491   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1492   arrayse.ss = arrayss;
1493   gfc_conv_expr_val (&arrayse, arrayexpr);
1494   gfc_add_block_to_block (&block, &arrayse.pre);
1495
1496   /* We do the following if this is a more extreme value.  */
1497   gfc_start_block (&ifblock);
1498
1499   /* Assign the value to the limit...  */
1500   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1501
1502   /* Remember where we are.  */
1503   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1504
1505   ifbody = gfc_finish_block (&ifblock);
1506
1507   /* If it is a more extreme value.  */
1508   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1509   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1510   gfc_add_expr_to_block (&block, tmp);
1511
1512   if (maskss)
1513     {
1514       /* We enclose the above in if (mask) {...}.  */
1515       tmp = gfc_finish_block (&block);
1516
1517       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1518     }
1519   else
1520     tmp = gfc_finish_block (&block);
1521   gfc_add_expr_to_block (&body, tmp);
1522
1523   gfc_trans_scalarizing_loops (&loop, &body);
1524
1525   gfc_add_block_to_block (&se->pre, &loop.pre);
1526   gfc_add_block_to_block (&se->pre, &loop.post);
1527   gfc_cleanup_loop (&loop);
1528
1529   /* Return a value in the range 1..SIZE(array).  */
1530   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1531                      gfc_index_one_node);
1532   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
1533   /* And convert to the required type.  */
1534   se->expr = convert (type, tmp);
1535 }
1536
1537 static void
1538 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1539 {
1540   tree limit;
1541   tree type;
1542   tree tmp;
1543   tree ifbody;
1544   stmtblock_t body;
1545   stmtblock_t block;
1546   gfc_loopinfo loop;
1547   gfc_actual_arglist *actual;
1548   gfc_ss *arrayss;
1549   gfc_ss *maskss;
1550   gfc_se arrayse;
1551   gfc_se maskse;
1552   gfc_expr *arrayexpr;
1553   gfc_expr *maskexpr;
1554   int n;
1555
1556   if (se->ss)
1557     {
1558       gfc_conv_intrinsic_funcall (se, expr);
1559       return;
1560     }
1561
1562   type = gfc_typenode_for_spec (&expr->ts);
1563   /* Initialize the result.  */
1564   limit = gfc_create_var (type, "limit");
1565   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1566   switch (expr->ts.type)
1567     {
1568     case BT_REAL:
1569       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1570       break;
1571
1572     case BT_INTEGER:
1573       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1574       break;
1575
1576     default:
1577       gcc_unreachable ();
1578     }
1579
1580   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1581   if (op == GT_EXPR)
1582     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1583   gfc_add_modify_expr (&se->pre, limit, tmp);
1584
1585   /* Walk the arguments.  */
1586   actual = expr->value.function.actual;
1587   arrayexpr = actual->expr;
1588   arrayss = gfc_walk_expr (arrayexpr);
1589   gcc_assert (arrayss != gfc_ss_terminator);
1590
1591   actual = actual->next->next;
1592   gcc_assert (actual);
1593   maskexpr = actual->expr;
1594   if (maskexpr)
1595     {
1596       maskss = gfc_walk_expr (maskexpr);
1597       gcc_assert (maskss != gfc_ss_terminator);
1598     }
1599   else
1600     maskss = NULL;
1601
1602   /* Initialize the scalarizer.  */
1603   gfc_init_loopinfo (&loop);
1604   gfc_add_ss_to_loop (&loop, arrayss);
1605   if (maskss)
1606     gfc_add_ss_to_loop (&loop, maskss);
1607
1608   /* Initialize the loop.  */
1609   gfc_conv_ss_startstride (&loop);
1610   gfc_conv_loop_setup (&loop);
1611
1612   gfc_mark_ss_chain_used (arrayss, 1);
1613   if (maskss)
1614     gfc_mark_ss_chain_used (maskss, 1);
1615   /* Generate the loop body.  */
1616   gfc_start_scalarized_body (&loop, &body);
1617
1618   /* If we have a mask, only add this element if the mask is set.  */
1619   if (maskss)
1620     {
1621       gfc_init_se (&maskse, NULL);
1622       gfc_copy_loopinfo_to_se (&maskse, &loop);
1623       maskse.ss = maskss;
1624       gfc_conv_expr_val (&maskse, maskexpr);
1625       gfc_add_block_to_block (&body, &maskse.pre);
1626
1627       gfc_start_block (&block);
1628     }
1629   else
1630     gfc_init_block (&block);
1631
1632   /* Compare with the current limit.  */
1633   gfc_init_se (&arrayse, NULL);
1634   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1635   arrayse.ss = arrayss;
1636   gfc_conv_expr_val (&arrayse, arrayexpr);
1637   gfc_add_block_to_block (&block, &arrayse.pre);
1638
1639   /* Assign the value to the limit...  */
1640   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1641
1642   /* If it is a more extreme value.  */
1643   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1644   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1645   gfc_add_expr_to_block (&block, tmp);
1646   gfc_add_block_to_block (&block, &arrayse.post);
1647
1648   tmp = gfc_finish_block (&block);
1649   if (maskss)
1650     /* We enclose the above in if (mask) {...}.  */
1651     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1652   gfc_add_expr_to_block (&body, tmp);
1653
1654   gfc_trans_scalarizing_loops (&loop, &body);
1655
1656   gfc_add_block_to_block (&se->pre, &loop.pre);
1657   gfc_add_block_to_block (&se->pre, &loop.post);
1658   gfc_cleanup_loop (&loop);
1659
1660   se->expr = limit;
1661 }
1662
1663 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1664 static void
1665 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1666 {
1667   tree arg;
1668   tree arg2;
1669   tree type;
1670   tree tmp;
1671
1672   arg = gfc_conv_intrinsic_function_args (se, expr);
1673   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1674   arg = TREE_VALUE (arg);
1675   type = TREE_TYPE (arg);
1676
1677   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
1678   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1679   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
1680                      build_int_cst (type, 0));
1681   type = gfc_typenode_for_spec (&expr->ts);
1682   se->expr = convert (type, tmp);
1683 }
1684
1685 /* Generate code to perform the specified operation.  */
1686 static void
1687 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1688 {
1689   tree arg;
1690   tree arg2;
1691   tree type;
1692
1693   arg = gfc_conv_intrinsic_function_args (se, expr);
1694   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1695   arg = TREE_VALUE (arg);
1696   type = TREE_TYPE (arg);
1697
1698   se->expr = fold_build2 (op, type, arg, arg2);
1699 }
1700
1701 /* Bitwise not.  */
1702 static void
1703 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1704 {
1705   tree arg;
1706
1707   arg = gfc_conv_intrinsic_function_args (se, expr);
1708   arg = TREE_VALUE (arg);
1709
1710   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1711 }
1712
1713 /* Set or clear a single bit.  */
1714 static void
1715 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1716 {
1717   tree arg;
1718   tree arg2;
1719   tree type;
1720   tree tmp;
1721   int op;
1722
1723   arg = gfc_conv_intrinsic_function_args (se, expr);
1724   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1725   arg = TREE_VALUE (arg);
1726   type = TREE_TYPE (arg);
1727
1728   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
1729   if (set)
1730     op = BIT_IOR_EXPR;
1731   else
1732     {
1733       op = BIT_AND_EXPR;
1734       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
1735     }
1736   se->expr = fold_build2 (op, type, arg, tmp);
1737 }
1738
1739 /* Extract a sequence of bits.
1740     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1741 static void
1742 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1743 {
1744   tree arg;
1745   tree arg2;
1746   tree arg3;
1747   tree type;
1748   tree tmp;
1749   tree mask;
1750
1751   arg = gfc_conv_intrinsic_function_args (se, expr);
1752   arg2 = TREE_CHAIN (arg);
1753   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1754   arg = TREE_VALUE (arg);
1755   arg2 = TREE_VALUE (arg2);
1756   type = TREE_TYPE (arg);
1757
1758   mask = build_int_cst (NULL_TREE, -1);
1759   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1760   mask = build1 (BIT_NOT_EXPR, type, mask);
1761
1762   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1763
1764   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
1765 }
1766
1767 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1768                         ? 0
1769                         : ((shift >= 0) ? i << shift : i >> -shift)
1770    where all shifts are logical shifts.  */
1771 static void
1772 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1773 {
1774   tree arg;
1775   tree arg2;
1776   tree type;
1777   tree utype;
1778   tree tmp;
1779   tree width;
1780   tree num_bits;
1781   tree cond;
1782   tree lshift;
1783   tree rshift;
1784
1785   arg = gfc_conv_intrinsic_function_args (se, expr);
1786   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1787   arg = TREE_VALUE (arg);
1788   type = TREE_TYPE (arg);
1789   utype = gfc_unsigned_type (type);
1790
1791   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
1792
1793   /* Left shift if positive.  */
1794   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
1795
1796   /* Right shift if negative.
1797      We convert to an unsigned type because we want a logical shift.
1798      The standard doesn't define the case of shifting negative
1799      numbers, and we try to be compatible with other compilers, most
1800      notably g77, here.  */
1801   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
1802                                        convert (utype, arg), width));
1803
1804   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
1805                      build_int_cst (TREE_TYPE (arg2), 0));
1806   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
1807
1808   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1809      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1810      special case.  */
1811   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
1812   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
1813
1814   se->expr = fold_build3 (COND_EXPR, type, cond,
1815                           build_int_cst (type, 0), tmp);
1816 }
1817
1818 /* Circular shift.  AKA rotate or barrel shift.  */
1819 static void
1820 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1821 {
1822   tree arg;
1823   tree arg2;
1824   tree arg3;
1825   tree type;
1826   tree tmp;
1827   tree lrot;
1828   tree rrot;
1829   tree zero;
1830
1831   arg = gfc_conv_intrinsic_function_args (se, expr);
1832   arg2 = TREE_CHAIN (arg);
1833   arg3 = TREE_CHAIN (arg2);
1834   if (arg3)
1835     {
1836       /* Use a library function for the 3 parameter version.  */
1837       tree int4type = gfc_get_int_type (4);
1838
1839       type = TREE_TYPE (TREE_VALUE (arg));
1840       /* We convert the first argument to at least 4 bytes, and
1841          convert back afterwards.  This removes the need for library
1842          functions for all argument sizes, and function will be
1843          aligned to at least 32 bits, so there's no loss.  */
1844       if (expr->ts.kind < 4)
1845         {
1846           tmp = convert (int4type, TREE_VALUE (arg));
1847           TREE_VALUE (arg) = tmp;
1848         }
1849       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1850          need loads of library  functions.  They cannot have values >
1851          BIT_SIZE (I) so the conversion is safe.  */
1852       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
1853       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
1854
1855       switch (expr->ts.kind)
1856         {
1857         case 1:
1858         case 2:
1859         case 4:
1860           tmp = gfor_fndecl_math_ishftc4;
1861           break;
1862         case 8:
1863           tmp = gfor_fndecl_math_ishftc8;
1864           break;
1865         default:
1866           gcc_unreachable ();
1867         }
1868       se->expr = gfc_build_function_call (tmp, arg);
1869       /* Convert the result back to the original type, if we extended
1870          the first argument's width above.  */
1871       if (expr->ts.kind < 4)
1872         se->expr = convert (type, se->expr);
1873
1874       return;
1875     }
1876   arg = TREE_VALUE (arg);
1877   arg2 = TREE_VALUE (arg2);
1878   type = TREE_TYPE (arg);
1879
1880   /* Rotate left if positive.  */
1881   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
1882
1883   /* Rotate right if negative.  */
1884   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1885   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
1886
1887   zero = build_int_cst (TREE_TYPE (arg2), 0);
1888   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
1889   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
1890
1891   /* Do nothing if shift == 0.  */
1892   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
1893   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
1894 }
1895
1896 /* The length of a character string.  */
1897 static void
1898 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1899 {
1900   tree len;
1901   tree type;
1902   tree decl;
1903   gfc_symbol *sym;
1904   gfc_se argse;
1905   gfc_expr *arg;
1906
1907   gcc_assert (!se->ss);
1908
1909   arg = expr->value.function.actual->expr;
1910
1911   type = gfc_typenode_for_spec (&expr->ts);
1912   switch (arg->expr_type)
1913     {
1914     case EXPR_CONSTANT:
1915       len = build_int_cst (NULL_TREE, arg->value.character.length);
1916       break;
1917
1918     default:
1919         if (arg->expr_type == EXPR_VARIABLE
1920             && (arg->ref == NULL || (arg->ref->next == NULL
1921                                      && arg->ref->type == REF_ARRAY)))
1922           {
1923             /* This doesn't catch all cases.
1924                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1925                and the surrounding thread.  */
1926             sym = arg->symtree->n.sym;
1927             decl = gfc_get_symbol_decl (sym);
1928             if (decl == current_function_decl && sym->attr.function
1929                 && (sym->result == sym))
1930               decl = gfc_get_fake_result_decl (sym);
1931
1932             len = sym->ts.cl->backend_decl;
1933             gcc_assert (len);
1934           }
1935         else
1936           {
1937             /* Anybody stupid enough to do this deserves inefficient code.  */
1938             gfc_init_se (&argse, se);
1939             gfc_conv_expr (&argse, arg);
1940             gfc_add_block_to_block (&se->pre, &argse.pre);
1941             gfc_add_block_to_block (&se->post, &argse.post);
1942             len = argse.string_length;
1943         }
1944       break;
1945     }
1946   se->expr = convert (type, len);
1947 }
1948
1949 /* The length of a character string not including trailing blanks.  */
1950 static void
1951 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1952 {
1953   tree args;
1954   tree type;
1955
1956   args = gfc_conv_intrinsic_function_args (se, expr);
1957   type = gfc_typenode_for_spec (&expr->ts);
1958   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1959   se->expr = convert (type, se->expr);
1960 }
1961
1962
1963 /* Returns the starting position of a substring within a string.  */
1964
1965 static void
1966 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1967 {
1968   tree logical4_type_node = gfc_get_logical_type (4);
1969   tree args;
1970   tree back;
1971   tree type;
1972   tree tmp;
1973
1974   args = gfc_conv_intrinsic_function_args (se, expr);
1975   type = gfc_typenode_for_spec (&expr->ts);
1976   tmp = gfc_advance_chain (args, 3);
1977   if (TREE_CHAIN (tmp) == NULL_TREE)
1978     {
1979       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
1980                         NULL_TREE);
1981       TREE_CHAIN (tmp) = back;
1982     }
1983   else
1984     {
1985       back = TREE_CHAIN (tmp);
1986       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
1987     }
1988
1989   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1990   se->expr = convert (type, se->expr);
1991 }
1992
1993 /* The ascii value for a single character.  */
1994 static void
1995 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1996 {
1997   tree arg;
1998   tree type;
1999
2000   arg = gfc_conv_intrinsic_function_args (se, expr);
2001   arg = TREE_VALUE (TREE_CHAIN (arg));
2002   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2003   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2004   type = gfc_typenode_for_spec (&expr->ts);
2005
2006   se->expr = gfc_build_indirect_ref (arg);
2007   se->expr = convert (type, se->expr);
2008 }
2009
2010
2011 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2012
2013 static void
2014 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2015 {
2016   tree arg;
2017   tree tsource;
2018   tree fsource;
2019   tree mask;
2020   tree type;
2021   tree len;
2022
2023   arg = gfc_conv_intrinsic_function_args (se, expr);
2024   if (expr->ts.type != BT_CHARACTER)
2025     {
2026       tsource = TREE_VALUE (arg);
2027       arg = TREE_CHAIN (arg);
2028       fsource = TREE_VALUE (arg);
2029       mask = TREE_VALUE (TREE_CHAIN (arg));
2030     }
2031   else
2032     {
2033       /* We do the same as in the non-character case, but the argument
2034          list is different because of the string length arguments. We
2035          also have to set the string length for the result.  */
2036       len = TREE_VALUE (arg);
2037       arg = TREE_CHAIN (arg);
2038       tsource = TREE_VALUE (arg);
2039       arg = TREE_CHAIN (TREE_CHAIN (arg));
2040       fsource = TREE_VALUE (arg);
2041       mask = TREE_VALUE (TREE_CHAIN (arg));
2042
2043       se->string_length = len;
2044     }
2045   type = TREE_TYPE (tsource);
2046   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2047 }
2048
2049
2050 static void
2051 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2052 {
2053   gfc_actual_arglist *actual;
2054   tree args;
2055   tree type;
2056   tree fndecl;
2057   gfc_se argse;
2058   gfc_ss *ss;
2059
2060   gfc_init_se (&argse, NULL);
2061   actual = expr->value.function.actual;
2062
2063   ss = gfc_walk_expr (actual->expr);
2064   gcc_assert (ss != gfc_ss_terminator);
2065   argse.want_pointer = 1;
2066   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2067   gfc_add_block_to_block (&se->pre, &argse.pre);
2068   gfc_add_block_to_block (&se->post, &argse.post);
2069   args = gfc_chainon_list (NULL_TREE, argse.expr);
2070
2071   actual = actual->next;
2072   if (actual->expr)
2073     {
2074       gfc_init_se (&argse, NULL);
2075       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2076       gfc_add_block_to_block (&se->pre, &argse.pre);
2077       args = gfc_chainon_list (args, argse.expr);
2078       fndecl = gfor_fndecl_size1;
2079     }
2080   else
2081     fndecl = gfor_fndecl_size0;
2082
2083   se->expr = gfc_build_function_call (fndecl, args);
2084   type = gfc_typenode_for_spec (&expr->ts);
2085   se->expr = convert (type, se->expr);
2086 }
2087
2088
2089 /* Intrinsic string comparison functions.  */
2090
2091   static void
2092 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2093 {
2094   tree type;
2095   tree args;
2096
2097   args = gfc_conv_intrinsic_function_args (se, expr);
2098   /* Build a call for the comparison.  */
2099   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2100
2101   type = gfc_typenode_for_spec (&expr->ts);
2102   se->expr = build2 (op, type, se->expr,
2103                      build_int_cst (TREE_TYPE (se->expr), 0));
2104 }
2105
2106 /* Generate a call to the adjustl/adjustr library function.  */
2107 static void
2108 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2109 {
2110   tree args;
2111   tree len;
2112   tree type;
2113   tree var;
2114   tree tmp;
2115
2116   args = gfc_conv_intrinsic_function_args (se, expr);
2117   len = TREE_VALUE (args);
2118
2119   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2120   var = gfc_conv_string_tmp (se, type, len);
2121   args = tree_cons (NULL_TREE, var, args);
2122
2123   tmp = gfc_build_function_call (fndecl, args);
2124   gfc_add_expr_to_block (&se->pre, tmp);
2125   se->expr = var;
2126   se->string_length = len;
2127 }
2128
2129
2130 /* Scalar transfer statement.
2131    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2132
2133 static void
2134 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2135 {
2136   gfc_actual_arglist *arg;
2137   gfc_se argse;
2138   tree type;
2139   tree ptr;
2140   gfc_ss *ss;
2141
2142   gcc_assert (!se->ss);
2143
2144   /* Get a pointer to the source.  */
2145   arg = expr->value.function.actual;
2146   ss = gfc_walk_expr (arg->expr);
2147   gfc_init_se (&argse, NULL);
2148   if (ss == gfc_ss_terminator)
2149     gfc_conv_expr_reference (&argse, arg->expr);
2150   else
2151     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2152   gfc_add_block_to_block (&se->pre, &argse.pre);
2153   gfc_add_block_to_block (&se->post, &argse.post);
2154   ptr = argse.expr;
2155
2156   arg = arg->next;
2157   type = gfc_typenode_for_spec (&expr->ts);
2158   ptr = convert (build_pointer_type (type), ptr);
2159   if (expr->ts.type == BT_CHARACTER)
2160     {
2161       gfc_init_se (&argse, NULL);
2162       gfc_conv_expr (&argse, arg->expr);
2163       gfc_add_block_to_block (&se->pre, &argse.pre);
2164       gfc_add_block_to_block (&se->post, &argse.post);
2165       se->expr = ptr;
2166       se->string_length = argse.string_length;
2167     }
2168   else
2169     {
2170       se->expr = gfc_build_indirect_ref (ptr);
2171     }
2172 }
2173
2174
2175 /* Generate code for the ALLOCATED intrinsic.
2176    Generate inline code that directly check the address of the argument.  */
2177
2178 static void
2179 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2180 {
2181   gfc_actual_arglist *arg1;
2182   gfc_se arg1se;
2183   gfc_ss *ss1;
2184   tree tmp;
2185
2186   gfc_init_se (&arg1se, NULL);
2187   arg1 = expr->value.function.actual;
2188   ss1 = gfc_walk_expr (arg1->expr);
2189   arg1se.descriptor_only = 1;
2190   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2191
2192   tmp = gfc_conv_descriptor_data (arg1se.expr);
2193   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2194                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2195   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2196 }
2197
2198
2199 /* Generate code for the ASSOCIATED intrinsic.
2200    If both POINTER and TARGET are arrays, generate a call to library function
2201    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2202    In other cases, generate inline code that directly compare the address of
2203    POINTER with the address of TARGET.  */
2204
2205 static void
2206 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2207 {
2208   gfc_actual_arglist *arg1;
2209   gfc_actual_arglist *arg2;
2210   gfc_se arg1se;
2211   gfc_se arg2se;
2212   tree tmp2;
2213   tree tmp;
2214   tree args, fndecl;
2215   gfc_ss *ss1, *ss2;
2216
2217   gfc_init_se (&arg1se, NULL);
2218   gfc_init_se (&arg2se, NULL);
2219   arg1 = expr->value.function.actual;
2220   arg2 = arg1->next;
2221   ss1 = gfc_walk_expr (arg1->expr);
2222
2223   if (!arg2->expr)
2224     {
2225       /* No optional target.  */
2226       if (ss1 == gfc_ss_terminator)
2227         {
2228           /* A pointer to a scalar.  */
2229           arg1se.want_pointer = 1;
2230           gfc_conv_expr (&arg1se, arg1->expr);
2231           tmp2 = arg1se.expr;
2232         }
2233       else
2234         {
2235           /* A pointer to an array.  */
2236           arg1se.descriptor_only = 1;
2237           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2238           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2239         }
2240       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2241                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2242       se->expr = tmp;
2243     }
2244   else
2245     {
2246       /* An optional target.  */
2247       ss2 = gfc_walk_expr (arg2->expr);
2248       if (ss1 == gfc_ss_terminator)
2249         {
2250           /* A pointer to a scalar.  */
2251           gcc_assert (ss2 == gfc_ss_terminator);
2252           arg1se.want_pointer = 1;
2253           gfc_conv_expr (&arg1se, arg1->expr);
2254           arg2se.want_pointer = 1;
2255           gfc_conv_expr (&arg2se, arg2->expr);
2256           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2257           se->expr = tmp;
2258         }
2259       else
2260         {
2261           /* A pointer to an array, call library function _gfor_associated.  */
2262           gcc_assert (ss2 != gfc_ss_terminator);
2263           args = NULL_TREE;
2264           arg1se.want_pointer = 1;
2265           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2266           args = gfc_chainon_list (args, arg1se.expr);
2267           arg2se.want_pointer = 1;
2268           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2269           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2270           gfc_add_block_to_block (&se->post, &arg2se.post);
2271           args = gfc_chainon_list (args, arg2se.expr);
2272           fndecl = gfor_fndecl_associated;
2273           se->expr = gfc_build_function_call (fndecl, args);
2274         }
2275      }
2276   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2277 }
2278
2279
2280 /* Scan a string for any one of the characters in a set of characters.  */
2281
2282 static void
2283 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2284 {
2285   tree logical4_type_node = gfc_get_logical_type (4);
2286   tree args;
2287   tree back;
2288   tree type;
2289   tree tmp;
2290
2291   args = gfc_conv_intrinsic_function_args (se, expr);
2292   type = gfc_typenode_for_spec (&expr->ts);
2293   tmp = gfc_advance_chain (args, 3);
2294   if (TREE_CHAIN (tmp) == NULL_TREE)
2295     {
2296       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2297                         NULL_TREE);
2298       TREE_CHAIN (tmp) = back;
2299     }
2300   else
2301     {
2302       back = TREE_CHAIN (tmp);
2303       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2304     }
2305
2306   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2307   se->expr = convert (type, se->expr);
2308 }
2309
2310
2311 /* Verify that a set of characters contains all the characters in a string
2312    by identifying the position of the first character in a string of
2313    characters that does not appear in a given set of characters.  */
2314
2315 static void
2316 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2317 {
2318   tree logical4_type_node = gfc_get_logical_type (4);
2319   tree args;
2320   tree back;
2321   tree type;
2322   tree tmp;
2323
2324   args = gfc_conv_intrinsic_function_args (se, expr);
2325   type = gfc_typenode_for_spec (&expr->ts);
2326   tmp = gfc_advance_chain (args, 3);
2327   if (TREE_CHAIN (tmp) == NULL_TREE)
2328     {
2329       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2330                         NULL_TREE);
2331       TREE_CHAIN (tmp) = back;
2332     }
2333   else
2334     {
2335       back = TREE_CHAIN (tmp);
2336       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2337     }
2338
2339   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2340   se->expr = convert (type, se->expr);
2341 }
2342
2343 /* Prepare components and related information of a real number which is
2344    the first argument of a elemental functions to manipulate reals.  */
2345
2346 static void
2347 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2348                   real_compnt_info * rcs, int all)
2349 {
2350    tree arg;
2351    tree masktype;
2352    tree tmp;
2353    tree wbits;
2354    tree one;
2355    tree exponent, fraction;
2356    int n;
2357    gfc_expr *a1;
2358
2359    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2360      gfc_todo_error ("Non-IEEE floating format");
2361
2362    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2363
2364    arg = gfc_conv_intrinsic_function_args (se, expr);
2365    arg = TREE_VALUE (arg);
2366    rcs->type = TREE_TYPE (arg);
2367
2368    /* Force arg'type to integer by unaffected convert  */
2369    a1 = expr->value.function.actual->expr;
2370    masktype = gfc_get_int_type (a1->ts.kind);
2371    rcs->mtype = masktype;
2372    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2373    arg = gfc_create_var (masktype, "arg");
2374    gfc_add_modify_expr(&se->pre, arg, tmp);
2375    rcs->arg = arg;
2376
2377    /* Calculate the numbers of bits of exponent, fraction and word  */
2378    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2379    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2380    rcs->fdigits = convert (masktype, tmp);
2381    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2382    wbits = convert (masktype, wbits);
2383    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
2384
2385    /* Form masks for exponent/fraction/sign  */
2386    one = gfc_build_const (masktype, integer_one_node);
2387    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
2388    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
2389    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
2390    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
2391    /* Form bias.  */
2392    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
2393    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
2394    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
2395
2396    if (all)
2397      {
2398        /* exponent, and fraction  */
2399        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2400        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2401        exponent = gfc_create_var (masktype, "exponent");
2402        gfc_add_modify_expr(&se->pre, exponent, tmp);
2403        rcs->expn = exponent;
2404
2405        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2406        fraction = gfc_create_var (masktype, "fraction");
2407        gfc_add_modify_expr(&se->pre, fraction, tmp);
2408        rcs->frac = fraction;
2409      }
2410 }
2411
2412 /* Build a call to __builtin_clz.  */
2413
2414 static tree
2415 call_builtin_clz (tree result_type, tree op0)
2416 {
2417   tree fn, parms, call;
2418   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2419
2420   if (op0_mode == TYPE_MODE (integer_type_node))
2421     fn = built_in_decls[BUILT_IN_CLZ];
2422   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2423     fn = built_in_decls[BUILT_IN_CLZL];
2424   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2425     fn = built_in_decls[BUILT_IN_CLZLL];
2426   else
2427     gcc_unreachable ();
2428
2429   parms = tree_cons (NULL, op0, NULL);
2430   call = gfc_build_function_call (fn, parms);
2431
2432   return convert (result_type, call);
2433 }
2434
2435
2436 /* Generate code for SPACING (X) intrinsic function.
2437    SPACING (X) = POW (2, e-p)
2438
2439    We generate:
2440
2441     t = expn - fdigits // e - p.
2442     res = t << fdigits // Form the exponent. Fraction is zero.
2443     if (t < 0) // The result is out of range. Denormalized case.
2444       res = tiny(X)
2445  */
2446
2447 static void
2448 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2449 {
2450    tree arg;
2451    tree masktype;
2452    tree tmp, t1, cond;
2453    tree tiny, zero;
2454    tree fdigits;
2455    real_compnt_info rcs;
2456
2457    prepare_arg_info (se, expr, &rcs, 0);
2458    arg = rcs.arg;
2459    masktype = rcs.mtype;
2460    fdigits = rcs.fdigits;
2461    tiny = rcs.f1;
2462    zero = gfc_build_const (masktype, integer_zero_node);
2463    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2464    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2465    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2466    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2467    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2468    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2469    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2470
2471    se->expr = tmp;
2472 }
2473
2474 /* Generate code for RRSPACING (X) intrinsic function.
2475    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2476
2477    So the result's exponent is p. And if X is normalized, X's fraction part
2478    is the result's fraction. If X is denormalized, to get the X's fraction we
2479    shift X's fraction part to left until the first '1' is removed.
2480
2481    We generate:
2482
2483     if (expn == 0 && frac == 0)
2484        res = 0;
2485     else
2486     {
2487        // edigits is the number of exponent bits. Add the sign bit.
2488        sedigits = edigits + 1;
2489
2490        if (expn == 0) // Denormalized case.
2491        {
2492          t1 = leadzero (frac);
2493          frac = frac << (t1 + 1); //Remove the first '1'.
2494          frac = frac >> (sedigits); //Form the fraction.
2495        }
2496
2497        //fdigits is the number of fraction bits. Form the exponent.
2498        t = bias + fdigits;
2499
2500        res = (t << fdigits) | frac;
2501     }
2502 */
2503
2504 static void
2505 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2506 {
2507    tree masktype;
2508    tree tmp, t1, t2, cond, cond2;
2509    tree one, zero;
2510    tree fdigits, fraction;
2511    real_compnt_info rcs;
2512
2513    prepare_arg_info (se, expr, &rcs, 1);
2514    masktype = rcs.mtype;
2515    fdigits = rcs.fdigits;
2516    fraction = rcs.frac;
2517    one = gfc_build_const (masktype, integer_one_node);
2518    zero = gfc_build_const (masktype, integer_zero_node);
2519    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
2520
2521    t1 = call_builtin_clz (masktype, fraction);
2522    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2523    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2524    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2525    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2526    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2527
2528    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
2529    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2530    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2531
2532    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2533    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2534    tmp = build3 (COND_EXPR, masktype, cond,
2535                  build_int_cst (masktype, 0), tmp);
2536
2537    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2538    se->expr = tmp;
2539 }
2540
2541 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2542
2543 static void
2544 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2545 {
2546   tree args;
2547
2548   args = gfc_conv_intrinsic_function_args (se, expr);
2549   args = TREE_VALUE (args);
2550   args = gfc_build_addr_expr (NULL, args);
2551   args = tree_cons (NULL_TREE, args, NULL_TREE);
2552   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2553 }
2554
2555 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2556
2557 static void
2558 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2559 {
2560   gfc_actual_arglist *actual;
2561   tree args;
2562   gfc_se argse;
2563
2564   args = NULL_TREE;
2565   for (actual = expr->value.function.actual; actual; actual = actual->next)
2566     {
2567       gfc_init_se (&argse, se);
2568
2569       /* Pass a NULL pointer for an absent arg.  */
2570       if (actual->expr == NULL)
2571         argse.expr = null_pointer_node;
2572       else
2573         gfc_conv_expr_reference (&argse, actual->expr);
2574
2575       gfc_add_block_to_block (&se->pre, &argse.pre);
2576       gfc_add_block_to_block (&se->post, &argse.post);
2577       args = gfc_chainon_list (args, argse.expr);
2578     }
2579   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2580 }
2581
2582
2583 /* Generate code for TRIM (A) intrinsic function.  */
2584
2585 static void
2586 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2587 {
2588   tree gfc_int4_type_node = gfc_get_int_type (4);
2589   tree var;
2590   tree len;
2591   tree addr;
2592   tree tmp;
2593   tree arglist;
2594   tree type;
2595   tree cond;
2596
2597   arglist = NULL_TREE;
2598
2599   type = build_pointer_type (gfc_character1_type_node);
2600   var = gfc_create_var (type, "pstr");
2601   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2602   len = gfc_create_var (gfc_int4_type_node, "len");
2603
2604   tmp = gfc_conv_intrinsic_function_args (se, expr);
2605   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2606   arglist = gfc_chainon_list (arglist, addr);
2607   arglist = chainon (arglist, tmp);
2608
2609   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2610   gfc_add_expr_to_block (&se->pre, tmp);
2611
2612   /* Free the temporary afterwards, if necessary.  */
2613   cond = build2 (GT_EXPR, boolean_type_node, len,
2614                  build_int_cst (TREE_TYPE (len), 0));
2615   arglist = gfc_chainon_list (NULL_TREE, var);
2616   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2617   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2618   gfc_add_expr_to_block (&se->post, tmp);
2619
2620   se->expr = var;
2621   se->string_length = len;
2622 }
2623
2624
2625 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2626
2627 static void
2628 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2629 {
2630   tree gfc_int4_type_node = gfc_get_int_type (4);
2631   tree tmp;
2632   tree len;
2633   tree args;
2634   tree arglist;
2635   tree ncopies;
2636   tree var;
2637   tree type;
2638
2639   args = gfc_conv_intrinsic_function_args (se, expr);
2640   len = TREE_VALUE (args);
2641   tmp = gfc_advance_chain (args, 2);
2642   ncopies = TREE_VALUE (tmp);
2643   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
2644   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2645   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2646
2647   arglist = NULL_TREE;
2648   arglist = gfc_chainon_list (arglist, var);
2649   arglist = chainon (arglist, args);
2650   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2651   gfc_add_expr_to_block (&se->pre, tmp);
2652
2653   se->expr = var;
2654   se->string_length = len;
2655 }
2656
2657
2658 /* Generate code for the IARGC intrinsic.  */
2659
2660 static void
2661 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
2662 {
2663   tree tmp;
2664   tree fndecl;
2665   tree type;
2666
2667   /* Call the library function.  This always returns an INTEGER(4).  */
2668   fndecl = gfor_fndecl_iargc;
2669   tmp = gfc_build_function_call (fndecl, NULL_TREE);
2670
2671   /* Convert it to the required type.  */
2672   type = gfc_typenode_for_spec (&expr->ts);
2673   tmp = fold_convert (type, tmp);
2674
2675   se->expr = tmp;
2676 }
2677
2678 /* Generate code for an intrinsic function.  Some map directly to library
2679    calls, others get special handling.  In some cases the name of the function
2680    used depends on the type specifiers.  */
2681
2682 void
2683 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2684 {
2685   gfc_intrinsic_sym *isym;
2686   const char *name;
2687   int lib;
2688
2689   isym = expr->value.function.isym;
2690
2691   name = &expr->value.function.name[2];
2692
2693   if (expr->rank > 0)
2694     {
2695       lib = gfc_is_intrinsic_libcall (expr);
2696       if (lib != 0)
2697         {
2698           if (lib == 1)
2699             se->ignore_optional = 1;
2700           gfc_conv_intrinsic_funcall (se, expr);
2701           return;
2702         }
2703     }
2704
2705   switch (expr->value.function.isym->generic_id)
2706     {
2707     case GFC_ISYM_NONE:
2708       gcc_unreachable ();
2709
2710     case GFC_ISYM_REPEAT:
2711       gfc_conv_intrinsic_repeat (se, expr);
2712       break;
2713
2714     case GFC_ISYM_TRIM:
2715       gfc_conv_intrinsic_trim (se, expr);
2716       break;
2717
2718     case GFC_ISYM_SI_KIND:
2719       gfc_conv_intrinsic_si_kind (se, expr);
2720       break;
2721
2722     case GFC_ISYM_SR_KIND:
2723       gfc_conv_intrinsic_sr_kind (se, expr);
2724       break;
2725
2726     case GFC_ISYM_EXPONENT:
2727       gfc_conv_intrinsic_exponent (se, expr);
2728       break;
2729
2730     case GFC_ISYM_SPACING:
2731       gfc_conv_intrinsic_spacing (se, expr);
2732       break;
2733
2734     case GFC_ISYM_RRSPACING:
2735       gfc_conv_intrinsic_rrspacing (se, expr);
2736       break;
2737
2738     case GFC_ISYM_SCAN:
2739       gfc_conv_intrinsic_scan (se, expr);
2740       break;
2741
2742     case GFC_ISYM_VERIFY:
2743       gfc_conv_intrinsic_verify (se, expr);
2744       break;
2745
2746     case GFC_ISYM_ALLOCATED:
2747       gfc_conv_allocated (se, expr);
2748       break;
2749
2750     case GFC_ISYM_ASSOCIATED:
2751       gfc_conv_associated(se, expr);
2752       break;
2753
2754     case GFC_ISYM_ABS:
2755       gfc_conv_intrinsic_abs (se, expr);
2756       break;
2757
2758     case GFC_ISYM_ADJUSTL:
2759       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2760       break;
2761
2762     case GFC_ISYM_ADJUSTR:
2763       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2764       break;
2765
2766     case GFC_ISYM_AIMAG:
2767       gfc_conv_intrinsic_imagpart (se, expr);
2768       break;
2769
2770     case GFC_ISYM_AINT:
2771       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2772       break;
2773
2774     case GFC_ISYM_ALL:
2775       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2776       break;
2777
2778     case GFC_ISYM_ANINT:
2779       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2780       break;
2781
2782     case GFC_ISYM_ANY:
2783       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2784       break;
2785
2786     case GFC_ISYM_BTEST:
2787       gfc_conv_intrinsic_btest (se, expr);
2788       break;
2789
2790     case GFC_ISYM_ACHAR:
2791     case GFC_ISYM_CHAR:
2792       gfc_conv_intrinsic_char (se, expr);
2793       break;
2794
2795     case GFC_ISYM_CONVERSION:
2796     case GFC_ISYM_REAL:
2797     case GFC_ISYM_LOGICAL:
2798     case GFC_ISYM_DBLE:
2799       gfc_conv_intrinsic_conversion (se, expr);
2800       break;
2801
2802       /* Integer conversions are handled separately to make sure we get the
2803          correct rounding mode.  */
2804     case GFC_ISYM_INT:
2805       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2806       break;
2807
2808     case GFC_ISYM_NINT:
2809       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2810       break;
2811
2812     case GFC_ISYM_CEILING:
2813       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2814       break;
2815
2816     case GFC_ISYM_FLOOR:
2817       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2818       break;
2819
2820     case GFC_ISYM_MOD:
2821       gfc_conv_intrinsic_mod (se, expr, 0);
2822       break;
2823
2824     case GFC_ISYM_MODULO:
2825       gfc_conv_intrinsic_mod (se, expr, 1);
2826       break;
2827
2828     case GFC_ISYM_CMPLX:
2829       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2830       break;
2831
2832     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2833       gfc_conv_intrinsic_iargc (se, expr);
2834       break;
2835
2836     case GFC_ISYM_CONJG:
2837       gfc_conv_intrinsic_conjg (se, expr);
2838       break;
2839
2840     case GFC_ISYM_COUNT:
2841       gfc_conv_intrinsic_count (se, expr);
2842       break;
2843
2844     case GFC_ISYM_DIM:
2845       gfc_conv_intrinsic_dim (se, expr);
2846       break;
2847
2848     case GFC_ISYM_DPROD:
2849       gfc_conv_intrinsic_dprod (se, expr);
2850       break;
2851
2852     case GFC_ISYM_IAND:
2853       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2854       break;
2855
2856     case GFC_ISYM_IBCLR:
2857       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2858       break;
2859
2860     case GFC_ISYM_IBITS:
2861       gfc_conv_intrinsic_ibits (se, expr);
2862       break;
2863
2864     case GFC_ISYM_IBSET:
2865       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2866       break;
2867
2868     case GFC_ISYM_IACHAR:
2869     case GFC_ISYM_ICHAR:
2870       /* We assume ASCII character sequence.  */
2871       gfc_conv_intrinsic_ichar (se, expr);
2872       break;
2873
2874     case GFC_ISYM_IARGC:
2875       gfc_conv_intrinsic_iargc (se, expr);
2876       break;
2877
2878     case GFC_ISYM_IEOR:
2879       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2880       break;
2881
2882     case GFC_ISYM_INDEX:
2883       gfc_conv_intrinsic_index (se, expr);
2884       break;
2885
2886     case GFC_ISYM_IOR:
2887       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2888       break;
2889
2890     case GFC_ISYM_ISHFT:
2891       gfc_conv_intrinsic_ishft (se, expr);
2892       break;
2893
2894     case GFC_ISYM_ISHFTC:
2895       gfc_conv_intrinsic_ishftc (se, expr);
2896       break;
2897
2898     case GFC_ISYM_LBOUND:
2899       gfc_conv_intrinsic_bound (se, expr, 0);
2900       break;
2901
2902     case GFC_ISYM_LEN:
2903       gfc_conv_intrinsic_len (se, expr);
2904       break;
2905
2906     case GFC_ISYM_LEN_TRIM:
2907       gfc_conv_intrinsic_len_trim (se, expr);
2908       break;
2909
2910     case GFC_ISYM_LGE:
2911       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2912       break;
2913
2914     case GFC_ISYM_LGT:
2915       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2916       break;
2917
2918     case GFC_ISYM_LLE:
2919       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2920       break;
2921
2922     case GFC_ISYM_LLT:
2923       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2924       break;
2925
2926     case GFC_ISYM_MAX:
2927       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2928       break;
2929
2930     case GFC_ISYM_MAXLOC:
2931       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2932       break;
2933
2934     case GFC_ISYM_MAXVAL:
2935       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2936       break;
2937
2938     case GFC_ISYM_MERGE:
2939       gfc_conv_intrinsic_merge (se, expr);
2940       break;
2941
2942     case GFC_ISYM_MIN:
2943       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2944       break;
2945
2946     case GFC_ISYM_MINLOC:
2947       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2948       break;
2949
2950     case GFC_ISYM_MINVAL:
2951       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2952       break;
2953
2954     case GFC_ISYM_NOT:
2955       gfc_conv_intrinsic_not (se, expr);
2956       break;
2957
2958     case GFC_ISYM_PRESENT:
2959       gfc_conv_intrinsic_present (se, expr);
2960       break;
2961
2962     case GFC_ISYM_PRODUCT:
2963       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2964       break;
2965
2966     case GFC_ISYM_SIGN:
2967       gfc_conv_intrinsic_sign (se, expr);
2968       break;
2969
2970     case GFC_ISYM_SIZE:
2971       gfc_conv_intrinsic_size (se, expr);
2972       break;
2973
2974     case GFC_ISYM_SUM:
2975       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2976       break;
2977
2978     case GFC_ISYM_TRANSFER:
2979       gfc_conv_intrinsic_transfer (se, expr);
2980       break;
2981
2982     case GFC_ISYM_UBOUND:
2983       gfc_conv_intrinsic_bound (se, expr, 1);
2984       break;
2985
2986     case GFC_ISYM_CHDIR:
2987     case GFC_ISYM_DOT_PRODUCT:
2988     case GFC_ISYM_ETIME:
2989     case GFC_ISYM_FNUM:
2990     case GFC_ISYM_FSTAT:
2991     case GFC_ISYM_GETCWD:
2992     case GFC_ISYM_GETGID:
2993     case GFC_ISYM_GETPID:
2994     case GFC_ISYM_GETUID:
2995     case GFC_ISYM_HOSTNM:
2996     case GFC_ISYM_KILL:
2997     case GFC_ISYM_IERRNO:
2998     case GFC_ISYM_IRAND:
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"