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