gcc/fortran/trans-intrinsic.c

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