gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  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 "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "tree-gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct gfc_intrinsic_map_t      GTY(())
  49 {
  50   /* The explicit enum is required to work around inadequacies in the
  51      garbage collection/gengtype parsing mechanism.  */
  52   enum gfc_isym_id id;
  53
  54   /* Enum value from the "language-independent", aka C-centric, part
  55      of gcc, or END_BUILTINS of no such value set.  */
  56   enum built_in_function code_r4;
  57   enum built_in_function code_r8;
  58   enum built_in_function code_r10;
  59   enum built_in_function code_r16;
  60   enum built_in_function code_c4;
  61   enum built_in_function code_c8;
  62   enum built_in_function code_c10;
  63   enum built_in_function code_c16;
  64
  65   /* True if the naming pattern is to prepend "c" for complex and
  66      append "f" for kind=4.  False if the naming pattern is to
  67      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  68   bool libm_name;
  69
  70   /* True if a complex version of the function exists.  */
  71   bool complex_available;
  72
  73   /* True if the function should be marked const.  */
  74   bool is_constant;
  75
  76   /* The base library name of this function.  */
  77   const char *name;
  78
  79   /* Cache decls created for the various operand types.  */
  80   tree real4_decl;
  81   tree real8_decl;
  82   tree real10_decl;
  83   tree real16_decl;
  84   tree complex4_decl;
  85   tree complex8_decl;
  86   tree complex10_decl;
  87   tree complex16_decl;
  88 }
  89 gfc_intrinsic_map_t;
  90
  91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  92    defines complex variants of all of the entries in mathbuiltins.def
  93    except for atan2.  */
  94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  95   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  96     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  97     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  99
 100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 106
 107 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 112
 113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 114   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 115     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 116     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 117     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 118
 119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 120 {
 121   /* Functions built into gcc itself.  */
 122 #include "mathbuiltins.def"
 123
 124   /* Functions in libm.  */
 125   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 126      pattern for other mathbuiltins.def entries.  At present we have no
 127      optimizations for this in the common sources.  */
 128   LIBM_FUNCTION (SCALE, "scalbn", false),
 129
 130   /* Functions in libgfortran.  */
 131   LIBF_FUNCTION (FRACTION, "fraction", false),
 132   LIBF_FUNCTION (NEAREST, "nearest", false),
 133   LIBF_FUNCTION (RRSPACING, "rrspacing", false),
 134   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 135   LIBF_FUNCTION (SPACING, "spacing", false),
 136
 137   /* End the list.  */
 138   LIBF_FUNCTION (NONE, NULL, false)
 139 };
 140 #undef DEFINE_MATH_BUILTIN
 141 #undef DEFINE_MATH_BUILTIN_C
 142 #undef LIBM_FUNCTION
 143 #undef LIBF_FUNCTION
 144
 145 /* Structure for storing components of a floating number to be used by
 146    elemental functions to manipulate reals.  */
 147 typedef struct
 148 {
 149   tree arg;     /* Variable tree to view convert to integer.  */
 150   tree expn;    /* Variable tree to save exponent.  */
 151   tree frac;    /* Variable tree to save fraction.  */
 152   tree smask;   /* Constant tree of sign's mask.  */
 153   tree emask;   /* Constant tree of exponent's mask.  */
 154   tree fmask;   /* Constant tree of fraction's mask.  */
 155   tree edigits; /* Constant tree of the number of exponent bits.  */
 156   tree fdigits; /* Constant tree of the number of fraction bits.  */
 157   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 158   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 159   tree type;    /* Type tree of arg1.  */
 160   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 161 }
 162 real_compnt_info;
 163
 164 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 165
 166 /* Evaluate the arguments to an intrinsic function.  The value
 167    of NARGS may be less than the actual number of arguments in EXPR
 168    to allow optional "KIND" arguments that are not included in the
 169    generated code to be ignored.  */
 170
 171 static void
 172 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 173                                   tree *argarray, int nargs)
 174 {
 175   gfc_actual_arglist *actual;
 176   gfc_expr *e;
 177   gfc_intrinsic_arg  *formal;
 178   gfc_se argse;
 179   int curr_arg;
 180
 181   formal = expr->value.function.isym->formal;
 182   actual = expr->value.function.actual;
 183
 184    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 185         actual = actual->next,
 186         formal = formal ? formal->next : NULL)
 187     {
 188       gcc_assert (actual);
 189       e = actual->expr;
 190       /* Skip omitted optional arguments.  */
 191       if (!e)
 192         {
 193           --curr_arg;
 194           continue;
 195         }
 196
 197       /* Evaluate the parameter.  This will substitute scalarized
 198          references automatically.  */
 199       gfc_init_se (&argse, se);
 200
 201       if (e->ts.type == BT_CHARACTER)
 202         {
 203           gfc_conv_expr (&argse, e);
 204           gfc_conv_string_parameter (&argse);
 205           argarray[curr_arg++] = argse.string_length;
 206           gcc_assert (curr_arg < nargs);
 207         }
 208       else
 209         gfc_conv_expr_val (&argse, e);
 210
 211       /* If an optional argument is itself an optional dummy argument,
 212          check its presence and substitute a null if absent.  */
 213       if (e->expr_type ==EXPR_VARIABLE
 214             && e->symtree->n.sym->attr.optional
 215             && formal
 216             && formal->optional)
 217         gfc_conv_missing_dummy (&argse, e, formal->ts);
 218
 219       gfc_add_block_to_block (&se->pre, &argse.pre);
 220       gfc_add_block_to_block (&se->post, &argse.post);
 221       argarray[curr_arg] = argse.expr;
 222     }
 223 }
 224
 225 /* Count the number of actual arguments to the intrinsic function EXPR
 226    including any "hidden" string length arguments.  */
 227
 228 static unsigned int
 229 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 230 {
 231   int n = 0;
 232   gfc_actual_arglist *actual;
 233
 234   for (actual = expr->value.function.actual; actual; actual = actual->next)
 235     {
 236       if (!actual->expr)
 237         continue;
 238
 239       if (actual->expr->ts.type == BT_CHARACTER)
 240         n += 2;
 241       else
 242         n++;
 243     }
 244
 245   return n;
 246 }
 247
 248
 249 /* Conversions between different types are output by the frontend as
 250    intrinsic functions.  We implement these directly with inline code.  */
 251
 252 static void
 253 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 254 {
 255   tree type;
 256   tree *args;
 257   int nargs;
 258
 259   nargs = gfc_intrinsic_argument_list_length (expr);
 260   args = alloca (sizeof (tree) * nargs);
 261
 262   /* Evaluate all the arguments passed. Whilst we're only interested in the
 263      first one here, there are other parts of the front-end that assume this
 264      and will trigger an ICE if it's not the case.  */
 265   type = gfc_typenode_for_spec (&expr->ts);
 266   gcc_assert (expr->value.function.actual->expr);
 267   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 268
 269   /* Conversion from complex to non-complex involves taking the real
 270      component of the value.  */
 271   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 272       && expr->ts.type != BT_COMPLEX)
 273     {
 274       tree artype;
 275
 276       artype = TREE_TYPE (TREE_TYPE (args[0]));
 277       args[0] = build1 (REALPART_EXPR, artype, args[0]);
 278     }
 279
 280   se->expr = convert (type, args[0]);
 281 }
 282
 283 /* This is needed because the gcc backend only implements
 284    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 285    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 286    Similarly for CEILING.  */
 287
 288 static tree
 289 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 290 {
 291   tree tmp;
 292   tree cond;
 293   tree argtype;
 294   tree intval;
 295
 296   argtype = TREE_TYPE (arg);
 297   arg = gfc_evaluate_now (arg, pblock);
 298
 299   intval = convert (type, arg);
 300   intval = gfc_evaluate_now (intval, pblock);
 301
 302   tmp = convert (argtype, intval);
 303   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 304
 305   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 306                 build_int_cst (type, 1));
 307   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 308   return tmp;
 309 }
 310
 311
 312 /* Round to nearest integer, away from zero.  */
 313
 314 static tree
 315 build_round_expr (tree arg, tree restype)
 316 {
 317   tree argtype;
 318   tree fn;
 319   bool longlong;
 320   int argprec, resprec;
 321
 322   argtype = TREE_TYPE (arg);
 323   argprec = TYPE_PRECISION (argtype);
 324   resprec = TYPE_PRECISION (restype);
 325
 326   /* Depending on the type of the result, choose the long int intrinsic
 327      (lround family) or long long intrinsic (llround).  We might also
 328      need to convert the result afterwards.  */
 329   if (resprec <= LONG_TYPE_SIZE)
 330     longlong = false;
 331   else if (resprec <= LONG_LONG_TYPE_SIZE)
 332     longlong = true;
 333   else
 334     gcc_unreachable ();
 335
 336   /* Now, depending on the argument type, we choose between intrinsics.  */
 337   if (argprec == TYPE_PRECISION (float_type_node))
 338     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
 339   else if (argprec == TYPE_PRECISION (double_type_node))
 340     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
 341   else if (argprec == TYPE_PRECISION (long_double_type_node))
 342     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
 343   else
 344     gcc_unreachable ();
 345
 346   return fold_convert (restype, build_call_expr (fn, 1, arg));
 347 }
 348
 349
 350 /* Convert a real to an integer using a specific rounding mode.
 351    Ideally we would just build the corresponding GENERIC node,
 352    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 353
 354 static tree
 355 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 356                enum rounding_mode op)
 357 {
 358   switch (op)
 359     {
 360     case RND_FLOOR:
 361       return build_fixbound_expr (pblock, arg, type, 0);
 362       break;
 363
 364     case RND_CEIL:
 365       return build_fixbound_expr (pblock, arg, type, 1);
 366       break;
 367
 368     case RND_ROUND:
 369       return build_round_expr (arg, type);
 370       break;
 371
 372     case RND_TRUNC:
 373       return build1 (FIX_TRUNC_EXPR, type, arg);
 374       break;
 375
 376     default:
 377       gcc_unreachable ();
 378     }
 379 }
 380
 381
 382 /* Round a real value using the specified rounding mode.
 383    We use a temporary integer of that same kind size as the result.
 384    Values larger than those that can be represented by this kind are
 385    unchanged, as they will not be accurate enough to represent the
 386    rounding.
 387     huge = HUGE (KIND (a))
 388     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 389    */
 390
 391 static void
 392 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 393 {
 394   tree type;
 395   tree itype;
 396   tree arg[2];
 397   tree tmp;
 398   tree cond;
 399   mpfr_t huge;
 400   int n, nargs;
 401   int kind;
 402
 403   kind = expr->ts.kind;
 404   nargs =  gfc_intrinsic_argument_list_length (expr);
 405
 406   n = END_BUILTINS;
 407   /* We have builtin functions for some cases.  */
 408   switch (op)
 409     {
 410     case RND_ROUND:
 411       switch (kind)
 412         {
 413         case 4:
 414           n = BUILT_IN_ROUNDF;
 415           break;
 416
 417         case 8:
 418           n = BUILT_IN_ROUND;
 419           break;
 420
 421         case 10:
 422         case 16:
 423           n = BUILT_IN_ROUNDL;
 424           break;
 425         }
 426       break;
 427
 428     case RND_TRUNC:
 429       switch (kind)
 430         {
 431         case 4:
 432           n = BUILT_IN_TRUNCF;
 433           break;
 434
 435         case 8:
 436           n = BUILT_IN_TRUNC;
 437           break;
 438
 439         case 10:
 440         case 16:
 441           n = BUILT_IN_TRUNCL;
 442           break;
 443         }
 444       break;
 445
 446     default:
 447       gcc_unreachable ();
 448     }
 449
 450   /* Evaluate the argument.  */
 451   gcc_assert (expr->value.function.actual->expr);
 452   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
 453
 454   /* Use a builtin function if one exists.  */
 455   if (n != END_BUILTINS)
 456     {
 457       tmp = built_in_decls[n];
 458       se->expr = build_call_expr (tmp, 1, arg[0]);
 459       return;
 460     }
 461
 462   /* This code is probably redundant, but we'll keep it lying around just
 463      in case.  */
 464   type = gfc_typenode_for_spec (&expr->ts);
 465   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
 466
 467   /* Test if the value is too large to handle sensibly.  */
 468   gfc_set_model_kind (kind);
 469   mpfr_init (huge);
 470   n = gfc_validate_kind (BT_INTEGER, kind, false);
 471   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 472   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 473   cond = build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
 474
 475   mpfr_neg (huge, huge, GFC_RND_MODE);
 476   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 477   tmp = build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
 478   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 479   itype = gfc_get_int_type (kind);
 480
 481   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
 482   tmp = convert (type, tmp);
 483   se->expr = build3 (COND_EXPR, type, cond, tmp, arg[0]);
 484   mpfr_clear (huge);
 485 }
 486
 487
 488 /* Convert to an integer using the specified rounding mode.  */
 489
 490 static void
 491 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 492 {
 493   tree type;
 494   tree *args;
 495   int nargs;
 496
 497   nargs = gfc_intrinsic_argument_list_length (expr);
 498   args = alloca (sizeof (tree) * nargs);
 499
 500   /* Evaluate the argument, we process all arguments even though we only
 501      use the first one for code generation purposes.  */
 502   type = gfc_typenode_for_spec (&expr->ts);
 503   gcc_assert (expr->value.function.actual->expr);
 504   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 505
 506   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 507     {
 508       /* Conversion to a different integer kind.  */
 509       se->expr = convert (type, args[0]);
 510     }
 511   else
 512     {
 513       /* Conversion from complex to non-complex involves taking the real
 514          component of the value.  */
 515       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 516           && expr->ts.type != BT_COMPLEX)
 517         {
 518           tree artype;
 519
 520           artype = TREE_TYPE (TREE_TYPE (args[0]));
 521           args[0] = build1 (REALPART_EXPR, artype, args[0]);
 522         }
 523
 524       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 525     }
 526 }
 527
 528
 529 /* Get the imaginary component of a value.  */
 530
 531 static void
 532 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 533 {
 534   tree arg;
 535
 536   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 537   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 538 }
 539
 540
 541 /* Get the complex conjugate of a value.  */
 542
 543 static void
 544 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 545 {
 546   tree arg;
 547
 548   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 549   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 550 }
 551
 552
 553 /* Initialize function decls for library functions.  The external functions
 554    are created as required.  Builtin functions are added here.  */
 555
 556 void
 557 gfc_build_intrinsic_lib_fndecls (void)
 558 {
 559   gfc_intrinsic_map_t *m;
 560
 561   /* Add GCC builtin functions.  */
 562   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 563     {
 564       if (m->code_r4 != END_BUILTINS)
 565         m->real4_decl = built_in_decls[m->code_r4];
 566       if (m->code_r8 != END_BUILTINS)
 567         m->real8_decl = built_in_decls[m->code_r8];
 568       if (m->code_r10 != END_BUILTINS)
 569         m->real10_decl = built_in_decls[m->code_r10];
 570       if (m->code_r16 != END_BUILTINS)
 571         m->real16_decl = built_in_decls[m->code_r16];
 572       if (m->code_c4 != END_BUILTINS)
 573         m->complex4_decl = built_in_decls[m->code_c4];
 574       if (m->code_c8 != END_BUILTINS)
 575         m->complex8_decl = built_in_decls[m->code_c8];
 576       if (m->code_c10 != END_BUILTINS)
 577         m->complex10_decl = built_in_decls[m->code_c10];
 578       if (m->code_c16 != END_BUILTINS)
 579         m->complex16_decl = built_in_decls[m->code_c16];
 580     }
 581 }
 582
 583
 584 /* Create a fndecl for a simple intrinsic library function.  */
 585
 586 static tree
 587 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 588 {
 589   tree type;
 590   tree argtypes;
 591   tree fndecl;
 592   gfc_actual_arglist *actual;
 593   tree *pdecl;
 594   gfc_typespec *ts;
 595   char name[GFC_MAX_SYMBOL_LEN + 3];
 596
 597   ts = &expr->ts;
 598   if (ts->type == BT_REAL)
 599     {
 600       switch (ts->kind)
 601         {
 602         case 4:
 603           pdecl = &m->real4_decl;
 604           break;
 605         case 8:
 606           pdecl = &m->real8_decl;
 607           break;
 608         case 10:
 609           pdecl = &m->real10_decl;
 610           break;
 611         case 16:
 612           pdecl = &m->real16_decl;
 613           break;
 614         default:
 615           gcc_unreachable ();
 616         }
 617     }
 618   else if (ts->type == BT_COMPLEX)
 619     {
 620       gcc_assert (m->complex_available);
 621
 622       switch (ts->kind)
 623         {
 624         case 4:
 625           pdecl = &m->complex4_decl;
 626           break;
 627         case 8:
 628           pdecl = &m->complex8_decl;
 629           break;
 630         case 10:
 631           pdecl = &m->complex10_decl;
 632           break;
 633         case 16:
 634           pdecl = &m->complex16_decl;
 635           break;
 636         default:
 637           gcc_unreachable ();
 638         }
 639     }
 640   else
 641     gcc_unreachable ();
 642
 643   if (*pdecl)
 644     return *pdecl;
 645
 646   if (m->libm_name)
 647     {
 648       if (ts->kind == 4)
 649         snprintf (name, sizeof (name), "%s%s%s",
 650                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 651       else if (ts->kind == 8)
 652         snprintf (name, sizeof (name), "%s%s",
 653                 ts->type == BT_COMPLEX ? "c" : "", m->name);
 654       else
 655         {
 656           gcc_assert (ts->kind == 10 || ts->kind == 16);
 657           snprintf (name, sizeof (name), "%s%s%s",
 658                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 659         }
 660     }
 661   else
 662     {
 663       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 664                 ts->type == BT_COMPLEX ? 'c' : 'r',
 665                 ts->kind);
 666     }
 667
 668   argtypes = NULL_TREE;
 669   for (actual = expr->value.function.actual; actual; actual = actual->next)
 670     {
 671       type = gfc_typenode_for_spec (&actual->expr->ts);
 672       argtypes = gfc_chainon_list (argtypes, type);
 673     }
 674   argtypes = gfc_chainon_list (argtypes, void_type_node);
 675   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 676   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 677
 678   /* Mark the decl as external.  */
 679   DECL_EXTERNAL (fndecl) = 1;
 680   TREE_PUBLIC (fndecl) = 1;
 681
 682   /* Mark it __attribute__((const)), if possible.  */
 683   TREE_READONLY (fndecl) = m->is_constant;
 684
 685   rest_of_decl_compilation (fndecl, 1, 0);
 686
 687   (*pdecl) = fndecl;
 688   return fndecl;
 689 }
 690
 691
 692 /* Convert an intrinsic function into an external or builtin call.  */
 693
 694 static void
 695 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 696 {
 697   gfc_intrinsic_map_t *m;
 698   tree fndecl;
 699   tree rettype;
 700   tree *args;
 701   unsigned int num_args;
 702   gfc_isym_id id;
 703
 704   id = expr->value.function.isym->id;
 705   /* Find the entry for this function.  */
 706   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 707     {
 708       if (id == m->id)
 709         break;
 710     }
 711
 712   if (m->id == GFC_ISYM_NONE)
 713     {
 714       internal_error ("Intrinsic function %s(%d) not recognized",
 715                       expr->value.function.name, id);
 716     }
 717
 718   /* Get the decl and generate the call.  */
 719   num_args = gfc_intrinsic_argument_list_length (expr);
 720   args = alloca (sizeof (tree) * num_args);
 721
 722   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 723   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 724   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 725
 726   fndecl = build_addr (fndecl, current_function_decl);
 727   se->expr = build_call_array (rettype, fndecl, num_args, args);
 728 }
 729
 730 /* Generate code for EXPONENT(X) intrinsic function.  */
 731
 732 static void
 733 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 734 {
 735   tree arg, fndecl, type;
 736   gfc_expr *a1;
 737
 738   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 739
 740   a1 = expr->value.function.actual->expr;
 741   switch (a1->ts.kind)
 742     {
 743     case 4:
 744       fndecl = gfor_fndecl_math_exponent4;
 745       break;
 746     case 8:
 747       fndecl = gfor_fndecl_math_exponent8;
 748       break;
 749     case 10:
 750       fndecl = gfor_fndecl_math_exponent10;
 751       break;
 752     case 16:
 753       fndecl = gfor_fndecl_math_exponent16;
 754       break;
 755     default:
 756       gcc_unreachable ();
 757     }
 758
 759   /* Convert it to the required type.  */
 760   type = gfc_typenode_for_spec (&expr->ts);
 761   se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
 762 }
 763
 764 /* Evaluate a single upper or lower bound.  */
 765 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 766
 767 static void
 768 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 769 {
 770   gfc_actual_arglist *arg;
 771   gfc_actual_arglist *arg2;
 772   tree desc;
 773   tree type;
 774   tree bound;
 775   tree tmp;
 776   tree cond, cond1, cond2, cond3, cond4, size;
 777   tree ubound;
 778   tree lbound;
 779   gfc_se argse;
 780   gfc_ss *ss;
 781   gfc_array_spec * as;
 782   gfc_ref *ref;
 783
 784   arg = expr->value.function.actual;
 785   arg2 = arg->next;
 786
 787   if (se->ss)
 788     {
 789       /* Create an implicit second parameter from the loop variable.  */
 790       gcc_assert (!arg2->expr);
 791       gcc_assert (se->loop->dimen == 1);
 792       gcc_assert (se->ss->expr == expr);
 793       gfc_advance_se_ss_chain (se);
 794       bound = se->loop->loopvar[0];
 795       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 796                            se->loop->from[0]);
 797     }
 798   else
 799     {
 800       /* use the passed argument.  */
 801       gcc_assert (arg->next->expr);
 802       gfc_init_se (&argse, NULL);
 803       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 804       gfc_add_block_to_block (&se->pre, &argse.pre);
 805       bound = argse.expr;
 806       /* Convert from one based to zero based.  */
 807       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 808                            gfc_index_one_node);
 809     }
 810
 811   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 812   /* Get a descriptor for the first parameter.  */
 813   ss = gfc_walk_expr (arg->expr);
 814   gcc_assert (ss != gfc_ss_terminator);
 815   gfc_init_se (&argse, NULL);
 816   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 817   gfc_add_block_to_block (&se->pre, &argse.pre);
 818   gfc_add_block_to_block (&se->post, &argse.post);
 819
 820   desc = argse.expr;
 821
 822   if (INTEGER_CST_P (bound))
 823     {
 824       int hi, low;
 825
 826       hi = TREE_INT_CST_HIGH (bound);
 827       low = TREE_INT_CST_LOW (bound);
 828       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 829         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 830                    "dimension index", upper ? "UBOUND" : "LBOUND",
 831                    &expr->where);
 832     }
 833   else
 834     {
 835       if (flag_bounds_check)
 836         {
 837           bound = gfc_evaluate_now (bound, &se->pre);
 838           cond = fold_build2 (LT_EXPR, boolean_type_node,
 839                               bound, build_int_cst (TREE_TYPE (bound), 0));
 840           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 841           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 842           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 843           gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);
 844         }
 845     }
 846
 847   ubound = gfc_conv_descriptor_ubound (desc, bound);
 848   lbound = gfc_conv_descriptor_lbound (desc, bound);
 849
 850   /* Follow any component references.  */
 851   if (arg->expr->expr_type == EXPR_VARIABLE
 852       || arg->expr->expr_type == EXPR_CONSTANT)
 853     {
 854       as = arg->expr->symtree->n.sym->as;
 855       for (ref = arg->expr->ref; ref; ref = ref->next)
 856         {
 857           switch (ref->type)
 858             {
 859             case REF_COMPONENT:
 860               as = ref->u.c.component->as;
 861               continue;
 862
 863             case REF_SUBSTRING:
 864               continue;
 865
 866             case REF_ARRAY:
 867               {
 868                 switch (ref->u.ar.type)
 869                   {
 870                   case AR_ELEMENT:
 871                   case AR_SECTION:
 872                   case AR_UNKNOWN:
 873                     as = NULL;
 874                     continue;
 875
 876                   case AR_FULL:
 877                     break;
 878                   }
 879               }
 880             }
 881         }
 882     }
 883   else
 884     as = NULL;
 885
 886   /* 13.14.53: Result value for LBOUND
 887
 888      Case (i): For an array section or for an array expression other than a
 889                whole array or array structure component, LBOUND(ARRAY, DIM)
 890                has the value 1.  For a whole array or array structure
 891                component, LBOUND(ARRAY, DIM) has the value:
 892                  (a) equal to the lower bound for subscript DIM of ARRAY if
 893                      dimension DIM of ARRAY does not have extent zero
 894                      or if ARRAY is an assumed-size array of rank DIM,
 895               or (b) 1 otherwise.
 896
 897      13.14.113: Result value for UBOUND
 898
 899      Case (i): For an array section or for an array expression other than a
 900                whole array or array structure component, UBOUND(ARRAY, DIM)
 901                has the value equal to the number of elements in the given
 902                dimension; otherwise, it has a value equal to the upper bound
 903                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 904                not have size zero and has value zero if dimension DIM has
 905                size zero.  */
 906
 907   if (as)
 908     {
 909       tree stride = gfc_conv_descriptor_stride (desc, bound);
 910
 911       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 912       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 913
 914       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 915                            gfc_index_zero_node);
 916       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 917
 918       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 919                            gfc_index_zero_node);
 920       cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
 921
 922       if (upper)
 923         {
 924           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 925
 926           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 927                                   ubound, gfc_index_zero_node);
 928         }
 929       else
 930         {
 931           if (as->type == AS_ASSUMED_SIZE)
 932             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 933                                 build_int_cst (TREE_TYPE (bound),
 934                                                arg->expr->rank - 1));
 935           else
 936             cond = boolean_false_node;
 937
 938           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 939           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 940
 941           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 942                                   lbound, gfc_index_one_node);
 943         }
 944     }
 945   else
 946     {
 947       if (upper)
 948         {
 949           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
 950           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 951                                   gfc_index_one_node);
 952         }
 953       else
 954         se->expr = gfc_index_one_node;
 955     }
 956
 957   type = gfc_typenode_for_spec (&expr->ts);
 958   se->expr = convert (type, se->expr);
 959 }
 960
 961
 962 static void
 963 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 964 {
 965   tree arg;
 966   int n;
 967
 968   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 969
 970   switch (expr->value.function.actual->expr->ts.type)
 971     {
 972     case BT_INTEGER:
 973     case BT_REAL:
 974       se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
 975       break;
 976
 977     case BT_COMPLEX:
 978       switch (expr->ts.kind)
 979         {
 980         case 4:
 981           n = BUILT_IN_CABSF;
 982           break;
 983         case 8:
 984           n = BUILT_IN_CABS;
 985           break;
 986         case 10:
 987         case 16:
 988           n = BUILT_IN_CABSL;
 989           break;
 990         default:
 991           gcc_unreachable ();
 992         }
 993       se->expr = build_call_expr (built_in_decls[n], 1, arg);
 994       break;
 995
 996     default:
 997       gcc_unreachable ();
 998     }
 999 }
