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