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