1000
1001
1002 /* Create a complex value from one or two real components.  */
1003
1004 static void
1005 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1006 {
1007   tree real;
1008   tree imag;
1009   tree type;
1010   tree *args;
1011   unsigned int num_args;
1012
1013   num_args = gfc_intrinsic_argument_list_length (expr);
1014   args = alloca (sizeof (tree) * num_args);
1015
1016   type = gfc_typenode_for_spec (&expr->ts);
1017   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1018   real = convert (TREE_TYPE (type), args[0]);
1019   if (both)
1020     imag = convert (TREE_TYPE (type), args[1]);
1021   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1022     {
1023       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1024       imag = convert (TREE_TYPE (type), imag);
1025     }
1026   else
1027     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1028
1029   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1030 }
1031
1032 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1033                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1034 /* TODO: MOD(x, 0)  */
1035
1036 static void
1037 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1038 {
1039   tree type;
1040   tree itype;
1041   tree tmp;
1042   tree test;
1043   tree test2;
1044   mpfr_t huge;
1045   int n, ikind;
1046   tree args[2];
1047
1048   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1049
1050   switch (expr->ts.type)
1051     {
1052     case BT_INTEGER:
1053       /* Integer case is easy, we've got a builtin op.  */
1054       type = TREE_TYPE (args[0]);
1055
1056       if (modulo)
1057        se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1058       else
1059        se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1060       break;
1061
1062     case BT_REAL:
1063       n = END_BUILTINS;
1064       /* Check if we have a builtin fmod.  */
1065       switch (expr->ts.kind)
1066         {
1067         case 4:
1068           n = BUILT_IN_FMODF;
1069           break;
1070
1071         case 8:
1072           n = BUILT_IN_FMOD;
1073           break;
1074
1075         case 10:
1076         case 16:
1077           n = BUILT_IN_FMODL;
1078           break;
1079
1080         default:
1081           break;
1082         }
1083
1084       /* Use it if it exists.  */
1085       if (n != END_BUILTINS)
1086         {
1087           tmp = build_addr (built_in_decls[n], current_function_decl);
1088           se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1089                                        tmp, 2, args);
1090           if (modulo == 0)
1091             return;
1092         }
1093
1094       type = TREE_TYPE (args[0]);
1095
1096       args[0] = gfc_evaluate_now (args[0], &se->pre);
1097       args[1] = gfc_evaluate_now (args[1], &se->pre);
1098
1099       /* Definition:
1100          modulo = arg - floor (arg/arg2) * arg2, so
1101                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1102          where
1103           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1104          thereby avoiding another division and retaining the accuracy
1105          of the builtin function.  */
1106       if (n != END_BUILTINS && modulo)
1107         {
1108           tree zero = gfc_build_const (type, integer_zero_node);
1109           tmp = gfc_evaluate_now (se->expr, &se->pre);
1110           test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
1111           test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
1112           test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1113           test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
1114           test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1115           test = gfc_evaluate_now (test, &se->pre);
1116           se->expr = build3 (COND_EXPR, type, test,
1117                              build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
1118           return;
1119         }
1120
1121       /* If we do not have a built_in fmod, the calculation is going to
1122          have to be done longhand.  */
1123       tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
1124
1125       /* Test if the value is too large to handle sensibly.  */
1126       gfc_set_model_kind (expr->ts.kind);
1127       mpfr_init (huge);
1128       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1129       ikind = expr->ts.kind;
1130       if (n < 0)
1131         {
1132           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1133           ikind = gfc_max_integer_kind;
1134         }
1135       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1136       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1137       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1138
1139       mpfr_neg (huge, huge, GFC_RND_MODE);
1140       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1141       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1142       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1143
1144       itype = gfc_get_int_type (ikind);
1145       if (modulo)
1146        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1147       else
1148        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1149       tmp = convert (type, tmp);
1150       tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
1151       tmp = build2 (MULT_EXPR, type, tmp, args[1]);
1152       se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
1153       mpfr_clear (huge);
1154       break;
1155
1156     default:
1157       gcc_unreachable ();
1158     }
1159 }
1160
1161 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1162
1163 static void
1164 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1165 {
1166   tree val;
1167   tree tmp;
1168   tree type;
1169   tree zero;
1170   tree args[2];
1171
1172   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1173   type = TREE_TYPE (args[0]);
1174
1175   val = build2 (MINUS_EXPR, type, args[0], args[1]);
1176   val = gfc_evaluate_now (val, &se->pre);
1177
1178   zero = gfc_build_const (type, integer_zero_node);
1179   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1180   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1181 }
1182
1183
1184 /* SIGN(A, B) is absolute value of A times sign of B.
1185    The real value versions use library functions to ensure the correct
1186    handling of negative zero.  Integer case implemented as:
1187    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1188   */
1189
1190 static void
1191 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1192 {
1193   tree tmp;
1194   tree type;
1195   tree args[2];
1196
1197   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1198   if (expr->ts.type == BT_REAL)
1199     {
1200       switch (expr->ts.kind)
1201         {
1202         case 4:
1203           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1204           break;
1205         case 8:
1206           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1207           break;
1208         case 10:
1209         case 16:
1210           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1211           break;
1212         default:
1213           gcc_unreachable ();
1214         }
1215       se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1216       return;
1217     }
1218
1219   /* Having excluded floating point types, we know we are now dealing
1220      with signed integer types.  */
1221   type = TREE_TYPE (args[0]);
1222
1223   /* Args[0] is used multiple times below.  */
1224   args[0] = gfc_evaluate_now (args[0], &se->pre);
1225
1226   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1227      the signs of A and B are the same, and of all ones if they differ.  */
1228   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1229   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1230                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1231   tmp = gfc_evaluate_now (tmp, &se->pre);
1232
1233   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1234      is all ones (i.e. -1).  */
1235   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1236                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1237                           tmp);
1238 }
1239
1240
1241 /* Test for the presence of an optional argument.  */
1242
1243 static void
1244 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1245 {
1246   gfc_expr *arg;
1247
1248   arg = expr->value.function.actual->expr;
1249   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1250   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1251   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1252 }
1253
1254
1255 /* Calculate the double precision product of two single precision values.  */
1256
1257 static void
1258 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1259 {
1260   tree type;
1261   tree args[2];
1262
1263   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1264
1265   /* Convert the args to double precision before multiplying.  */
1266   type = gfc_typenode_for_spec (&expr->ts);
1267   args[0] = convert (type, args[0]);
1268   args[1] = convert (type, args[1]);
1269   se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
1270 }
1271
1272
1273 /* Return a length one character string containing an ascii character.  */
1274
1275 static void
1276 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1277 {
1278   tree arg;
1279   tree var;
1280   tree type;
1281
1282   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1283
1284   /* We currently don't support character types != 1.  */
1285   gcc_assert (expr->ts.kind == 1);
1286   type = gfc_character1_type_node;
1287   var = gfc_create_var (type, "char");
1288
1289   arg = convert (type, arg);
1290   gfc_add_modify_expr (&se->pre, var, arg);
1291   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1292   se->string_length = integer_one_node;
1293 }
1294
1295
1296 static void
1297 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1298 {
1299   tree var;
1300   tree len;
1301   tree tmp;
1302   tree type;
1303   tree cond;
1304   tree gfc_int8_type_node = gfc_get_int_type (8);
1305   tree fndecl;
1306   tree *args;
1307   unsigned int num_args;
1308
1309   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1310   args = alloca (sizeof (tree) * num_args);
1311
1312   type = build_pointer_type (gfc_character1_type_node);
1313   var = gfc_create_var (type, "pstr");
1314   len = gfc_create_var (gfc_int8_type_node, "len");
1315
1316   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1317   args[0] = build_fold_addr_expr (var);
1318   args[1] = build_fold_addr_expr (len);
1319
1320   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1321   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1322                           fndecl, num_args, args);
1323   gfc_add_expr_to_block (&se->pre, tmp);
1324
1325   /* Free the temporary afterwards, if necessary.  */
1326   cond = build2 (GT_EXPR, boolean_type_node, len,
1327                  build_int_cst (TREE_TYPE (len), 0));
1328   tmp = gfc_call_free (var);
1329   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1330   gfc_add_expr_to_block (&se->post, tmp);
1331
1332   se->expr = var;
1333   se->string_length = len;
1334 }
1335
1336
1337 static void
1338 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1339 {
1340   tree var;
1341   tree len;
1342   tree tmp;
1343   tree type;
1344   tree cond;
1345   tree gfc_int4_type_node = gfc_get_int_type (4);
1346   tree fndecl;
1347   tree *args;
1348   unsigned int num_args;
1349
1350   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1351   args = alloca (sizeof (tree) * num_args);
1352
1353   type = build_pointer_type (gfc_character1_type_node);
1354   var = gfc_create_var (type, "pstr");
1355   len = gfc_create_var (gfc_int4_type_node, "len");
1356
1357   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1358   args[0] = build_fold_addr_expr (var);
1359   args[1] = build_fold_addr_expr (len);
1360
1361   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1362   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1363                           fndecl, num_args, args);
1364   gfc_add_expr_to_block (&se->pre, tmp);
1365
1366   /* Free the temporary afterwards, if necessary.  */
1367   cond = build2 (GT_EXPR, boolean_type_node, len,
1368                  build_int_cst (TREE_TYPE (len), 0));
1369   tmp = gfc_call_free (var);
1370   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1371   gfc_add_expr_to_block (&se->post, tmp);
1372
1373   se->expr = var;
1374   se->string_length = len;
1375 }
1376
1377
1378 /* Return a character string containing the tty name.  */
1379
1380 static void
1381 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1382 {
1383   tree var;
1384   tree len;
1385   tree tmp;
1386   tree type;
1387   tree cond;
1388   tree fndecl;
1389   tree gfc_int4_type_node = gfc_get_int_type (4);
1390   tree *args;
1391   unsigned int num_args;
1392
1393   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1394   args = alloca (sizeof (tree) * num_args);
1395
1396   type = build_pointer_type (gfc_character1_type_node);
1397   var = gfc_create_var (type, "pstr");
1398   len = gfc_create_var (gfc_int4_type_node, "len");
1399
1400   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1401   args[0] = build_fold_addr_expr (var);
1402   args[1] = build_fold_addr_expr (len);
1403
1404   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1405   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1406                           fndecl, num_args, args);
1407   gfc_add_expr_to_block (&se->pre, tmp);
1408
1409   /* Free the temporary afterwards, if necessary.  */
1410   cond = build2 (GT_EXPR, boolean_type_node, len,
1411                  build_int_cst (TREE_TYPE (len), 0));
1412   tmp = gfc_call_free (var);
1413   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1414   gfc_add_expr_to_block (&se->post, tmp);
1415
1416   se->expr = var;
1417   se->string_length = len;
1418 }
1419
1420
1421 /* Get the minimum/maximum value of all the parameters.
1422     minmax (a1, a2, a3, ...)
1423     {
1424       mvar = a1;
1425       if (a2 .op. mvar || isnan(mvar))
1426         mvar = a2;
1427       if (a3 .op. mvar || isnan(mvar))
1428         mvar = a3;
1429       ...
1430       return mvar
1431     }
1432  */
1433
1434 /* TODO: Mismatching types can occur when specific names are used.
1435    These should be handled during resolution.  */
1436 static void
1437 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1438 {
1439   tree tmp;
1440   tree mvar;
1441   tree val;
1442   tree thencase;
1443   tree *args;
1444   tree type;
1445   gfc_actual_arglist *argexpr;
1446   unsigned int i, nargs;
1447
1448   nargs = gfc_intrinsic_argument_list_length (expr);
1449   args = alloca (sizeof (tree) * nargs);
1450
1451   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1452   type = gfc_typenode_for_spec (&expr->ts);
1453
1454   argexpr = expr->value.function.actual;
1455   if (TREE_TYPE (args[0]) != type)
1456     args[0] = convert (type, args[0]);
1457   /* Only evaluate the argument once.  */
1458   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1459     args[0] = gfc_evaluate_now (args[0], &se->pre);
1460
1461   mvar = gfc_create_var (type, "M");
1462   gfc_add_modify_expr (&se->pre, mvar, args[0]);
1463   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1464     {
1465       tree cond, isnan;
1466
1467       val = args[i];
1468
1469       /* Handle absent optional arguments by ignoring the comparison.  */
1470       if (argexpr->expr->expr_type == EXPR_VARIABLE
1471           && argexpr->expr->symtree->n.sym->attr.optional
1472           && TREE_CODE (val) == INDIRECT_REF)
1473         cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1474                        build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1475       else
1476       {
1477         cond = NULL_TREE;
1478
1479         /* Only evaluate the argument once.  */
1480         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1481           val = gfc_evaluate_now (val, &se->pre);
1482       }
1483
1484       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1485
1486       tmp = build2 (op, boolean_type_node, convert (type, val), mvar);
1487
1488       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1489          __builtin_isnan might be made dependent on that module being loaded,
1490          to help performance of programs that don't rely on IEEE semantics.  */
1491       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1492         {
1493           isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1494           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1495                              fold_convert (boolean_type_node, isnan));
1496         }
1497       tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
1498
1499       if (cond != NULL_TREE)
1500         tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1501
1502       gfc_add_expr_to_block (&se->pre, tmp);
1503       argexpr = argexpr->next;
1504     }
1505   se->expr = mvar;
1506 }
1507
1508
1509 /* Generate library calls for MIN and MAX intrinsics for character
1510    variables.  */
1511 static void
1512 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1513 {
1514   tree *args;
1515   tree var, len, fndecl, tmp, cond;
1516   unsigned int nargs;
1517
1518   nargs = gfc_intrinsic_argument_list_length (expr);
1519   args = alloca (sizeof (tree) * (nargs + 4));
1520   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1521
1522   /* Create the result variables.  */
1523   len = gfc_create_var (gfc_charlen_type_node, "len");
1524   args[0] = build_fold_addr_expr (len);
1525   var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
1526   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1527   args[2] = build_int_cst (NULL_TREE, op);
1528   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1529
1530   /* Make the function call.  */
1531   fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
1532   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
1533                           fndecl, nargs + 4, args);
1534   gfc_add_expr_to_block (&se->pre, tmp);
1535
1536   /* Free the temporary afterwards, if necessary.  */
1537   cond = build2 (GT_EXPR, boolean_type_node, len,
1538                  build_int_cst (TREE_TYPE (len), 0));
1539   tmp = gfc_call_free (var);
1540   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1541   gfc_add_expr_to_block (&se->post, tmp);
1542
1543   se->expr = var;
1544   se->string_length = len;
1545 }
1546
1547
1548 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1549    has the generic name.  */
1550
1551 static gfc_symbol *
1552 gfc_get_symbol_for_expr (gfc_expr * expr)
1553 {
1554   gfc_symbol *sym;
1555
1556   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1557   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1558   sym = gfc_new_symbol (expr->value.function.name, NULL);
1559
1560   sym->ts = expr->ts;
1561   sym->attr.external = 1;
1562   sym->attr.function = 1;
1563   sym->attr.always_explicit = 1;
1564   sym->attr.proc = PROC_INTRINSIC;
1565   sym->attr.flavor = FL_PROCEDURE;
1566   sym->result = sym;
1567   if (expr->rank > 0)
1568     {
1569       sym->attr.dimension = 1;
1570       sym->as = gfc_get_array_spec ();
1571       sym->as->type = AS_ASSUMED_SHAPE;
1572       sym->as->rank = expr->rank;
1573     }
1574
1575   /* TODO: proper argument lists for external intrinsics.  */
1576   return sym;
1577 }
1578
1579 /* Generate a call to an external intrinsic function.  */
1580 static void
1581 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1582 {
1583   gfc_symbol *sym;
1584   tree append_args;
1585
1586   gcc_assert (!se->ss || se->ss->expr == expr);
1587
1588   if (se->ss)
1589     gcc_assert (expr->rank > 0);
1590   else
1591     gcc_assert (expr->rank == 0);
1592
1593   sym = gfc_get_symbol_for_expr (expr);
1594
1595   /* Calls to libgfortran_matmul need to be appended special arguments,
1596      to be able to call the BLAS ?gemm functions if required and possible.  */
1597   append_args = NULL_TREE;
1598   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1599       && sym->ts.type != BT_LOGICAL)
1600     {
1601       tree cint = gfc_get_int_type (gfc_c_int_kind);
1602
1603       if (gfc_option.flag_external_blas
1604           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1605           && (sym->ts.kind == gfc_default_real_kind
1606               || sym->ts.kind == gfc_default_double_kind))
1607         {
1608           tree gemm_fndecl;
1609
1610           if (sym->ts.type == BT_REAL)
1611             {
1612               if (sym->ts.kind == gfc_default_real_kind)
1613                 gemm_fndecl = gfor_fndecl_sgemm;
1614               else
1615                 gemm_fndecl = gfor_fndecl_dgemm;
1616             }
1617           else
1618             {
1619               if (sym->ts.kind == gfc_default_real_kind)
1620                 gemm_fndecl = gfor_fndecl_cgemm;
1621               else
1622                 gemm_fndecl = gfor_fndecl_zgemm;
1623             }
1624
1625           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1626           append_args = gfc_chainon_list
1627                           (append_args, build_int_cst
1628                                           (cint, gfc_option.blas_matmul_limit));
1629           append_args = gfc_chainon_list (append_args,
1630                                           gfc_build_addr_expr (NULL_TREE,
1631                                                                gemm_fndecl));
1632         }
1633       else
1634         {
1635           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1636           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1637           append_args = gfc_chainon_list (append_args, null_pointer_node);
1638         }
1639     }
1640
1641   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1642   gfc_free (sym);
1643 }
1644
1645 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1646    Implemented as
1647     any(a)
1648     {
1649       forall (i=...)
1650         if (a[i] != 0)
1651           return 1
1652       end forall
1653       return 0
1654     }
1655     all(a)
1656     {
1657       forall (i=...)
1658         if (a[i] == 0)
1659           return 0
1660       end forall
1661       return 1
1662     }
1663  */
1664 static void
1665 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1666 {
1667   tree resvar;
1668   stmtblock_t block;
1669   stmtblock_t body;
1670   tree type;
1671   tree tmp;
1672   tree found;
1673   gfc_loopinfo loop;
1674   gfc_actual_arglist *actual;
1675   gfc_ss *arrayss;
1676   gfc_se arrayse;
1677   tree exit_label;
1678
1679   if (se->ss)
1680     {
1681       gfc_conv_intrinsic_funcall (se, expr);
1682       return;
1683     }
1684
1685   actual = expr->value.function.actual;
1686   type = gfc_typenode_for_spec (&expr->ts);
1687   /* Initialize the result.  */
1688   resvar = gfc_create_var (type, "test");
1689   if (op == EQ_EXPR)
1690     tmp = convert (type, boolean_true_node);
1691   else
1692     tmp = convert (type, boolean_false_node);
1693   gfc_add_modify_expr (&se->pre, resvar, tmp);
1694
1695   /* Walk the arguments.  */
1696   arrayss = gfc_walk_expr (actual->expr);
1697   gcc_assert (arrayss != gfc_ss_terminator);
1698
1699   /* Initialize the scalarizer.  */
1700   gfc_init_loopinfo (&loop);
1701   exit_label = gfc_build_label_decl (NULL_TREE);
1702   TREE_USED (exit_label) = 1;
1703   gfc_add_ss_to_loop (&loop, arrayss);
1704
1705   /* Initialize the loop.  */
1706   gfc_conv_ss_startstride (&loop);
1707   gfc_conv_loop_setup (&loop);
1708
1709   gfc_mark_ss_chain_used (arrayss, 1);
1710   /* Generate the loop body.  */
1711   gfc_start_scalarized_body (&loop, &body);
1712
1713   /* If the condition matches then set the return value.  */
1714   gfc_start_block (&block);
1715   if (op == EQ_EXPR)
1716     tmp = convert (type, boolean_false_node);
1717   else
1718     tmp = convert (type, boolean_true_node);
1719   gfc_add_modify_expr (&block, resvar, tmp);
1720
1721   /* And break out of the loop.  */
1722   tmp = build1_v (GOTO_EXPR, exit_label);
1723   gfc_add_expr_to_block (&block, tmp);
1724
1725   found = gfc_finish_block (&block);
1726
1727   /* Check this element.  */
1728   gfc_init_se (&arrayse, NULL);
1729   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1730   arrayse.ss = arrayss;
1731   gfc_conv_expr_val (&arrayse, actual->expr);
1732
1733   gfc_add_block_to_block (&body, &arrayse.pre);
1734   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1735                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1736   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1737   gfc_add_expr_to_block (&body, tmp);
1738   gfc_add_block_to_block (&body, &arrayse.post);
1739
1740   gfc_trans_scalarizing_loops (&loop, &body);
1741
1742   /* Add the exit label.  */
1743   tmp = build1_v (LABEL_EXPR, exit_label);
1744   gfc_add_expr_to_block (&loop.pre, tmp);
1745
1746   gfc_add_block_to_block (&se->pre, &loop.pre);
1747   gfc_add_block_to_block (&se->pre, &loop.post);
1748   gfc_cleanup_loop (&loop);
1749
1750   se->expr = resvar;
1751 }
1752
1753 /* COUNT(A) = Number of true elements in A.  */
1754 static void
1755 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1756 {
1757   tree resvar;
1758   tree type;
1759   stmtblock_t body;
1760   tree tmp;
1761   gfc_loopinfo loop;
1762   gfc_actual_arglist *actual;
1763   gfc_ss *arrayss;
1764   gfc_se arrayse;
1765
1766   if (se->ss)
1767     {
1768       gfc_conv_intrinsic_funcall (se, expr);
1769       return;
1770     }
1771
1772   actual = expr->value.function.actual;
1773
1774   type = gfc_typenode_for_spec (&expr->ts);
1775   /* Initialize the result.  */
1776   resvar = gfc_create_var (type, "count");
1777   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1778
1779   /* Walk the arguments.  */
1780   arrayss = gfc_walk_expr (actual->expr);
1781   gcc_assert (arrayss != gfc_ss_terminator);
1782
1783   /* Initialize the scalarizer.  */
1784   gfc_init_loopinfo (&loop);
1785   gfc_add_ss_to_loop (&loop, arrayss);
1786
1787   /* Initialize the loop.  */
1788   gfc_conv_ss_startstride (&loop);
1789   gfc_conv_loop_setup (&loop);
1790
1791   gfc_mark_ss_chain_used (arrayss, 1);
1792   /* Generate the loop body.  */
1793   gfc_start_scalarized_body (&loop, &body);
1794
1795   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1796                 build_int_cst (TREE_TYPE (resvar), 1));
1797   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1798
1799   gfc_init_se (&arrayse, NULL);
1800   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1801   arrayse.ss = arrayss;
1802   gfc_conv_expr_val (&arrayse, actual->expr);
1803   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1804
1805   gfc_add_block_to_block (&body, &arrayse.pre);
1806   gfc_add_expr_to_block (&body, tmp);
1807   gfc_add_block_to_block (&body, &arrayse.post);
1808
1809   gfc_trans_scalarizing_loops (&loop, &body);
1810
1811   gfc_add_block_to_block (&se->pre, &loop.pre);
1812   gfc_add_block_to_block (&se->pre, &loop.post);
1813   gfc_cleanup_loop (&loop);
1814
1815   se->expr = resvar;
1816 }
1817
1818 /* Inline implementation of the sum and product intrinsics.  */
1819 static void
1820 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1821 {
1822   tree resvar;
1823   tree type;
1824   stmtblock_t body;
1825   stmtblock_t block;
1826   tree tmp;
1827   gfc_loopinfo loop;
1828   gfc_actual_arglist *actual;
1829   gfc_ss *arrayss;
1830   gfc_ss *maskss;
1831   gfc_se arrayse;
1832   gfc_se maskse;
1833   gfc_expr *arrayexpr;
1834   gfc_expr *maskexpr;
1835
1836   if (se->ss)
1837     {
1838       gfc_conv_intrinsic_funcall (se, expr);
1839       return;
1840     }
1841
1842   type = gfc_typenode_for_spec (&expr->ts);
1843   /* Initialize the result.  */
1844   resvar = gfc_create_var (type, "val");
1845   if (op == PLUS_EXPR)
1846     tmp = gfc_build_const (type, integer_zero_node);
1847   else
1848     tmp = gfc_build_const (type, integer_one_node);
1849
1850   gfc_add_modify_expr (&se->pre, resvar, tmp);
1851
1852   /* Walk the arguments.  */
1853   actual = expr->value.function.actual;
1854   arrayexpr = actual->expr;
1855   arrayss = gfc_walk_expr (arrayexpr);
1856   gcc_assert (arrayss != gfc_ss_terminator);
1857
1858   actual = actual->next->next;
1859   gcc_assert (actual);
1860   maskexpr = actual->expr;
1861   if (maskexpr && maskexpr->rank != 0)
1862     {
1863       maskss = gfc_walk_expr (maskexpr);
1864       gcc_assert (maskss != gfc_ss_terminator);
1865     }
1866   else
1867     maskss = NULL;
1868
1869   /* Initialize the scalarizer.  */
1870   gfc_init_loopinfo (&loop);
1871   gfc_add_ss_to_loop (&loop, arrayss);
1872   if (maskss)
1873     gfc_add_ss_to_loop (&loop, maskss);
1874
1875   /* Initialize the loop.  */
1876   gfc_conv_ss_startstride (&loop);
1877   gfc_conv_loop_setup (&loop);
1878
1879   gfc_mark_ss_chain_used (arrayss, 1);
1880   if (maskss)
1881     gfc_mark_ss_chain_used (maskss, 1);
1882   /* Generate the loop body.  */
1883   gfc_start_scalarized_body (&loop, &body);
1884
1885   /* If we have a mask, only add this element if the mask is set.  */
1886   if (maskss)
1887     {
1888       gfc_init_se (&maskse, NULL);
1889       gfc_copy_loopinfo_to_se (&maskse, &loop);
1890       maskse.ss = maskss;
1891       gfc_conv_expr_val (&maskse, maskexpr);
1892       gfc_add_block_to_block (&body, &maskse.pre);
1893
1894       gfc_start_block (&block);
1895     }
1896   else
1897     gfc_init_block (&block);
1898
1899   /* Do the actual summation/product.  */
1900   gfc_init_se (&arrayse, NULL);
1901   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1902   arrayse.ss = arrayss;
1903   gfc_conv_expr_val (&arrayse, arrayexpr);
1904   gfc_add_block_to_block (&block, &arrayse.pre);
1905
1906   tmp = build2 (op, type, resvar, arrayse.expr);
1907   gfc_add_modify_expr (&block, resvar, tmp);
1908   gfc_add_block_to_block (&block, &arrayse.post);
1909
1910   if (maskss)
1911     {
1912       /* We enclose the above in if (mask) {...} .  */
1913       tmp = gfc_finish_block (&block);
1914
1915       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1916     }
1917   else
1918     tmp = gfc_finish_block (&block);
1919   gfc_add_expr_to_block (&body, tmp);
1920
1921   gfc_trans_scalarizing_loops (&loop, &body);
1922
1923   /* For a scalar mask, enclose the loop in an if statement.  */
1924   if (maskexpr && maskss == NULL)
1925     {
1926       gfc_init_se (&maskse, NULL);
1927       gfc_conv_expr_val (&maskse, maskexpr);
1928       gfc_init_block (&block);
1929       gfc_add_block_to_block (&block, &loop.pre);
1930       gfc_add_block_to_block (&block, &loop.post);
1931       tmp = gfc_finish_block (&block);
1932
1933       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1934       gfc_add_expr_to_block (&block, tmp);
1935       gfc_add_block_to_block (&se->pre, &block);
1936     }
1937   else
1938     {
1939       gfc_add_block_to_block (&se->pre, &loop.pre);
1940       gfc_add_block_to_block (&se->pre, &loop.post);
1941     }
1942
1943   gfc_cleanup_loop (&loop);
1944
1945   se->expr = resvar;
1946 }
1947
1948
1949 /* Inline implementation of the dot_product intrinsic. This function
1950    is based on gfc_conv_intrinsic_arith (the previous function).  */
1951 static void
1952 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1953 {
1954   tree resvar;
1955   tree type;
1956   stmtblock_t body;
1957   stmtblock_t block;
1958   tree tmp;
1959   gfc_loopinfo loop;
1960   gfc_actual_arglist *actual;
1961   gfc_ss *arrayss1, *arrayss2;
1962   gfc_se arrayse1, arrayse2;
1963   gfc_expr *arrayexpr1, *arrayexpr2;
1964
1965   type = gfc_typenode_for_spec (&expr->ts);
1966
1967   /* Initialize the result.  */
1968   resvar = gfc_create_var (type, "val");
1969   if (expr->ts.type == BT_LOGICAL)
1970     tmp = build_int_cst (type, 0);
1971   else
1972     tmp = gfc_build_const (type, integer_zero_node);
1973
1974   gfc_add_modify_expr (&se->pre, resvar, tmp);
1975
1976   /* Walk argument #1.  */
1977   actual = expr->value.function.actual;
1978   arrayexpr1 = actual->expr;
1979   arrayss1 = gfc_walk_expr (arrayexpr1);
1980   gcc_assert (arrayss1 != gfc_ss_terminator);
1981
1982   /* Walk argument #2.  */
1983   actual = actual->next;
1984   arrayexpr2 = actual->expr;
1985   arrayss2 = gfc_walk_expr (arrayexpr2);
1986   gcc_assert (arrayss2 != gfc_ss_terminator);
1987
1988   /* Initialize the scalarizer.  */
1989   gfc_init_loopinfo (&loop);
1990   gfc_add_ss_to_loop (&loop, arrayss1);
1991   gfc_add_ss_to_loop (&loop, arrayss2);
1992
1993   /* Initialize the loop.  */
1994   gfc_conv_ss_startstride (&loop);
1995   gfc_conv_loop_setup (&loop);
1996
1997   gfc_mark_ss_chain_used (arrayss1, 1);
1998   gfc_mark_ss_chain_used (arrayss2, 1);
1999
2000   /* Generate the loop body.  */
2001   gfc_start_scalarized_body (&loop, &body);
2002   gfc_init_block (&block);
2003
2004   /* Make the tree expression for [conjg(]array1[)].  */
2005   gfc_init_se (&arrayse1, NULL);
2006   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2007   arrayse1.ss = arrayss1;
2008   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2009   if (expr->ts.type == BT_COMPLEX)
2010     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
2011   gfc_add_block_to_block (&block, &arrayse1.pre);
2012
2013   /* Make the tree expression for array2.  */
2014   gfc_init_se (&arrayse2, NULL);
2015   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2016   arrayse2.ss = arrayss2;
2017   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2018   gfc_add_block_to_block (&block, &arrayse2.pre);
2019
2020   /* Do the actual product and sum.  */
2021   if (expr->ts.type == BT_LOGICAL)
2022     {
2023       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2024       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2025     }
2026   else
2027     {
2028       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2029       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
2030     }
2031   gfc_add_modify_expr (&block, resvar, tmp);
2032
2033   /* Finish up the loop block and the loop.  */
2034   tmp = gfc_finish_block (&block);
2035   gfc_add_expr_to_block (&body, tmp);
2036
2037   gfc_trans_scalarizing_loops (&loop, &body);
2038   gfc_add_block_to_block (&se->pre, &loop.pre);
2039   gfc_add_block_to_block (&se->pre, &loop.post);
2040   gfc_cleanup_loop (&loop);
2041
2042   se->expr = resvar;
2043 }
2044
2045
2046 static void
2047 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2048 {
2049   stmtblock_t body;
2050   stmtblock_t block;
2051   stmtblock_t ifblock;
2052   stmtblock_t elseblock;
2053   tree limit;
2054   tree type;
2055   tree tmp;
2056   tree elsetmp;
2057   tree ifbody;
2058   tree offset;
2059   gfc_loopinfo loop;
2060   gfc_actual_arglist *actual;
2061   gfc_ss *arrayss;
2062   gfc_ss *maskss;
2063   gfc_se arrayse;
2064   gfc_se maskse;
2065   gfc_expr *arrayexpr;
2066   gfc_expr *maskexpr;
2067   tree pos;
2068   int n;
2069
2070   if (se->ss)
2071     {
2072       gfc_conv_intrinsic_funcall (se, expr);
2073       return;
2074     }
2075
2076   /* Initialize the result.  */
2077   pos = gfc_create_var (gfc_array_index_type, "pos");
2078   offset = gfc_create_var (gfc_array_index_type, "offset");
2079   type = gfc_typenode_for_spec (&expr->ts);
2080
2081   /* Walk the arguments.  */
2082   actual = expr->value.function.actual;
2083   arrayexpr = actual->expr;
2084   arrayss = gfc_walk_expr (arrayexpr);
2085   gcc_assert (arrayss != gfc_ss_terminator);
2086
2087   actual = actual->next->next;
2088   gcc_assert (actual);
2089   maskexpr = actual->expr;
2090   if (maskexpr && maskexpr->rank != 0)
2091     {
2092       maskss = gfc_walk_expr (maskexpr);
2093       gcc_assert (maskss != gfc_ss_terminator);
2094     }
2095   else
2096     maskss = NULL;
2097
2098   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2099   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2100   switch (arrayexpr->ts.type)
2101     {
2102     case BT_REAL:
2103       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2104       break;
2105
2106     case BT_INTEGER:
2107       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2108                                   arrayexpr->ts.kind);
2109       break;
2110
2111     default:
2112       gcc_unreachable ();
2113     }
2114
2115   /* We start with the most negative possible value for MAXLOC, and the most
2116      positive possible value for MINLOC. The most negative possible value is
2117      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2118      possible value is HUGE in both cases.  */
2119   if (op == GT_EXPR)
2120     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2121   gfc_add_modify_expr (&se->pre, limit, tmp);
2122
2123   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2124     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2125                   build_int_cst (type, 1));
2126
2127   /* Initialize the scalarizer.  */
2128   gfc_init_loopinfo (&loop);
2129   gfc_add_ss_to_loop (&loop, arrayss);
2130   if (maskss)
2131     gfc_add_ss_to_loop (&loop, maskss);
2132
2133   /* Initialize the loop.  */
2134   gfc_conv_ss_startstride (&loop);
2135   gfc_conv_loop_setup (&loop);
2136
2137   gcc_assert (loop.dimen == 1);
2138
2139   /* Initialize the position to zero, following Fortran 2003.  We are free
2140      to do this because Fortran 95 allows the result of an entirely false
2141      mask to be processor dependent.  */
2142   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2143
2144   gfc_mark_ss_chain_used (arrayss, 1);
2145   if (maskss)
2146     gfc_mark_ss_chain_used (maskss, 1);
2147   /* Generate the loop body.  */
2148   gfc_start_scalarized_body (&loop, &body);
2149
2150   /* If we have a mask, only check this element if the mask is set.  */
2151   if (maskss)
2152     {
2153       gfc_init_se (&maskse, NULL);
2154       gfc_copy_loopinfo_to_se (&maskse, &loop);
2155       maskse.ss = maskss;
2156       gfc_conv_expr_val (&maskse, maskexpr);
2157       gfc_add_block_to_block (&body, &maskse.pre);
2158
2159       gfc_start_block (&block);
2160     }
2161   else
2162     gfc_init_block (&block);
2163
2164   /* Compare with the current limit.  */
2165   gfc_init_se (&arrayse, NULL);
2166   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2167   arrayse.ss = arrayss;
2168   gfc_conv_expr_val (&arrayse, arrayexpr);
2169   gfc_add_block_to_block (&block, &arrayse.pre);
2170
2171   /* We do the following if this is a more extreme value.  */
2172   gfc_start_block (&ifblock);
2173
2174   /* Assign the value to the limit...  */
2175   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2176
2177   /* Remember where we are.  An offset must be added to the loop
2178      counter to obtain the required position.  */
2179   if (loop.temp_dim)
2180     tmp = build_int_cst (gfc_array_index_type, 1);
2181   else
2182     tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2183                          gfc_index_one_node, loop.from[0]);
2184   gfc_add_modify_expr (&block, offset, tmp);
2185
2186   tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2187                 loop.loopvar[0], offset);
2188   gfc_add_modify_expr (&ifblock, pos, tmp);
2189
2190   ifbody = gfc_finish_block (&ifblock);
2191
2192   /* If it is a more extreme value or pos is still zero and the value
2193      equal to the limit.  */
2194   tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2195                 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2196                 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2197   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2198                 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2199   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2200   gfc_add_expr_to_block (&block, tmp);
2201
2202   if (maskss)
2203     {
2204       /* We enclose the above in if (mask) {...}.  */
2205       tmp = gfc_finish_block (&block);
2206
2207       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2208     }
2209   else
2210     tmp = gfc_finish_block (&block);
2211   gfc_add_expr_to_block (&body, tmp);
2212
2213   gfc_trans_scalarizing_loops (&loop, &body);
2214
2215   /* For a scalar mask, enclose the loop in an if statement.  */
2216   if (maskexpr && maskss == NULL)
2217     {
2218       gfc_init_se (&maskse, NULL);
2219       gfc_conv_expr_val (&maskse, maskexpr);
2220       gfc_init_block (&block);
2221       gfc_add_block_to_block (&block, &loop.pre);
2222       gfc_add_block_to_block (&block, &loop.post);
2223       tmp = gfc_finish_block (&block);
2224
2225       /* For the else part of the scalar mask, just initialize
2226          the pos variable the same way as above.  */
2227
2228       gfc_init_block (&elseblock);
2229       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2230       elsetmp = gfc_finish_block (&elseblock);
2231
2232       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2233       gfc_add_expr_to_block (&block, tmp);
2234       gfc_add_block_to_block (&se->pre, &block);
2235     }
2236   else
2237     {
2238       gfc_add_block_to_block (&se->pre, &loop.pre);
2239       gfc_add_block_to_block (&se->pre, &loop.post);
2240     }
2241   gfc_cleanup_loop (&loop);
2242
2243   se->expr = convert (type, pos);
2244 }
2245
2246 static void
2247 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2248 {
2249   tree limit;
2250   tree type;
2251   tree tmp;
2252   tree ifbody;
2253   stmtblock_t body;
2254   stmtblock_t block;
2255   gfc_loopinfo loop;
2256   gfc_actual_arglist *actual;
2257   gfc_ss *arrayss;
2258   gfc_ss *maskss;
2259   gfc_se arrayse;
2260   gfc_se maskse;
2261   gfc_expr *arrayexpr;
2262   gfc_expr *maskexpr;
2263   int n;
2264
2265   if (se->ss)
2266     {
2267       gfc_conv_intrinsic_funcall (se, expr);
2268       return;
2269     }
2270
2271   type = gfc_typenode_for_spec (&expr->ts);
2272   /* Initialize the result.  */
2273   limit = gfc_create_var (type, "limit");
2274   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2275   switch (expr->ts.type)
2276     {
2277     case BT_REAL:
2278       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2279       break;
2280
2281     case BT_INTEGER:
2282       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2283       break;
2284
2285     default:
2286       gcc_unreachable ();
2287     }
2288
2289   /* We start with the most negative possible value for MAXVAL, and the most
2290      positive possible value for MINVAL. The most negative possible value is
2291      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2292      possible value is HUGE in both cases.  */
2293   if (op == GT_EXPR)
2294     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2295
2296   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2297     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2298                   build_int_cst (type, 1));
2299
2300   gfc_add_modify_expr (&se->pre, limit, tmp);
2301
2302   /* Walk the arguments.  */
2303   actual = expr->value.function.actual;
2304   arrayexpr = actual->expr;
2305   arrayss = gfc_walk_expr (arrayexpr);
2306   gcc_assert (arrayss != gfc_ss_terminator);
2307
2308   actual = actual->next->next;
2309   gcc_assert (actual);
2310   maskexpr = actual->expr;
2311   if (maskexpr && maskexpr->rank != 0)
2312     {
2313       maskss = gfc_walk_expr (maskexpr);
2314       gcc_assert (maskss != gfc_ss_terminator);
2315     }
2316   else
2317     maskss = NULL;
2318
2319   /* Initialize the scalarizer.  */
2320   gfc_init_loopinfo (&loop);
2321   gfc_add_ss_to_loop (&loop, arrayss);
2322   if (maskss)
2323     gfc_add_ss_to_loop (&loop, maskss);
2324
2325   /* Initialize the loop.  */
2326   gfc_conv_ss_startstride (&loop);
2327   gfc_conv_loop_setup (&loop);
2328
2329   gfc_mark_ss_chain_used (arrayss, 1);
2330   if (maskss)
2331     gfc_mark_ss_chain_used (maskss, 1);
2332   /* Generate the loop body.  */
2333   gfc_start_scalarized_body (&loop, &body);
2334
2335   /* If we have a mask, only add this element if the mask is set.  */
2336   if (maskss)
2337     {
2338       gfc_init_se (&maskse, NULL);
2339       gfc_copy_loopinfo_to_se (&maskse, &loop);
2340       maskse.ss = maskss;
2341       gfc_conv_expr_val (&maskse, maskexpr);
2342       gfc_add_block_to_block (&body, &maskse.pre);
2343
2344       gfc_start_block (&block);
2345     }
2346   else
2347     gfc_init_block (&block);
2348
2349   /* Compare with the current limit.  */
2350   gfc_init_se (&arrayse, NULL);
2351   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2352   arrayse.ss = arrayss;
2353   gfc_conv_expr_val (&arrayse, arrayexpr);
2354   gfc_add_block_to_block (&block, &arrayse.pre);
2355
2356   /* Assign the value to the limit...  */
2357   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2358
2359   /* If it is a more extreme value.  */
2360   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2361   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2362   gfc_add_expr_to_block (&block, tmp);
2363   gfc_add_block_to_block (&block, &arrayse.post);
2364
2365   tmp = gfc_finish_block (&block);
2366   if (maskss)
2367     /* We enclose the above in if (mask) {...}.  */
2368     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2369   gfc_add_expr_to_block (&body, tmp);
2370
2371   gfc_trans_scalarizing_loops (&loop, &body);
2372
2373   /* For a scalar mask, enclose the loop in an if statement.  */
2374   if (maskexpr && maskss == NULL)
2375     {
2376       gfc_init_se (&maskse, NULL);
2377       gfc_conv_expr_val (&maskse, maskexpr);
2378       gfc_init_block (&block);
2379       gfc_add_block_to_block (&block, &loop.pre);
2380       gfc_add_block_to_block (&block, &loop.post);
2381       tmp = gfc_finish_block (&block);
2382
2383       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2384       gfc_add_expr_to_block (&block, tmp);
2385       gfc_add_block_to_block (&se->pre, &block);
2386     }
2387   else
2388     {
2389       gfc_add_block_to_block (&se->pre, &loop.pre);
2390       gfc_add_block_to_block (&se->pre, &loop.post);
2391     }
2392
2393   gfc_cleanup_loop (&loop);
2394
2395   se->expr = limit;
2396 }
2397
2398 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2399 static void
2400 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2401 {
2402   tree args[2];
2403   tree type;
2404   tree tmp;
2405
2406   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2407   type = TREE_TYPE (args[0]);
2408
2409   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2410   tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
2411   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2412                      build_int_cst (type, 0));
2413   type = gfc_typenode_for_spec (&expr->ts);
2414   se->expr = convert (type, tmp);
2415 }
2416
2417 /* Generate code to perform the specified operation.  */
2418 static void
2419 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2420 {
2421   tree args[2];
2422
2423   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2424   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2425 }
2426
2427 /* Bitwise not.  */
2428 static void
2429 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2430 {
2431   tree arg;
2432
2433   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2434   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2435 }
2436
2437 /* Set or clear a single bit.  */
2438 static void
2439 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2440 {
2441   tree args[2];
2442   tree type;
2443   tree tmp;
2444   int op;
2445
2446   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2447   type = TREE_TYPE (args[0]);
2448
2449   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2450   if (set)
2451     op = BIT_IOR_EXPR;
2452   else
2453     {
2454       op = BIT_AND_EXPR;
2455       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2456     }
2457   se->expr = fold_build2 (op, type, args[0], tmp);
2458 }
2459
2460 /* Extract a sequence of bits.
2461     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2462 static void
2463 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2464 {
2465   tree args[3];
2466   tree type;
2467   tree tmp;
2468   tree mask;
2469
2470   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2471   type = TREE_TYPE (args[0]);
2472
2473   mask = build_int_cst (type, -1);
2474   mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
2475   mask = build1 (BIT_NOT_EXPR, type, mask);
2476
2477   tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
2478
2479   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2480 }
2481
2482 /* RSHIFT (I, SHIFT) = I >> SHIFT
2483    LSHIFT (I, SHIFT) = I << SHIFT  */
2484 static void
2485 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2486 {
2487   tree args[2];
2488
2489   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2490
2491   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2492                           TREE_TYPE (args[0]), args[0], args[1]);
2493 }
2494
2495 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2496                         ? 0
2497                         : ((shift >= 0) ? i << shift : i >> -shift)
2498    where all shifts are logical shifts.  */
2499 static void
2500 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2501 {
2502   tree args[2];
2503   tree type;
2504   tree utype;
2505   tree tmp;
2506   tree width;
2507   tree num_bits;
2508   tree cond;
2509   tree lshift;
2510   tree rshift;
2511
2512   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2513   type = TREE_TYPE (args[0]);
2514   utype = unsigned_type_for (type);
2515
2516   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2517
2518   /* Left shift if positive.  */
2519   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2520
2521   /* Right shift if negative.
2522      We convert to an unsigned type because we want a logical shift.
2523      The standard doesn't define the case of shifting negative
2524      numbers, and we try to be compatible with other compilers, most
2525      notably g77, here.  */
2526   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2527                                        convert (utype, args[0]), width));
2528
2529   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2530                      build_int_cst (TREE_TYPE (args[1]), 0));
2531   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2532
2533   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2534      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2535      special case.  */
2536   num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
2537   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2538
2539   se->expr = fold_build3 (COND_EXPR, type, cond,
2540                           build_int_cst (type, 0), tmp);
2541 }
2542
2543
2544 /* Circular shift.  AKA rotate or barrel shift.  */
2545
2546 static void
2547 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2548 {
2549   tree *args;
2550   tree type;
2551   tree tmp;
2552   tree lrot;
2553   tree rrot;
2554   tree zero;
2555   unsigned int num_args;
2556
2557   num_args = gfc_intrinsic_argument_list_length (expr);
2558   args = alloca (sizeof (tree) * num_args);
2559
2560   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2561
2562   if (num_args == 3)
2563     {
2564       /* Use a library function for the 3 parameter version.  */
2565       tree int4type = gfc_get_int_type (4);
2566
2567       type = TREE_TYPE (args[0]);
2568       /* We convert the first argument to at least 4 bytes, and
2569          convert back afterwards.  This removes the need for library
2570          functions for all argument sizes, and function will be
2571          aligned to at least 32 bits, so there's no loss.  */
2572       if (expr->ts.kind < 4)
2573         args[0] = convert (int4type, args[0]);
2574
2575       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2576          need loads of library  functions.  They cannot have values >
2577          BIT_SIZE (I) so the conversion is safe.  */
2578       args[1] = convert (int4type, args[1]);
2579       args[2] = convert (int4type, args[2]);
2580
2581       switch (expr->ts.kind)
2582         {
2583         case 1:
2584         case 2:
2585         case 4:
2586           tmp = gfor_fndecl_math_ishftc4;
2587           break;
2588         case 8:
2589           tmp = gfor_fndecl_math_ishftc8;
2590           break;
2591         case 16:
2592           tmp = gfor_fndecl_math_ishftc16;
2593           break;
2594         default:
2595           gcc_unreachable ();
2596         }
2597       se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2598       /* Convert the result back to the original type, if we extended
2599          the first argument's width above.  */
2600       if (expr->ts.kind < 4)
2601         se->expr = convert (type, se->expr);
2602
2603       return;
2604     }
2605   type = TREE_TYPE (args[0]);
2606
2607   /* Rotate left if positive.  */
2608   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2609
2610   /* Rotate right if negative.  */
2611   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2612   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2613
2614   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2615   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2616   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2617
2618   /* Do nothing if shift == 0.  */
2619   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2620   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2621 }
2622
2623 /* The length of a character string.  */
2624 static void
2625 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2626 {
2627   tree len;
2628   tree type;
2629   tree decl;
2630   gfc_symbol *sym;
2631   gfc_se argse;
2632   gfc_expr *arg;
2633   gfc_ss *ss;
2634
2635   gcc_assert (!se->ss);
2636
2637   arg = expr->value.function.actual->expr;
2638
2639   type = gfc_typenode_for_spec (&expr->ts);
2640   switch (arg->expr_type)
2641     {
2642     case EXPR_CONSTANT:
2643       len = build_int_cst (NULL_TREE, arg->value.character.length);
2644       break;
2645
2646     case EXPR_ARRAY:
2647       /* Obtain the string length from the function used by
2648          trans-array.c(gfc_trans_array_constructor).  */
2649       len = NULL_TREE;
2650       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2651       break;
2652
2653     case EXPR_VARIABLE:
2654       if (arg->ref == NULL
2655             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2656         {
2657           /* This doesn't catch all cases.
2658              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2659              and the surrounding thread.  */
2660           sym = arg->symtree->n.sym;
2661           decl = gfc_get_symbol_decl (sym);
2662           if (decl == current_function_decl && sym->attr.function
2663                 && (sym->result == sym))
2664             decl = gfc_get_fake_result_decl (sym, 0);
2665
2666           len = sym->ts.cl->backend_decl;
2667           gcc_assert (len);
2668           break;
2669         }
2670
2671       /* Otherwise fall through.  */
2672
2673     default:
2674       /* Anybody stupid enough to do this deserves inefficient code.  */
2675       ss = gfc_walk_expr (arg);
2676       gfc_init_se (&argse, se);
2677       if (ss == gfc_ss_terminator)
2678         gfc_conv_expr (&argse, arg);
2679       else
2680         gfc_conv_expr_descriptor (&argse, arg, ss);
2681       gfc_add_block_to_block (&se->pre, &argse.pre);
2682       gfc_add_block_to_block (&se->post, &argse.post);
2683       len = argse.string_length;
2684       break;
2685     }
2686   se->expr = convert (type, len);
2687 }
2688
2689 /* The length of a character string not including trailing blanks.  */
2690 static void
2691 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2692 {
2693   tree args[2];
2694   tree type;
2695
2696   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2697   type = gfc_typenode_for_spec (&expr->ts);
2698   se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2699   se->expr = convert (type, se->expr);
2700 }
2701
2702
2703 /* Returns the starting position of a substring within a string.  */
2704
2705 static void
2706 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2707                                       tree function)
2708 {
2709   tree logical4_type_node = gfc_get_logical_type (4);
2710   tree type;
2711   tree fndecl;
2712   tree *args;
2713   unsigned int num_args;
2714
2715   num_args = gfc_intrinsic_argument_list_length (expr);
2716   args = alloca (sizeof (tree) * 5);
2717
2718   gfc_conv_intrinsic_function_args (se, expr, args,
2719                                     num_args >= 5 ? 5 : num_args);
2720   type = gfc_typenode_for_spec (&expr->ts);
2721
2722   if (num_args == 4)
2723     args[4] = build_int_cst (logical4_type_node, 0);
2724   else
2725     args[4] = convert (logical4_type_node, args[4]);
2726
2727   fndecl = build_addr (function, current_function_decl);
2728   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
2729                                5, args);
2730   se->expr = convert (type, se->expr);
2731
2732 }
2733
2734 /* The ascii value for a single character.  */
2735 static void
2736 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2737 {
2738   tree args[2];
2739   tree type;
2740
2741   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2742   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2743   args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
2744   type = gfc_typenode_for_spec (&expr->ts);
2745
2746   se->expr = build_fold_indirect_ref (args[1]);
2747   se->expr = convert (type, se->expr);
2748 }
2749
2750
2751 /* Intrinsic ISNAN calls __builtin_isnan.  */
2752
2753 static void
2754 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
2755 {
2756   tree arg;
2757
2758   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2759   se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
2760   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2761 }
2762
2763
2764 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
2765    their argument against a constant integer value.  */
2766
2767 static void
2768 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
2769 {
2770   tree arg;
2771
2772   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2773   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
2774                           arg, build_int_cst (TREE_TYPE (arg), value));
2775 }
2776
2777
2778
2779 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2780
2781 static void
2782 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2783 {
2784   tree tsource;
2785   tree fsource;
2786   tree mask;
2787   tree type;
2788   tree len;
2789   tree *args;
2790   unsigned int num_args;
2791
2792   num_args = gfc_intrinsic_argument_list_length (expr);
2793   args = alloca (sizeof (tree) * num_args);
2794
2795   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2796   if (expr->ts.type != BT_CHARACTER)
2797     {
2798       tsource = args[0];
2799       fsource = args[1];
2800       mask = args[2];
2801     }
2802   else
2803     {
2804       /* We do the same as in the non-character case, but the argument
2805          list is different because of the string length arguments. We
2806          also have to set the string length for the result.  */
2807       len = args[0];
2808       tsource = args[1];
2809       fsource = args[3];
2810       mask = args[4];
2811
2812       se->string_length = len;
2813     }
2814   type = TREE_TYPE (tsource);
2815   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2816 }
2817
2818
2819 static void
2820 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2821 {
2822   gfc_actual_arglist *actual;
2823   tree arg1;
2824   tree type;
2825   tree fncall0;
2826   tree fncall1;
2827   gfc_se argse;
2828   gfc_ss *ss;
2829
2830   gfc_init_se (&argse, NULL);
2831   actual = expr->value.function.actual;
2832
2833   ss = gfc_walk_expr (actual->expr);
2834   gcc_assert (ss != gfc_ss_terminator);
2835   argse.want_pointer = 1;
2836   argse.data_not_needed = 1;
2837   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2838   gfc_add_block_to_block (&se->pre, &argse.pre);
2839   gfc_add_block_to_block (&se->post, &argse.post);
2840   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2841
2842   /* Build the call to size0.  */
2843   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2844
2845   actual = actual->next;
2846
2847   if (actual->expr)
2848     {
2849       gfc_init_se (&argse, NULL);
2850       gfc_conv_expr_type (&argse, actual->expr,
2851                           gfc_array_index_type);
2852       gfc_add_block_to_block (&se->pre, &argse.pre);
2853
2854       /* Build the call to size1.  */
2855       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2856                                  arg1, argse.expr);
2857
2858       /* Unusually, for an intrinsic, size does not exclude
2859          an optional arg2, so we must test for it.  */
2860       if (actual->expr->expr_type == EXPR_VARIABLE
2861             && actual->expr->symtree->n.sym->attr.dummy
2862             && actual->expr->symtree->n.sym->attr.optional)
2863         {
2864           tree tmp;
2865           gfc_init_se (&argse, NULL);
2866           argse.want_pointer = 1;
2867           argse.data_not_needed = 1;
2868           gfc_conv_expr (&argse, actual->expr);
2869           gfc_add_block_to_block (&se->pre, &argse.pre);
2870           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2871                         null_pointer_node);
2872           tmp = gfc_evaluate_now (tmp, &se->pre);
2873           se->expr = build3 (COND_EXPR, pvoid_type_node,
2874                              tmp, fncall1, fncall0);
2875         }
2876       else
2877         se->expr = fncall1;
2878     }
2879   else
2880     se->expr = fncall0;
2881
2882   type = gfc_typenode_for_spec (&expr->ts);
2883   se->expr = convert (type, se->expr);
2884 }
2885
2886
2887 static void
2888 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2889 {
2890   gfc_expr *arg;
2891   gfc_ss *ss;
2892   gfc_se argse;
2893   tree source;
2894   tree source_bytes;
2895   tree type;
2896   tree tmp;
2897   tree lower;
2898   tree upper;
2899   /*tree stride;*/
2900   int n;
2901
2902   arg = expr->value.function.actual->expr;
2903
2904   gfc_init_se (&argse, NULL);
2905   ss = gfc_walk_expr (arg);
2906
2907   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2908
2909   if (ss == gfc_ss_terminator)
2910     {
2911       gfc_conv_expr_reference (&argse, arg);
2912       source = argse.expr;
2913
2914       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2915
2916       /* Obtain the source word length.  */
2917       if (arg->ts.type == BT_CHARACTER)
2918         source_bytes = fold_convert (gfc_array_index_type,
2919                                      argse.string_length);
2920       else
2921         source_bytes = fold_convert (gfc_array_index_type,
2922                                      size_in_bytes (type));
2923     }
2924   else
2925     {
2926       argse.want_pointer = 0;
2927       gfc_conv_expr_descriptor (&argse, arg, ss);
2928       source = gfc_conv_descriptor_data_get (argse.expr);
2929       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2930
2931       /* Obtain the argument's word length.  */
2932       if (arg->ts.type == BT_CHARACTER)
2933         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2934       else
2935         tmp = fold_convert (gfc_array_index_type,
2936                             size_in_bytes (type));
2937       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2938
2939       /* Obtain the size of the array in bytes.  */
2940       for (n = 0; n < arg->rank; n++)
2941         {
2942           tree idx;
2943           idx = gfc_rank_cst[n];
2944           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2945           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2946           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2947                              upper, lower);
2948           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2949                              tmp, gfc_index_one_node);
2950           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2951                              tmp, source_bytes);
2952           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2953         }
2954     }
2955
2956   gfc_add_block_to_block (&se->pre, &argse.pre);
2957   se->expr = source_bytes;
2958 }
2959
2960
2961 /* Intrinsic string comparison functions.  */
2962
2963 static void
2964 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2965 {
2966   tree args[4];
2967
2968   gfc_conv_intrinsic_function_args (se, expr, args, 4);
2969
2970   se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
2971   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
2972                           build_int_cst (TREE_TYPE (se->expr), 0));
2973 }
2974
2975 /* Generate a call to the adjustl/adjustr library function.  */
2976 static void
2977 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2978 {
2979   tree args[3];
2980   tree len;
2981   tree type;
2982   tree var;
2983   tree tmp;
2984
2985   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
2986   len = args[1];
2987
2988   type = TREE_TYPE (args[2]);
2989   var = gfc_conv_string_tmp (se, type, len);
2990   args[0] = var;
2991
2992   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
2993   gfc_add_expr_to_block (&se->pre, tmp);
2994   se->expr = var;
2995   se->string_length = len;
2996 }
2997
2998
2999 /* Array transfer statement.
3000      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3001    where:
3002      typeof<DEST> = typeof<MOLD>
3003    and:
3004      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3005               sizeof (DEST(0) * SIZE).  */
3006
3007 static void
3008 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3009 {
3010   tree tmp;
3011   tree extent;
3012   tree source;
3013   tree source_type;
3014   tree source_bytes;
3015   tree mold_type;
3016   tree dest_word_len;
3017   tree size_words;
3018   tree size_bytes;
3019   tree upper;
3020   tree lower;
3021   tree stride;
3022   tree stmt;
3023   gfc_actual_arglist *arg;
3024   gfc_se argse;
3025   gfc_ss *ss;
3026   gfc_ss_info *info;
3027   stmtblock_t block;
3028   int n;
3029
3030   gcc_assert (se->loop);
3031   info = &se->ss->data.info;
3032
3033   /* Convert SOURCE.  The output from this stage is:-
3034         source_bytes = length of the source in bytes
3035         source = pointer to the source data.  */
3036   arg = expr->value.function.actual;
3037   gfc_init_se (&argse, NULL);
3038   ss = gfc_walk_expr (arg->expr);
3039
3040   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3041
3042   /* Obtain the pointer to source and the length of source in bytes.  */
3043   if (ss == gfc_ss_terminator)
3044     {
3045       gfc_conv_expr_reference (&argse, arg->expr);
3046       source = argse.expr;
3047
3048       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3049
3050       /* Obtain the source word length.  */
3051       if (arg->expr->ts.type == BT_CHARACTER)
3052         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3053       else
3054         tmp = fold_convert (gfc_array_index_type,
3055                             size_in_bytes (source_type));
3056     }
3057   else
3058     {
3059       argse.want_pointer = 0;
3060       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3061       source = gfc_conv_descriptor_data_get (argse.expr);
3062       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3063
3064       /* Repack the source if not a full variable array.  */
3065       if (!(arg->expr->expr_type == EXPR_VARIABLE
3066               && arg->expr->ref->u.ar.type == AR_FULL))
3067         {
3068           tmp = build_fold_addr_expr (argse.expr);
3069           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3070           source = gfc_evaluate_now (source, &argse.pre);
3071
3072           /* Free the temporary.  */
3073           gfc_start_block (&block);
3074           tmp = gfc_call_free (convert (pvoid_type_node, source));
3075           gfc_add_expr_to_block (&block, tmp);
3076           stmt = gfc_finish_block (&block);
3077
3078           /* Clean up if it was repacked.  */
3079           gfc_init_block (&block);
3080           tmp = gfc_conv_array_data (argse.expr);
3081           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3082           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3083           gfc_add_expr_to_block (&block, tmp);
3084           gfc_add_block_to_block (&block, &se->post);
3085           gfc_init_block (&se->post);
3086           gfc_add_block_to_block (&se->post, &block);
3087         }
3088
3089       /* Obtain the source word length.  */
3090       if (arg->expr->ts.type == BT_CHARACTER)
3091         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3092       else
3093         tmp = fold_convert (gfc_array_index_type,
3094                             size_in_bytes (source_type));
3095
3096       /* Obtain the size of the array in bytes.  */
3097       extent = gfc_create_var (gfc_array_index_type, NULL);
3098       for (n = 0; n < arg->expr->rank; n++)
3099         {
3100           tree idx;
3101           idx = gfc_rank_cst[n];
3102           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3103           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3104           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3105           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3106           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3107                              upper, lower);
3108           gfc_add_modify_expr (&argse.pre, extent, tmp);
3109           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3110                              extent, gfc_index_one_node);
3111           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3112                              tmp, source_bytes);
3113         }
3114     }
3115
3116   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3117   gfc_add_block_to_block (&se->pre, &argse.pre);
3118   gfc_add_block_to_block (&se->post, &argse.post);
3119
3120   /* Now convert MOLD.  The outputs are:
3121         mold_type = the TREE type of MOLD
3122         dest_word_len = destination word length in bytes.  */
3123   arg = arg->next;
3124
3125   gfc_init_se (&argse, NULL);
3126   ss = gfc_walk_expr (arg->expr);
3127
3128   if (ss == gfc_ss_terminator)
3129     {
3130       gfc_conv_expr_reference (&argse, arg->expr);
3131       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3132     }
3133   else
3134     {
3135       gfc_init_se (&argse, NULL);
3136       argse.want_pointer = 0;
3137       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3138       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3139     }
3140
3141   if (arg->expr->ts.type == BT_CHARACTER)
3142     {
3143       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3144       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3145     }
3146   else
3147     tmp = fold_convert (gfc_array_index_type,
3148                         size_in_bytes (mold_type));
3149
3150   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3151   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3152
3153   /* Finally convert SIZE, if it is present.  */
3154   arg = arg->next;
3155   size_words = gfc_create_var (gfc_array_index_type, NULL);
3156
3157   if (arg->expr)
3158     {
3159       gfc_init_se (&argse, NULL);
3160       gfc_conv_expr_reference (&argse, arg->expr);
3161       tmp = convert (gfc_array_index_type,
3162                          build_fold_indirect_ref (argse.expr));
3163       gfc_add_block_to_block (&se->pre, &argse.pre);
3164       gfc_add_block_to_block (&se->post, &argse.post);
3165     }
3166   else
3167     tmp = NULL_TREE;
3168
3169   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3170   if (tmp != NULL_TREE)
3171     {
3172       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3173                          tmp, dest_word_len);
3174       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3175                          tmp, source_bytes);
3176     }
3177   else
3178     tmp = source_bytes;
3179
3180   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3181   gfc_add_modify_expr (&se->pre, size_words,
3182                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3183                                     size_bytes, dest_word_len));
3184
3185   /* Evaluate the bounds of the result.  If the loop range exists, we have
3186      to check if it is too large.  If so, we modify loop->to be consistent
3187      with min(size, size(source)).  Otherwise, size is made consistent with
3188      the loop range, so that the right number of bytes is transferred.*/
3189   n = se->loop->order[0];
3190   if (se->loop->to[n] != NULL_TREE)
3191     {
3192       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3193                          se->loop->to[n], se->loop->from[n]);
3194       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3195                          tmp, gfc_index_one_node);
3196       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3197                          tmp, size_words);
3198       gfc_add_modify_expr (&se->pre, size_words, tmp);
3199       gfc_add_modify_expr (&se->pre, size_bytes,
3200                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3201                                         size_words, dest_word_len));
3202       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3203                            size_words, se->loop->from[n]);
3204       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3205                            upper, gfc_index_one_node);
3206     }
3207   else
3208     {
3209       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3210                            size_words, gfc_index_one_node);
3211       se->loop->from[n] = gfc_index_zero_node;
3212     }
3213
3214   se->loop->to[n] = upper;
3215
3216   /* Build a destination descriptor, using the pointer, source, as the
3217      data field.  This is already allocated so set callee_alloc.
3218      FIXME callee_alloc is not set!  */
3219
3220   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3221                                info, mold_type, false, true, false);
3222
3223   /* Cast the pointer to the result.  */
3224   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3225   tmp = fold_convert (pvoid_type_node, tmp);
3226
3227   /* Use memcpy to do the transfer.  */
3228   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3229                          3,
3230                          tmp,
3231                          fold_convert (pvoid_type_node, source),
3232                          size_bytes);
3233   gfc_add_expr_to_block (&se->pre, tmp);
3234
3235   se->expr = info->descriptor;
3236   if (expr->ts.type == BT_CHARACTER)
3237     se->string_length = dest_word_len;
3238 }
3239
3240
3241 /* Scalar transfer statement.
3242    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3243
3244 static void
3245 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3246 {
3247   gfc_actual_arglist *arg;
3248   gfc_se argse;
3249   tree type;
3250   tree ptr;
3251   gfc_ss *ss;
3252   tree tmpdecl, tmp;
3253
3254   /* Get a pointer to the source.  */
3255   arg = expr->value.function.actual;
3256   ss = gfc_walk_expr (arg->expr);
3257   gfc_init_se (&argse, NULL);
3258   if (ss == gfc_ss_terminator)
3259     gfc_conv_expr_reference (&argse, arg->expr);
3260   else
3261     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3262   gfc_add_block_to_block (&se->pre, &argse.pre);
3263   gfc_add_block_to_block (&se->post, &argse.post);
3264   ptr = argse.expr;
3265
3266   arg = arg->next;
3267   type = gfc_typenode_for_spec (&expr->ts);
3268
3269   if (expr->ts.type == BT_CHARACTER)
3270     {
3271       ptr = convert (build_pointer_type (type), ptr);
3272       gfc_init_se (&argse, NULL);
3273       gfc_conv_expr (&argse, arg->expr);
3274       gfc_add_block_to_block (&se->pre, &argse.pre);
3275       gfc_add_block_to_block (&se->post, &argse.post);
3276       se->expr = ptr;
3277       se->string_length = argse.string_length;
3278     }
3279   else
3280     {
3281       tree moldsize;
3282       tmpdecl = gfc_create_var (type, "transfer");
3283       moldsize = size_in_bytes (type);
3284
3285       /* Use memcpy to do the transfer.  */
3286       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3287       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3288                              fold_convert (pvoid_type_node, tmp),
3289                              fold_convert (pvoid_type_node, ptr),
3290                              moldsize);
3291       gfc_add_expr_to_block (&se->pre, tmp);
3292
3293       se->expr = tmpdecl;
3294     }
3295 }
3296
3297
3298 /* Generate code for the ALLOCATED intrinsic.
3299    Generate inline code that directly check the address of the argument.  */
3300
3301 static void
3302 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3303 {
3304   gfc_actual_arglist *arg1;
3305   gfc_se arg1se;
3306   gfc_ss *ss1;
3307   tree tmp;
3308
3309   gfc_init_se (&arg1se, NULL);
3310   arg1 = expr->value.function.actual;
3311   ss1 = gfc_walk_expr (arg1->expr);
3312   arg1se.descriptor_only = 1;
3313   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3314
3315   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3316   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3317                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3318   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3319 }
3320
3321
3322 /* Generate code for the ASSOCIATED intrinsic.
3323    If both POINTER and TARGET are arrays, generate a call to library function
3324    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3325    In other cases, generate inline code that directly compare the address of
3326    POINTER with the address of TARGET.  */
3327
3328 static void
3329 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3330 {
3331   gfc_actual_arglist *arg1;
3332   gfc_actual_arglist *arg2;
3333   gfc_se arg1se;
3334   gfc_se arg2se;
3335   tree tmp2;
3336   tree tmp;
3337   tree nonzero_charlen;
3338   tree nonzero_arraylen;
3339   gfc_ss *ss1, *ss2;
3340
3341   gfc_init_se (&arg1se, NULL);
3342   gfc_init_se (&arg2se, NULL);
3343   arg1 = expr->value.function.actual;
3344   arg2 = arg1->next;
3345   ss1 = gfc_walk_expr (arg1->expr);
3346
3347   if (!arg2->expr)
3348     {
3349       /* No optional target.  */
3350       if (ss1 == gfc_ss_terminator)
3351         {
3352           /* A pointer to a scalar.  */
3353           arg1se.want_pointer = 1;
3354           gfc_conv_expr (&arg1se, arg1->expr);
3355           tmp2 = arg1se.expr;
3356         }
3357       else
3358         {
3359           /* A pointer to an array.  */
3360           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3361           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3362         }
3363       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3364       gfc_add_block_to_block (&se->post, &arg1se.post);
3365       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3366                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3367       se->expr = tmp;
3368     }
3369   else
3370     {
3371       /* An optional target.  */
3372       ss2 = gfc_walk_expr (arg2->expr);
3373
3374       nonzero_charlen = NULL_TREE;
3375       if (arg1->expr->ts.type == BT_CHARACTER)
3376         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3377                                   arg1->expr->ts.cl->backend_decl,
3378                                   integer_zero_node);
3379
3380       if (ss1 == gfc_ss_terminator)
3381         {
3382           /* A pointer to a scalar.  */
3383           gcc_assert (ss2 == gfc_ss_terminator);
3384           arg1se.want_pointer = 1;
3385           gfc_conv_expr (&arg1se, arg1->expr);
3386           arg2se.want_pointer = 1;
3387           gfc_conv_expr (&arg2se, arg2->expr);
3388           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3389           gfc_add_block_to_block (&se->post, &arg1se.post);
3390           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3391           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3392                          null_pointer_node);
3393           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3394         }
3395       else
3396         {
3397           /* An array pointer of zero length is not associated if target is
3398              present.  */
3399           arg1se.descriptor_only = 1;
3400           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3401           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3402                                             gfc_rank_cst[arg1->expr->rank - 1]);
3403           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3404                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3405
3406           /* A pointer to an array, call library function _gfor_associated.  */
3407           gcc_assert (ss2 != gfc_ss_terminator);
3408           arg1se.want_pointer = 1;
3409           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3410
3411           arg2se.want_pointer = 1;
3412           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3413           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3414           gfc_add_block_to_block (&se->post, &arg2se.post);
3415           se->expr = build_call_expr (gfor_fndecl_associated, 2,
3416                                       arg1se.expr, arg2se.expr);
3417           se->expr = convert (boolean_type_node, se->expr);
3418           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3419                              se->expr, nonzero_arraylen);
3420         }
3421
3422       /* If target is present zero character length pointers cannot
3423          be associated.  */
3424       if (nonzero_charlen != NULL_TREE)
3425         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3426                            se->expr, nonzero_charlen);
3427     }
3428
3429   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3430 }
3431
3432
3433 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3434
3435 static void
3436 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3437 {
3438   tree arg, type;
3439
3440   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3441
3442   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
3443   type = gfc_get_int_type (4);
3444   arg = build_fold_addr_expr (fold_convert (type, arg));
3445
3446   /* Convert it to the required type.  */
3447   type = gfc_typenode_for_spec (&expr->ts);
3448   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3449   se->expr = fold_convert (type, se->expr);
3450 }
3451
3452
3453 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3454
3455 static void
3456 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3457 {
3458   gfc_actual_arglist *actual;
3459   tree args, type;
3460   gfc_se argse;
3461
3462   args = NULL_TREE;
3463   for (actual = expr->value.function.actual; actual; actual = actual->next)
3464     {
3465       gfc_init_se (&argse, se);
3466
3467       /* Pass a NULL pointer for an absent arg.  */
3468       if (actual->expr == NULL)
3469         argse.expr = null_pointer_node;
3470       else
3471         {
3472           gfc_typespec ts;
3473           if (actual->expr->ts.kind != gfc_c_int_kind)
3474             {
3475               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
3476               ts.type = BT_INTEGER;
3477               ts.kind = gfc_c_int_kind;
3478               gfc_convert_type (actual->expr, &ts, 2);
3479             }
3480           gfc_conv_expr_reference (&argse, actual->expr);
3481         }
3482
3483       gfc_add_block_to_block (&se->pre, &argse.pre);
3484       gfc_add_block_to_block (&se->post, &argse.post);
3485       args = gfc_chainon_list (args, argse.expr);
3486     }
3487
3488   /* Convert it to the required type.  */
3489   type = gfc_typenode_for_spec (&expr->ts);
3490   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3491   se->expr = fold_convert (type, se->expr);
3492 }
3493
3494
3495 /* Generate code for TRIM (A) intrinsic function.  */
3496
3497 static void
3498 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3499 {
3500   tree gfc_int4_type_node = gfc_get_int_type (4);
3501   tree var;
3502   tree len;
3503   tree addr;
3504   tree tmp;
3505   tree type;
3506   tree cond;
3507   tree fndecl;
3508   tree *args;
3509   unsigned int num_args;
3510
3511   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3512   args = alloca (sizeof (tree) * num_args);
3513
3514   type = build_pointer_type (gfc_character1_type_node);
3515   var = gfc_create_var (type, "pstr");
3516   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3517   len = gfc_create_var (gfc_int4_type_node, "len");
3518
3519   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3520   args[0] = build_fold_addr_expr (len);
3521   args[1] = addr;
3522
3523   fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3524   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3525                           fndecl, num_args, args);
3526   gfc_add_expr_to_block (&se->pre, tmp);
3527
3528   /* Free the temporary afterwards, if necessary.  */
3529   cond = build2 (GT_EXPR, boolean_type_node, len,
3530                  build_int_cst (TREE_TYPE (len), 0));
3531   tmp = gfc_call_free (var);
3532   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3533   gfc_add_expr_to_block (&se->post, tmp);
3534
3535   se->expr = var;
3536   se->string_length = len;
3537 }
3538
3539
3540 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3541
3542 static void
3543 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3544 {
3545   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3546   tree type, cond, tmp, count, exit_label, n, max, largest;
3547   stmtblock_t block, body;
3548   int i;
3549
3550   /* Get the arguments.  */
3551   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3552   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3553   src = args[1];
3554   ncopies = gfc_evaluate_now (args[2], &se->pre);
3555   ncopies_type = TREE_TYPE (ncopies);
3556
3557   /* Check that NCOPIES is not negative.  */
3558   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3559                       build_int_cst (ncopies_type, 0));
3560   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3561                            "Argument NCOPIES of REPEAT intrinsic is negative "
3562                            "(its value is %lld)",
3563                            fold_convert (long_integer_type_node, ncopies));
3564
3565   /* If the source length is zero, any non negative value of NCOPIES
3566      is valid, and nothing happens.  */
3567   n = gfc_create_var (ncopies_type, "ncopies");
3568   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3569                       build_int_cst (size_type_node, 0));
3570   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3571                      build_int_cst (ncopies_type, 0), ncopies);
3572   gfc_add_modify_expr (&se->pre, n, tmp);
3573   ncopies = n;
3574
3575   /* Check that ncopies is not too large: ncopies should be less than
3576      (or equal to) MAX / slen, where MAX is the maximal integer of
3577      the gfc_charlen_type_node type.  If slen == 0, we need a special
3578      case to avoid the division by zero.  */
3579   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3580   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3581   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3582                      fold_convert (size_type_node, max), slen);
3583   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3584               ? size_type_node : ncopies_type;
3585   cond = fold_build2 (GT_EXPR, boolean_type_node,
3586                       fold_convert (largest, ncopies),
3587                       fold_convert (largest, max));
3588   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3589                      build_int_cst (size_type_node, 0));
3590   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3591                       cond);
3592   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3593                            "Argument NCOPIES of REPEAT intrinsic is too large");
3594
3595
3596   /* Compute the destination length.  */
3597   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3598                       fold_convert (gfc_charlen_type_node, slen),
3599                       fold_convert (gfc_charlen_type_node, ncopies));
3600   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3601   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3602
3603   /* Generate the code to do the repeat operation:
3604        for (i = 0; i < ncopies; i++)
3605          memmove (dest + (i * slen), src, slen);  */
3606   gfc_start_block (&block);
3607   count = gfc_create_var (ncopies_type, "count");
3608   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3609   exit_label = gfc_build_label_decl (NULL_TREE);
3610
3611   /* Start the loop body.  */
3612   gfc_start_block (&body);
3613
3614   /* Exit the loop if count >= ncopies.  */
3615   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3616   tmp = build1_v (GOTO_EXPR, exit_label);
3617   TREE_USED (exit_label) = 1;
3618   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3619                      build_empty_stmt ());
3620   gfc_add_expr_to_block (&body, tmp);
3621
3622   /* Call memmove (dest + (i*slen), src, slen).  */
3623   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3624                      fold_convert (gfc_charlen_type_node, slen),
3625                      fold_convert (gfc_charlen_type_node, count));
3626   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3627                      fold_convert (pchar_type_node, dest),
3628                      fold_convert (sizetype, tmp));
3629   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3630                          tmp, src, slen);
3631   gfc_add_expr_to_block (&body, tmp);
3632
3633   /* Increment count.  */
3634   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3635                 build_int_cst (TREE_TYPE (count), 1));
3636   gfc_add_modify_expr (&body, count, tmp);
3637
3638   /* Build the loop.  */
3639   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3640   gfc_add_expr_to_block (&block, tmp);
3641
3642   /* Add the exit label.  */
3643   tmp = build1_v (LABEL_EXPR, exit_label);
3644   gfc_add_expr_to_block (&block, tmp);
3645
3646   /* Finish the block.  */
3647   tmp = gfc_finish_block (&block);
3648   gfc_add_expr_to_block (&se->pre, tmp);
3649
3650   /* Set the result value.  */
3651   se->expr = dest;
3652   se->string_length = dlen;
3653 }
3654
3655
3656 /* Generate code for the IARGC intrinsic.  */
3657
3658 static void
3659 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3660 {
3661   tree tmp;
3662   tree fndecl;
3663   tree type;
3664
3665   /* Call the library function.  This always returns an INTEGER(4).  */
3666   fndecl = gfor_fndecl_iargc;
3667   tmp = build_call_expr (fndecl, 0);
3668
3669   /* Convert it to the required type.  */
3670   type = gfc_typenode_for_spec (&expr->ts);
3671   tmp = fold_convert (type, tmp);
3672
3673   se->expr = tmp;
3674 }
3675
3676
3677 /* The loc intrinsic returns the address of its argument as
3678    gfc_index_integer_kind integer.  */
3679
3680 static void
3681 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3682 {
3683   tree temp_var;
3684   gfc_expr *arg_expr;
3685   gfc_ss *ss;
3686
3687   gcc_assert (!se->ss);
3688
3689   arg_expr = expr->value.function.actual->expr;
3690   ss = gfc_walk_expr (arg_expr);
3691   if (ss == gfc_ss_terminator)
3692     gfc_conv_expr_reference (se, arg_expr);
3693   else
3694     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3695   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3696
3697   /* Create a temporary variable for loc return value.  Without this,
3698      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3699   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3700   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3701   se->expr = temp_var;
3702 }
3703
3704 /* Generate code for an intrinsic function.  Some map directly to library
3705    calls, others get special handling.  In some cases the name of the function
3706    used depends on the type specifiers.  */
3707
3708 void
3709 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3710 {
3711   gfc_intrinsic_sym *isym;
3712   const char *name;
3713   int lib;
3714
3715   isym = expr->value.function.isym;
3716
3717   name = &expr->value.function.name[2];
3718
3719   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3720     {
3721       lib = gfc_is_intrinsic_libcall (expr);
3722       if (lib != 0)
3723         {
3724           if (lib == 1)
3725             se->ignore_optional = 1;
3726           gfc_conv_intrinsic_funcall (se, expr);
3727           return;
3728         }
3729     }
3730
3731   switch (expr->value.function.isym->id)
3732     {
3733     case GFC_ISYM_NONE:
3734       gcc_unreachable ();
3735
3736     case GFC_ISYM_REPEAT:
3737       gfc_conv_intrinsic_repeat (se, expr);
3738       break;
3739
3740     case GFC_ISYM_TRIM:
3741       gfc_conv_intrinsic_trim (se, expr);
3742       break;
3743
3744     case GFC_ISYM_SI_KIND:
3745       gfc_conv_intrinsic_si_kind (se, expr);
3746       break;
3747
3748     case GFC_ISYM_SR_KIND:
3749       gfc_conv_intrinsic_sr_kind (se, expr);
3750       break;
3751
3752     case GFC_ISYM_EXPONENT:
3753       gfc_conv_intrinsic_exponent (se, expr);
3754       break;
3755
3756     case GFC_ISYM_SCAN:
3757       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
3758       break;
3759
3760     case GFC_ISYM_VERIFY:
3761       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
3762       break;
3763
3764     case GFC_ISYM_ALLOCATED:
3765       gfc_conv_allocated (se, expr);
3766       break;
3767
3768     case GFC_ISYM_ASSOCIATED:
3769       gfc_conv_associated(se, expr);
3770       break;
3771
3772     case GFC_ISYM_ABS:
3773       gfc_conv_intrinsic_abs (se, expr);
3774       break;
3775
3776     case GFC_ISYM_ADJUSTL:
3777       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3778       break;
3779
3780     case GFC_ISYM_ADJUSTR:
3781       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3782       break;
3783
3784     case GFC_ISYM_AIMAG:
3785       gfc_conv_intrinsic_imagpart (se, expr);
3786       break;
3787
3788     case GFC_ISYM_AINT:
3789       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3790       break;
3791
3792     case GFC_ISYM_ALL:
3793       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3794       break;
3795
3796     case GFC_ISYM_ANINT:
3797       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3798       break;
3799
3800     case GFC_ISYM_AND:
3801       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3802       break;
3803
3804     case GFC_ISYM_ANY:
3805       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3806       break;
3807
3808     case GFC_ISYM_BTEST:
3809       gfc_conv_intrinsic_btest (se, expr);
3810       break;
3811
3812     case GFC_ISYM_ACHAR:
3813     case GFC_ISYM_CHAR:
3814       gfc_conv_intrinsic_char (se, expr);
3815       break;
3816
3817     case GFC_ISYM_CONVERSION:
3818     case GFC_ISYM_REAL:
3819     case GFC_ISYM_LOGICAL:
3820     case GFC_ISYM_DBLE:
3821       gfc_conv_intrinsic_conversion (se, expr);
3822       break;
3823
3824       /* Integer conversions are handled separately to make sure we get the
3825          correct rounding mode.  */
3826     case GFC_ISYM_INT:
3827     case GFC_ISYM_INT2:
3828     case GFC_ISYM_INT8:
3829     case GFC_ISYM_LONG:
3830       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3831       break;
3832
3833     case GFC_ISYM_NINT:
3834       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3835       break;
3836
3837     case GFC_ISYM_CEILING:
3838       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3839       break;
3840
3841     case GFC_ISYM_FLOOR:
3842       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3843       break;
3844
3845     case GFC_ISYM_MOD:
3846       gfc_conv_intrinsic_mod (se, expr, 0);
3847       break;
3848
3849     case GFC_ISYM_MODULO:
3850       gfc_conv_intrinsic_mod (se, expr, 1);
3851       break;
3852
3853     case GFC_ISYM_CMPLX:
3854       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3855       break;
3856
3857     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3858       gfc_conv_intrinsic_iargc (se, expr);
3859       break;
3860
3861     case GFC_ISYM_COMPLEX:
3862       gfc_conv_intrinsic_cmplx (se, expr, 1);
3863       break;
3864
3865     case GFC_ISYM_CONJG:
3866       gfc_conv_intrinsic_conjg (se, expr);
3867       break;
3868
3869     case GFC_ISYM_COUNT:
3870       gfc_conv_intrinsic_count (se, expr);
3871       break;
3872
3873     case GFC_ISYM_CTIME:
3874       gfc_conv_intrinsic_ctime (se, expr);
3875       break;
3876
3877     case GFC_ISYM_DIM:
3878       gfc_conv_intrinsic_dim (se, expr);
3879       break;
3880
3881     case GFC_ISYM_DOT_PRODUCT:
3882       gfc_conv_intrinsic_dot_product (se, expr);
3883       break;
3884
3885     case GFC_ISYM_DPROD:
3886       gfc_conv_intrinsic_dprod (se, expr);
3887       break;
3888
3889     case GFC_ISYM_FDATE:
3890       gfc_conv_intrinsic_fdate (se, expr);
3891       break;
3892
3893     case GFC_ISYM_IAND:
3894       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3895       break;
3896
3897     case GFC_ISYM_IBCLR:
3898       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3899       break;
3900
3901     case GFC_ISYM_IBITS:
3902       gfc_conv_intrinsic_ibits (se, expr);
3903       break;
3904
3905     case GFC_ISYM_IBSET:
3906       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3907       break;
3908
3909     case GFC_ISYM_IACHAR:
3910     case GFC_ISYM_ICHAR:
3911       /* We assume ASCII character sequence.  */
3912       gfc_conv_intrinsic_ichar (se, expr);
3913       break;
3914
3915     case GFC_ISYM_IARGC:
3916       gfc_conv_intrinsic_iargc (se, expr);
3917       break;
3918
3919     case GFC_ISYM_IEOR:
3920       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3921       break;
3922
3923     case GFC_ISYM_INDEX:
3924       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
3925       break;
3926
3927     case GFC_ISYM_IOR:
3928       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3929       break;
3930
3931     case GFC_ISYM_IS_IOSTAT_END:
3932       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
3933       break;
3934
3935     case GFC_ISYM_IS_IOSTAT_EOR:
3936       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
3937       break;
3938
3939     case GFC_ISYM_ISNAN:
3940       gfc_conv_intrinsic_isnan (se, expr);
3941       break;
3942
3943     case GFC_ISYM_LSHIFT:
3944       gfc_conv_intrinsic_rlshift (se, expr, 0);
3945       break;
3946
3947     case GFC_ISYM_RSHIFT:
3948       gfc_conv_intrinsic_rlshift (se, expr, 1);
3949       break;
3950
3951     case GFC_ISYM_ISHFT:
3952       gfc_conv_intrinsic_ishft (se, expr);
3953       break;
3954
3955     case GFC_ISYM_ISHFTC:
3956       gfc_conv_intrinsic_ishftc (se, expr);
3957       break;
3958
3959     case GFC_ISYM_LBOUND:
3960       gfc_conv_intrinsic_bound (se, expr, 0);
3961       break;
3962
3963     case GFC_ISYM_TRANSPOSE:
3964       if (se->ss && se->ss->useflags)
3965         {
3966           gfc_conv_tmp_array_ref (se);
3967           gfc_advance_se_ss_chain (se);
3968         }
3969       else
3970         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3971       break;
3972
3973     case GFC_ISYM_LEN:
3974       gfc_conv_intrinsic_len (se, expr);
3975       break;
3976
3977     case GFC_ISYM_LEN_TRIM:
3978       gfc_conv_intrinsic_len_trim (se, expr);
3979       break;
3980
3981     case GFC_ISYM_LGE:
3982       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3983       break;
3984
3985     case GFC_ISYM_LGT:
3986       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3987       break;
3988
3989     case GFC_ISYM_LLE:
3990       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3991       break;
3992
3993     case GFC_ISYM_LLT:
3994       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3995       break;
3996
3997     case GFC_ISYM_MAX:
3998       if (expr->ts.type == BT_CHARACTER)
3999         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4000       else
4001         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4002       break;
4003
4004     case GFC_ISYM_MAXLOC:
4005       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4006       break;
4007
4008     case GFC_ISYM_MAXVAL:
4009       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4010       break;
4011
4012     case GFC_ISYM_MERGE:
4013       gfc_conv_intrinsic_merge (se, expr);
4014       break;
4015
4016     case GFC_ISYM_MIN:
4017       if (expr->ts.type == BT_CHARACTER)
4018         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4019       else
4020         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4021       break;
4022
4023     case GFC_ISYM_MINLOC:
4024       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4025       break;
4026
4027     case GFC_ISYM_MINVAL:
4028       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4029       break;
4030
4031     case GFC_ISYM_NOT:
4032       gfc_conv_intrinsic_not (se, expr);
4033       break;
4034
4035     case GFC_ISYM_OR:
4036       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4037       break;
4038
4039     case GFC_ISYM_PRESENT:
4040       gfc_conv_intrinsic_present (se, expr);
4041       break;
4042
4043     case GFC_ISYM_PRODUCT:
4044       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4045       break;
4046
4047     case GFC_ISYM_SIGN:
4048       gfc_conv_intrinsic_sign (se, expr);
4049       break;
4050
4051     case GFC_ISYM_SIZE:
4052       gfc_conv_intrinsic_size (se, expr);
4053       break;
4054
4055     case GFC_ISYM_SIZEOF:
4056       gfc_conv_intrinsic_sizeof (se, expr);
4057       break;
4058
4059     case GFC_ISYM_SUM:
4060       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4061       break;
4062
4063     case GFC_ISYM_TRANSFER:
4064       if (se->ss)
4065         {
4066           if (se->ss->useflags)
4067             {
4068               /* Access the previously obtained result.  */
4069               gfc_conv_tmp_array_ref (se);
4070               gfc_advance_se_ss_chain (se);
4071               break;
4072             }
4073           else
4074             gfc_conv_intrinsic_array_transfer (se, expr);
4075         }
4076       else
4077         gfc_conv_intrinsic_transfer (se, expr);
4078       break;
4079
4080     case GFC_ISYM_TTYNAM:
4081       gfc_conv_intrinsic_ttynam (se, expr);
4082       break;
4083
4084     case GFC_ISYM_UBOUND:
4085       gfc_conv_intrinsic_bound (se, expr, 1);
4086       break;
4087
4088     case GFC_ISYM_XOR:
4089       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4090       break;
4091
4092     case GFC_ISYM_LOC:
4093       gfc_conv_intrinsic_loc (se, expr);
4094       break;
4095
4096     case GFC_ISYM_ACCESS:
4097     case GFC_ISYM_CHDIR:
4098     case GFC_ISYM_CHMOD:
4099     case GFC_ISYM_ETIME:
4100     case GFC_ISYM_FGET:
4101     case GFC_ISYM_FGETC:
4102     case GFC_ISYM_FNUM:
4103     case GFC_ISYM_FPUT:
4104     case GFC_ISYM_FPUTC:
4105     case GFC_ISYM_FSTAT:
4106     case GFC_ISYM_FTELL:
4107     case GFC_ISYM_GETCWD:
4108     case GFC_ISYM_GETGID:
4109     case GFC_ISYM_GETPID:
4110     case GFC_ISYM_GETUID:
4111     case GFC_ISYM_HOSTNM:
4112     case GFC_ISYM_KILL:
4113     case GFC_ISYM_IERRNO:
4114     case GFC_ISYM_IRAND:
4115     case GFC_ISYM_ISATTY:
4116     case GFC_ISYM_LINK:
4117     case GFC_ISYM_LSTAT:
4118     case GFC_ISYM_MALLOC:
4119     case GFC_ISYM_MATMUL:
4120     case GFC_ISYM_MCLOCK:
4121     case GFC_ISYM_MCLOCK8:
4122     case GFC_ISYM_RAND:
4123     case GFC_ISYM_RENAME:
4124     case GFC_ISYM_SECOND:
4125     case GFC_ISYM_SECNDS:
4126     case GFC_ISYM_SIGNAL:
4127     case GFC_ISYM_STAT:
4128     case GFC_ISYM_SYMLNK:
4129     case GFC_ISYM_SYSTEM:
4130     case GFC_ISYM_TIME:
4131     case GFC_ISYM_TIME8:
4132     case GFC_ISYM_UMASK:
4133     case GFC_ISYM_UNLINK:
4134       gfc_conv_intrinsic_funcall (se, expr);
4135       break;
4136
4137     default:
4138       gfc_conv_intrinsic_lib_function (se, expr);
4139       break;
4140     }
4141 }
4142
4143
4144 /* This generates code to execute before entering the scalarization loop.
4145    Currently does nothing.  */
4146
4147 void
4148 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4149 {
4150   switch (ss->expr->value.function.isym->id)
4151     {
4152     case GFC_ISYM_UBOUND:
4153     case GFC_ISYM_LBOUND:
4154       break;
4155
4156     default:
4157       gcc_unreachable ();
4158     }
4159 }
4160
4161
4162 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4163    inside the scalarization loop.  */
4164
4165 static gfc_ss *
4166 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4167 {
4168   gfc_ss *newss;
4169
4170   /* The two argument version returns a scalar.  */
4171   if (expr->value.function.actual->next->expr)
4172     return ss;
4173
4174   newss = gfc_get_ss ();
4175   newss->type = GFC_SS_INTRINSIC;
4176   newss->expr = expr;
4177   newss->next = ss;
4178   newss->data.info.dimen = 1;
4179
4180   return newss;
4181 }
4182
4183
4184 /* Walk an intrinsic array libcall.  */
4185
4186 static gfc_ss *
4187 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4188 {
4189   gfc_ss *newss;
4190
4191   gcc_assert (expr->rank > 0);
4192
4193   newss = gfc_get_ss ();
4194   newss->type = GFC_SS_FUNCTION;
4195   newss->expr = expr;
4196   newss->next = ss;
4197   newss->data.info.dimen = expr->rank;
4198
4199   return newss;
4200 }
4201
4202
4203 /* Returns nonzero if the specified intrinsic function call maps directly to a
4204    an external library call.  Should only be used for functions that return
4205    arrays.  */
4206
4207 int
4208 gfc_is_intrinsic_libcall (gfc_expr * expr)
4209 {
4210   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4211   gcc_assert (expr->rank > 0);
4212
4213   switch (expr->value.function.isym->id)
4214     {
4215     case GFC_ISYM_ALL:
4216     case GFC_ISYM_ANY:
4217     case GFC_ISYM_COUNT:
4218     case GFC_ISYM_MATMUL:
4219     case GFC_ISYM_MAXLOC:
4220     case GFC_ISYM_MAXVAL:
4221     case GFC_ISYM_MINLOC:
4222     case GFC_ISYM_MINVAL:
4223     case GFC_ISYM_PRODUCT:
4224     case GFC_ISYM_SUM:
4225     case GFC_ISYM_SHAPE:
4226     case GFC_ISYM_SPREAD:
4227     case GFC_ISYM_TRANSPOSE:
4228       /* Ignore absent optional parameters.  */
4229       return 1;
4230
4231     case GFC_ISYM_RESHAPE:
4232     case GFC_ISYM_CSHIFT:
4233     case GFC_ISYM_EOSHIFT:
4234     case GFC_ISYM_PACK:
4235     case GFC_ISYM_UNPACK:
4236       /* Pass absent optional parameters.  */
4237       return 2;
4238
4239     default:
4240       return 0;
4241     }
4242 }
4243
4244 /* Walk an intrinsic function.  */
4245 gfc_ss *
4246 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4247                              gfc_intrinsic_sym * isym)
4248 {
4249   gcc_assert (isym);
4250
4251   if (isym->elemental)
4252     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4253
4254   if (expr->rank == 0)
4255     return ss;
4256
4257   if (gfc_is_intrinsic_libcall (expr))
4258     return gfc_walk_intrinsic_libfunc (ss, expr);
4259
4260   /* Special cases.  */
4261   switch (isym->id)
4262     {
4263     case GFC_ISYM_LBOUND:
4264     case GFC_ISYM_UBOUND:
4265       return gfc_walk_intrinsic_bound (ss, expr);
4266
4267     case GFC_ISYM_TRANSFER:
4268       return gfc_walk_intrinsic_libfunc (ss, expr);
4269
4270     default:
4271       /* This probably meant someone forgot to add an intrinsic to the above
4272          list(s) when they implemented it, or something's gone horribly
4273          wrong.  */
4274       gcc_unreachable ();
4275     }
4276 }
4277
4278 #include "gt-fortran-trans-intrinsic.h"