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