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 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2763
2764 static void
2765 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2766 {
2767   tree tsource;
2768   tree fsource;
2769   tree mask;
2770   tree type;
2771   tree len;
2772   tree *args;
2773   unsigned int num_args;
2774
2775   num_args = gfc_intrinsic_argument_list_length (expr);
2776   args = alloca (sizeof (tree) * num_args);
2777
2778   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2779   if (expr->ts.type != BT_CHARACTER)
2780     {
2781       tsource = args[0];
2782       fsource = args[1];
2783       mask = args[2];
2784     }
2785   else
2786     {
2787       /* We do the same as in the non-character case, but the argument
2788          list is different because of the string length arguments. We
2789          also have to set the string length for the result.  */
2790       len = args[0];
2791       tsource = args[1];
2792       fsource = args[3];
2793       mask = args[4];
2794
2795       se->string_length = len;
2796     }
2797   type = TREE_TYPE (tsource);
2798   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2799 }
2800
2801
2802 static void
2803 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2804 {
2805   gfc_actual_arglist *actual;
2806   tree arg1;
2807   tree type;
2808   tree fncall0;
2809   tree fncall1;
2810   gfc_se argse;
2811   gfc_ss *ss;
2812
2813   gfc_init_se (&argse, NULL);
2814   actual = expr->value.function.actual;
2815
2816   ss = gfc_walk_expr (actual->expr);
2817   gcc_assert (ss != gfc_ss_terminator);
2818   argse.want_pointer = 1;
2819   argse.data_not_needed = 1;
2820   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2821   gfc_add_block_to_block (&se->pre, &argse.pre);
2822   gfc_add_block_to_block (&se->post, &argse.post);
2823   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2824
2825   /* Build the call to size0.  */
2826   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2827
2828   actual = actual->next;
2829
2830   if (actual->expr)
2831     {
2832       gfc_init_se (&argse, NULL);
2833       gfc_conv_expr_type (&argse, actual->expr,
2834                           gfc_array_index_type);
2835       gfc_add_block_to_block (&se->pre, &argse.pre);
2836
2837       /* Build the call to size1.  */
2838       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2839                                  arg1, argse.expr);
2840
2841       /* Unusually, for an intrinsic, size does not exclude
2842          an optional arg2, so we must test for it.  */
2843       if (actual->expr->expr_type == EXPR_VARIABLE
2844             && actual->expr->symtree->n.sym->attr.dummy
2845             && actual->expr->symtree->n.sym->attr.optional)
2846         {
2847           tree tmp;
2848           gfc_init_se (&argse, NULL);
2849           argse.want_pointer = 1;
2850           argse.data_not_needed = 1;
2851           gfc_conv_expr (&argse, actual->expr);
2852           gfc_add_block_to_block (&se->pre, &argse.pre);
2853           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2854                         null_pointer_node);
2855           tmp = gfc_evaluate_now (tmp, &se->pre);
2856           se->expr = build3 (COND_EXPR, pvoid_type_node,
2857                              tmp, fncall1, fncall0);
2858         }
2859       else
2860         se->expr = fncall1;
2861     }
2862   else
2863     se->expr = fncall0;
2864
2865   type = gfc_typenode_for_spec (&expr->ts);
2866   se->expr = convert (type, se->expr);
2867 }
2868
2869
2870 static void
2871 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2872 {
2873   gfc_expr *arg;
2874   gfc_ss *ss;
2875   gfc_se argse;
2876   tree source;
2877   tree source_bytes;
2878   tree type;
2879   tree tmp;
2880   tree lower;
2881   tree upper;
2882   /*tree stride;*/
2883   int n;
2884
2885   arg = expr->value.function.actual->expr;
2886
2887   gfc_init_se (&argse, NULL);
2888   ss = gfc_walk_expr (arg);
2889
2890   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2891
2892   if (ss == gfc_ss_terminator)
2893     {
2894       gfc_conv_expr_reference (&argse, arg);
2895       source = argse.expr;
2896
2897       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2898
2899       /* Obtain the source word length.  */
2900       if (arg->ts.type == BT_CHARACTER)
2901         source_bytes = fold_convert (gfc_array_index_type,
2902                                      argse.string_length);
2903       else
2904         source_bytes = fold_convert (gfc_array_index_type,
2905                                      size_in_bytes (type));
2906     }
2907   else
2908     {
2909       argse.want_pointer = 0;
2910       gfc_conv_expr_descriptor (&argse, arg, ss);
2911       source = gfc_conv_descriptor_data_get (argse.expr);
2912       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2913
2914       /* Obtain the argument's word length.  */
2915       if (arg->ts.type == BT_CHARACTER)
2916         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2917       else
2918         tmp = fold_convert (gfc_array_index_type,
2919                             size_in_bytes (type));
2920       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2921
2922       /* Obtain the size of the array in bytes.  */
2923       for (n = 0; n < arg->rank; n++)
2924         {
2925           tree idx;
2926           idx = gfc_rank_cst[n];
2927           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2928           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2929           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2930                              upper, lower);
2931           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2932                              tmp, gfc_index_one_node);
2933           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2934                              tmp, source_bytes);
2935           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2936         }
2937     }
2938
2939   gfc_add_block_to_block (&se->pre, &argse.pre);
2940   se->expr = source_bytes;
2941 }
2942
2943
2944 /* Intrinsic string comparison functions.  */
2945
2946 static void
2947 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2948 {
2949   tree args[4];
2950
2951   gfc_conv_intrinsic_function_args (se, expr, args, 4);
2952
2953   se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
2954   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
2955                           build_int_cst (TREE_TYPE (se->expr), 0));
2956 }
2957
2958 /* Generate a call to the adjustl/adjustr library function.  */
2959 static void
2960 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2961 {
2962   tree args[3];
2963   tree len;
2964   tree type;
2965   tree var;
2966   tree tmp;
2967
2968   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
2969   len = args[1];
2970
2971   type = TREE_TYPE (args[2]);
2972   var = gfc_conv_string_tmp (se, type, len);
2973   args[0] = var;
2974
2975   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
2976   gfc_add_expr_to_block (&se->pre, tmp);
2977   se->expr = var;
2978   se->string_length = len;
2979 }
2980
2981
2982 /* Array transfer statement.
2983      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2984    where:
2985      typeof<DEST> = typeof<MOLD>
2986    and:
2987      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2988               sizeof (DEST(0) * SIZE).  */
2989
2990 static void
2991 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2992 {
2993   tree tmp;
2994   tree extent;
2995   tree source;
2996   tree source_type;
2997   tree source_bytes;
2998   tree mold_type;
2999   tree dest_word_len;
3000   tree size_words;
3001   tree size_bytes;
3002   tree upper;
3003   tree lower;
3004   tree stride;
3005   tree stmt;
3006   gfc_actual_arglist *arg;
3007   gfc_se argse;
3008   gfc_ss *ss;
3009   gfc_ss_info *info;
3010   stmtblock_t block;
3011   int n;
3012
3013   gcc_assert (se->loop);
3014   info = &se->ss->data.info;
3015
3016   /* Convert SOURCE.  The output from this stage is:-
3017         source_bytes = length of the source in bytes
3018         source = pointer to the source data.  */
3019   arg = expr->value.function.actual;
3020   gfc_init_se (&argse, NULL);
3021   ss = gfc_walk_expr (arg->expr);
3022
3023   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3024
3025   /* Obtain the pointer to source and the length of source in bytes.  */
3026   if (ss == gfc_ss_terminator)
3027     {
3028       gfc_conv_expr_reference (&argse, arg->expr);
3029       source = argse.expr;
3030
3031       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3032
3033       /* Obtain the source word length.  */
3034       if (arg->expr->ts.type == BT_CHARACTER)
3035         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3036       else
3037         tmp = fold_convert (gfc_array_index_type,
3038                             size_in_bytes (source_type));
3039     }
3040   else
3041     {
3042       argse.want_pointer = 0;
3043       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3044       source = gfc_conv_descriptor_data_get (argse.expr);
3045       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3046
3047       /* Repack the source if not a full variable array.  */
3048       if (!(arg->expr->expr_type == EXPR_VARIABLE
3049               && arg->expr->ref->u.ar.type == AR_FULL))
3050         {
3051           tmp = build_fold_addr_expr (argse.expr);
3052           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3053           source = gfc_evaluate_now (source, &argse.pre);
3054
3055           /* Free the temporary.  */
3056           gfc_start_block (&block);
3057           tmp = gfc_call_free (convert (pvoid_type_node, source));
3058           gfc_add_expr_to_block (&block, tmp);
3059           stmt = gfc_finish_block (&block);
3060
3061           /* Clean up if it was repacked.  */
3062           gfc_init_block (&block);
3063           tmp = gfc_conv_array_data (argse.expr);
3064           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3065           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3066           gfc_add_expr_to_block (&block, tmp);
3067           gfc_add_block_to_block (&block, &se->post);
3068           gfc_init_block (&se->post);
3069           gfc_add_block_to_block (&se->post, &block);
3070         }
3071
3072       /* Obtain the source word length.  */
3073       if (arg->expr->ts.type == BT_CHARACTER)
3074         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3075       else
3076         tmp = fold_convert (gfc_array_index_type,
3077                             size_in_bytes (source_type));
3078
3079       /* Obtain the size of the array in bytes.  */
3080       extent = gfc_create_var (gfc_array_index_type, NULL);
3081       for (n = 0; n < arg->expr->rank; n++)
3082         {
3083           tree idx;
3084           idx = gfc_rank_cst[n];
3085           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3086           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3087           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3088           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3089           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3090                              upper, lower);
3091           gfc_add_modify_expr (&argse.pre, extent, tmp);
3092           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3093                              extent, gfc_index_one_node);
3094           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3095                              tmp, source_bytes);
3096         }
3097     }
3098
3099   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3100   gfc_add_block_to_block (&se->pre, &argse.pre);
3101   gfc_add_block_to_block (&se->post, &argse.post);
3102
3103   /* Now convert MOLD.  The outputs are:
3104         mold_type = the TREE type of MOLD
3105         dest_word_len = destination word length in bytes.  */
3106   arg = arg->next;
3107
3108   gfc_init_se (&argse, NULL);
3109   ss = gfc_walk_expr (arg->expr);
3110
3111   if (ss == gfc_ss_terminator)
3112     {
3113       gfc_conv_expr_reference (&argse, arg->expr);
3114       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3115     }
3116   else
3117     {
3118       gfc_init_se (&argse, NULL);
3119       argse.want_pointer = 0;
3120       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3121       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3122     }
3123
3124   if (arg->expr->ts.type == BT_CHARACTER)
3125     {
3126       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3127       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3128     }
3129   else
3130     tmp = fold_convert (gfc_array_index_type,
3131                         size_in_bytes (mold_type));
3132
3133   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3134   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3135
3136   /* Finally convert SIZE, if it is present.  */
3137   arg = arg->next;
3138   size_words = gfc_create_var (gfc_array_index_type, NULL);
3139
3140   if (arg->expr)
3141     {
3142       gfc_init_se (&argse, NULL);
3143       gfc_conv_expr_reference (&argse, arg->expr);
3144       tmp = convert (gfc_array_index_type,
3145                          build_fold_indirect_ref (argse.expr));
3146       gfc_add_block_to_block (&se->pre, &argse.pre);
3147       gfc_add_block_to_block (&se->post, &argse.post);
3148     }
3149   else
3150     tmp = NULL_TREE;
3151
3152   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3153   if (tmp != NULL_TREE)
3154     {
3155       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3156                          tmp, dest_word_len);
3157       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3158                          tmp, source_bytes);
3159     }
3160   else
3161     tmp = source_bytes;
3162
3163   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3164   gfc_add_modify_expr (&se->pre, size_words,
3165                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3166                                     size_bytes, dest_word_len));
3167
3168   /* Evaluate the bounds of the result.  If the loop range exists, we have
3169      to check if it is too large.  If so, we modify loop->to be consistent
3170      with min(size, size(source)).  Otherwise, size is made consistent with
3171      the loop range, so that the right number of bytes is transferred.*/
3172   n = se->loop->order[0];
3173   if (se->loop->to[n] != NULL_TREE)
3174     {
3175       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3176                          se->loop->to[n], se->loop->from[n]);
3177       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3178                          tmp, gfc_index_one_node);
3179       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3180                          tmp, size_words);
3181       gfc_add_modify_expr (&se->pre, size_words, tmp);
3182       gfc_add_modify_expr (&se->pre, size_bytes,
3183                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3184                                         size_words, dest_word_len));
3185       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3186                            size_words, se->loop->from[n]);
3187       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3188                            upper, gfc_index_one_node);
3189     }
3190   else
3191     {
3192       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3193                            size_words, gfc_index_one_node);
3194       se->loop->from[n] = gfc_index_zero_node;
3195     }
3196
3197   se->loop->to[n] = upper;
3198
3199   /* Build a destination descriptor, using the pointer, source, as the
3200      data field.  This is already allocated so set callee_alloc.
3201      FIXME callee_alloc is not set!  */
3202
3203   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3204                                info, mold_type, false, true, false);
3205
3206   /* Cast the pointer to the result.  */
3207   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3208   tmp = fold_convert (pvoid_type_node, tmp);
3209
3210   /* Use memcpy to do the transfer.  */
3211   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3212                          3,
3213                          tmp,
3214                          fold_convert (pvoid_type_node, source),
3215                          size_bytes);
3216   gfc_add_expr_to_block (&se->pre, tmp);
3217
3218   se->expr = info->descriptor;
3219   if (expr->ts.type == BT_CHARACTER)
3220     se->string_length = dest_word_len;
3221 }
3222
3223
3224 /* Scalar transfer statement.
3225    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3226
3227 static void
3228 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3229 {
3230   gfc_actual_arglist *arg;
3231   gfc_se argse;
3232   tree type;
3233   tree ptr;
3234   gfc_ss *ss;
3235   tree tmpdecl, tmp;
3236
3237   /* Get a pointer to the source.  */
3238   arg = expr->value.function.actual;
3239   ss = gfc_walk_expr (arg->expr);
3240   gfc_init_se (&argse, NULL);
3241   if (ss == gfc_ss_terminator)
3242     gfc_conv_expr_reference (&argse, arg->expr);
3243   else
3244     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3245   gfc_add_block_to_block (&se->pre, &argse.pre);
3246   gfc_add_block_to_block (&se->post, &argse.post);
3247   ptr = argse.expr;
3248
3249   arg = arg->next;
3250   type = gfc_typenode_for_spec (&expr->ts);
3251
3252   if (expr->ts.type == BT_CHARACTER)
3253     {
3254       ptr = convert (build_pointer_type (type), ptr);
3255       gfc_init_se (&argse, NULL);
3256       gfc_conv_expr (&argse, arg->expr);
3257       gfc_add_block_to_block (&se->pre, &argse.pre);
3258       gfc_add_block_to_block (&se->post, &argse.post);
3259       se->expr = ptr;
3260       se->string_length = argse.string_length;
3261     }
3262   else
3263     {
3264       tree moldsize;
3265       tmpdecl = gfc_create_var (type, "transfer");
3266       moldsize = size_in_bytes (type);
3267
3268       /* Use memcpy to do the transfer.  */
3269       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3270       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3271                              fold_convert (pvoid_type_node, tmp),
3272                              fold_convert (pvoid_type_node, ptr),
3273                              moldsize);
3274       gfc_add_expr_to_block (&se->pre, tmp);
3275
3276       se->expr = tmpdecl;
3277     }
3278 }
3279
3280
3281 /* Generate code for the ALLOCATED intrinsic.
3282    Generate inline code that directly check the address of the argument.  */
3283
3284 static void
3285 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3286 {
3287   gfc_actual_arglist *arg1;
3288   gfc_se arg1se;
3289   gfc_ss *ss1;
3290   tree tmp;
3291
3292   gfc_init_se (&arg1se, NULL);
3293   arg1 = expr->value.function.actual;
3294   ss1 = gfc_walk_expr (arg1->expr);
3295   arg1se.descriptor_only = 1;
3296   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3297
3298   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3299   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3300                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3301   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3302 }
3303
3304
3305 /* Generate code for the ASSOCIATED intrinsic.
3306    If both POINTER and TARGET are arrays, generate a call to library function
3307    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3308    In other cases, generate inline code that directly compare the address of
3309    POINTER with the address of TARGET.  */
3310
3311 static void
3312 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3313 {
3314   gfc_actual_arglist *arg1;
3315   gfc_actual_arglist *arg2;
3316   gfc_se arg1se;
3317   gfc_se arg2se;
3318   tree tmp2;
3319   tree tmp;
3320   tree nonzero_charlen;
3321   tree nonzero_arraylen;
3322   gfc_ss *ss1, *ss2;
3323
3324   gfc_init_se (&arg1se, NULL);
3325   gfc_init_se (&arg2se, NULL);
3326   arg1 = expr->value.function.actual;
3327   arg2 = arg1->next;
3328   ss1 = gfc_walk_expr (arg1->expr);
3329
3330   if (!arg2->expr)
3331     {
3332       /* No optional target.  */
3333       if (ss1 == gfc_ss_terminator)
3334         {
3335           /* A pointer to a scalar.  */
3336           arg1se.want_pointer = 1;
3337           gfc_conv_expr (&arg1se, arg1->expr);
3338           tmp2 = arg1se.expr;
3339         }
3340       else
3341         {
3342           /* A pointer to an array.  */
3343           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3344           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3345         }
3346       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3347       gfc_add_block_to_block (&se->post, &arg1se.post);
3348       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3349                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3350       se->expr = tmp;
3351     }
3352   else
3353     {
3354       /* An optional target.  */
3355       ss2 = gfc_walk_expr (arg2->expr);
3356
3357       nonzero_charlen = NULL_TREE;
3358       if (arg1->expr->ts.type == BT_CHARACTER)
3359         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3360                                   arg1->expr->ts.cl->backend_decl,
3361                                   integer_zero_node);
3362
3363       if (ss1 == gfc_ss_terminator)
3364         {
3365           /* A pointer to a scalar.  */
3366           gcc_assert (ss2 == gfc_ss_terminator);
3367           arg1se.want_pointer = 1;
3368           gfc_conv_expr (&arg1se, arg1->expr);
3369           arg2se.want_pointer = 1;
3370           gfc_conv_expr (&arg2se, arg2->expr);
3371           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3372           gfc_add_block_to_block (&se->post, &arg1se.post);
3373           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3374           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3375                          null_pointer_node);
3376           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3377         }
3378       else
3379         {
3380           /* An array pointer of zero length is not associated if target is
3381              present.  */
3382           arg1se.descriptor_only = 1;
3383           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3384           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3385                                             gfc_rank_cst[arg1->expr->rank - 1]);
3386           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3387                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3388
3389           /* A pointer to an array, call library function _gfor_associated.  */
3390           gcc_assert (ss2 != gfc_ss_terminator);
3391           arg1se.want_pointer = 1;
3392           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3393
3394           arg2se.want_pointer = 1;
3395           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3396           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3397           gfc_add_block_to_block (&se->post, &arg2se.post);
3398           se->expr = build_call_expr (gfor_fndecl_associated, 2,
3399                                       arg1se.expr, arg2se.expr);
3400           se->expr = convert (boolean_type_node, se->expr);
3401           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3402                              se->expr, nonzero_arraylen);
3403         }
3404
3405       /* If target is present zero character length pointers cannot
3406          be associated.  */
3407       if (nonzero_charlen != NULL_TREE)
3408         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3409                            se->expr, nonzero_charlen);
3410     }
3411
3412   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3413 }
3414
3415
3416 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3417
3418 static void
3419 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3420 {
3421   tree arg, type;
3422
3423   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3424
3425   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
3426   type = gfc_get_int_type (4);
3427   arg = build_fold_addr_expr (fold_convert (type, arg));
3428
3429   /* Convert it to the required type.  */
3430   type = gfc_typenode_for_spec (&expr->ts);
3431   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3432   se->expr = fold_convert (type, se->expr);
3433 }
3434
3435
3436 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3437
3438 static void
3439 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3440 {
3441   gfc_actual_arglist *actual;
3442   tree args, type;
3443   gfc_se argse;
3444
3445   args = NULL_TREE;
3446   for (actual = expr->value.function.actual; actual; actual = actual->next)
3447     {
3448       gfc_init_se (&argse, se);
3449
3450       /* Pass a NULL pointer for an absent arg.  */
3451       if (actual->expr == NULL)
3452         argse.expr = null_pointer_node;
3453       else
3454         {
3455           gfc_typespec ts;
3456           if (actual->expr->ts.kind != gfc_c_int_kind)
3457             {
3458               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
3459               ts.type = BT_INTEGER;
3460               ts.kind = gfc_c_int_kind;
3461               gfc_convert_type (actual->expr, &ts, 2);
3462             }
3463           gfc_conv_expr_reference (&argse, actual->expr);
3464         }
3465
3466       gfc_add_block_to_block (&se->pre, &argse.pre);
3467       gfc_add_block_to_block (&se->post, &argse.post);
3468       args = gfc_chainon_list (args, argse.expr);
3469     }
3470
3471   /* Convert it to the required type.  */
3472   type = gfc_typenode_for_spec (&expr->ts);
3473   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3474   se->expr = fold_convert (type, se->expr);
3475 }
3476
3477
3478 /* Generate code for TRIM (A) intrinsic function.  */
3479
3480 static void
3481 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3482 {
3483   tree gfc_int4_type_node = gfc_get_int_type (4);
3484   tree var;
3485   tree len;
3486   tree addr;
3487   tree tmp;
3488   tree type;
3489   tree cond;
3490   tree fndecl;
3491   tree *args;
3492   unsigned int num_args;
3493
3494   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3495   args = alloca (sizeof (tree) * num_args);
3496
3497   type = build_pointer_type (gfc_character1_type_node);
3498   var = gfc_create_var (type, "pstr");
3499   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3500   len = gfc_create_var (gfc_int4_type_node, "len");
3501
3502   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3503   args[0] = build_fold_addr_expr (len);
3504   args[1] = addr;
3505
3506   fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3507   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3508                           fndecl, num_args, args);
3509   gfc_add_expr_to_block (&se->pre, tmp);
3510
3511   /* Free the temporary afterwards, if necessary.  */
3512   cond = build2 (GT_EXPR, boolean_type_node, len,
3513                  build_int_cst (TREE_TYPE (len), 0));
3514   tmp = gfc_call_free (var);
3515   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3516   gfc_add_expr_to_block (&se->post, tmp);
3517
3518   se->expr = var;
3519   se->string_length = len;
3520 }
3521
3522
3523 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3524
3525 static void
3526 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3527 {
3528   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3529   tree type, cond, tmp, count, exit_label, n, max, largest;
3530   stmtblock_t block, body;
3531   int i;
3532
3533   /* Get the arguments.  */
3534   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3535   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3536   src = args[1];
3537   ncopies = gfc_evaluate_now (args[2], &se->pre);
3538   ncopies_type = TREE_TYPE (ncopies);
3539
3540   /* Check that NCOPIES is not negative.  */
3541   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3542                       build_int_cst (ncopies_type, 0));
3543   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3544                            "Argument NCOPIES of REPEAT intrinsic is negative "
3545                            "(its value is %lld)",
3546                            fold_convert (long_integer_type_node, ncopies));
3547
3548   /* If the source length is zero, any non negative value of NCOPIES
3549      is valid, and nothing happens.  */
3550   n = gfc_create_var (ncopies_type, "ncopies");
3551   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3552                       build_int_cst (size_type_node, 0));
3553   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3554                      build_int_cst (ncopies_type, 0), ncopies);
3555   gfc_add_modify_expr (&se->pre, n, tmp);
3556   ncopies = n;
3557
3558   /* Check that ncopies is not too large: ncopies should be less than
3559      (or equal to) MAX / slen, where MAX is the maximal integer of
3560      the gfc_charlen_type_node type.  If slen == 0, we need a special
3561      case to avoid the division by zero.  */
3562   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3563   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3564   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3565                      fold_convert (size_type_node, max), slen);
3566   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3567               ? size_type_node : ncopies_type;
3568   cond = fold_build2 (GT_EXPR, boolean_type_node,
3569                       fold_convert (largest, ncopies),
3570                       fold_convert (largest, max));
3571   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3572                      build_int_cst (size_type_node, 0));
3573   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3574                       cond);
3575   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3576                            "Argument NCOPIES of REPEAT intrinsic is too large");
3577
3578
3579   /* Compute the destination length.  */
3580   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3581                       fold_convert (gfc_charlen_type_node, slen),
3582                       fold_convert (gfc_charlen_type_node, ncopies));
3583   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3584   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3585
3586   /* Generate the code to do the repeat operation:
3587        for (i = 0; i < ncopies; i++)
3588          memmove (dest + (i * slen), src, slen);  */
3589   gfc_start_block (&block);
3590   count = gfc_create_var (ncopies_type, "count");
3591   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3592   exit_label = gfc_build_label_decl (NULL_TREE);
3593
3594   /* Start the loop body.  */
3595   gfc_start_block (&body);
3596
3597   /* Exit the loop if count >= ncopies.  */
3598   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3599   tmp = build1_v (GOTO_EXPR, exit_label);
3600   TREE_USED (exit_label) = 1;
3601   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3602                      build_empty_stmt ());
3603   gfc_add_expr_to_block (&body, tmp);
3604
3605   /* Call memmove (dest + (i*slen), src, slen).  */
3606   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3607                      fold_convert (gfc_charlen_type_node, slen),
3608                      fold_convert (gfc_charlen_type_node, count));
3609   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3610                      fold_convert (pchar_type_node, dest),
3611                      fold_convert (sizetype, tmp));
3612   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3613                          tmp, src, slen);
3614   gfc_add_expr_to_block (&body, tmp);
3615
3616   /* Increment count.  */
3617   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3618                 build_int_cst (TREE_TYPE (count), 1));
3619   gfc_add_modify_expr (&body, count, tmp);
3620
3621   /* Build the loop.  */
3622   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3623   gfc_add_expr_to_block (&block, tmp);
3624
3625   /* Add the exit label.  */
3626   tmp = build1_v (LABEL_EXPR, exit_label);
3627   gfc_add_expr_to_block (&block, tmp);
3628
3629   /* Finish the block.  */
3630   tmp = gfc_finish_block (&block);
3631   gfc_add_expr_to_block (&se->pre, tmp);
3632
3633   /* Set the result value.  */
3634   se->expr = dest;
3635   se->string_length = dlen;
3636 }
3637
3638
3639 /* Generate code for the IARGC intrinsic.  */
3640
3641 static void
3642 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3643 {
3644   tree tmp;
3645   tree fndecl;
3646   tree type;
3647
3648   /* Call the library function.  This always returns an INTEGER(4).  */
3649   fndecl = gfor_fndecl_iargc;
3650   tmp = build_call_expr (fndecl, 0);
3651
3652   /* Convert it to the required type.  */
3653   type = gfc_typenode_for_spec (&expr->ts);
3654   tmp = fold_convert (type, tmp);
3655
3656   se->expr = tmp;
3657 }
3658
3659
3660 /* The loc intrinsic returns the address of its argument as
3661    gfc_index_integer_kind integer.  */
3662
3663 static void
3664 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3665 {
3666   tree temp_var;
3667   gfc_expr *arg_expr;
3668   gfc_ss *ss;
3669
3670   gcc_assert (!se->ss);
3671
3672   arg_expr = expr->value.function.actual->expr;
3673   ss = gfc_walk_expr (arg_expr);
3674   if (ss == gfc_ss_terminator)
3675     gfc_conv_expr_reference (se, arg_expr);
3676   else
3677     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3678   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3679
3680   /* Create a temporary variable for loc return value.  Without this,
3681      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3682   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3683   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3684   se->expr = temp_var;
3685 }
3686
3687 /* Generate code for an intrinsic function.  Some map directly to library
3688    calls, others get special handling.  In some cases the name of the function
3689    used depends on the type specifiers.  */
3690
3691 void
3692 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3693 {
3694   gfc_intrinsic_sym *isym;
3695   const char *name;
3696   int lib;
3697
3698   isym = expr->value.function.isym;
3699
3700   name = &expr->value.function.name[2];
3701
3702   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3703     {
3704       lib = gfc_is_intrinsic_libcall (expr);
3705       if (lib != 0)
3706         {
3707           if (lib == 1)
3708             se->ignore_optional = 1;
3709           gfc_conv_intrinsic_funcall (se, expr);
3710           return;
3711         }
3712     }
3713
3714   switch (expr->value.function.isym->id)
3715     {
3716     case GFC_ISYM_NONE:
3717       gcc_unreachable ();
3718
3719     case GFC_ISYM_REPEAT:
3720       gfc_conv_intrinsic_repeat (se, expr);
3721       break;
3722
3723     case GFC_ISYM_TRIM:
3724       gfc_conv_intrinsic_trim (se, expr);
3725       break;
3726
3727     case GFC_ISYM_SI_KIND:
3728       gfc_conv_intrinsic_si_kind (se, expr);
3729       break;
3730
3731     case GFC_ISYM_SR_KIND:
3732       gfc_conv_intrinsic_sr_kind (se, expr);
3733       break;
3734
3735     case GFC_ISYM_EXPONENT:
3736       gfc_conv_intrinsic_exponent (se, expr);
3737       break;
3738
3739     case GFC_ISYM_SCAN:
3740       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
3741       break;
3742
3743     case GFC_ISYM_VERIFY:
3744       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
3745       break;
3746
3747     case GFC_ISYM_ALLOCATED:
3748       gfc_conv_allocated (se, expr);
3749       break;
3750
3751     case GFC_ISYM_ASSOCIATED:
3752       gfc_conv_associated(se, expr);
3753       break;
3754
3755     case GFC_ISYM_ABS:
3756       gfc_conv_intrinsic_abs (se, expr);
3757       break;
3758
3759     case GFC_ISYM_ADJUSTL:
3760       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3761       break;
3762
3763     case GFC_ISYM_ADJUSTR:
3764       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3765       break;
3766
3767     case GFC_ISYM_AIMAG:
3768       gfc_conv_intrinsic_imagpart (se, expr);
3769       break;
3770
3771     case GFC_ISYM_AINT:
3772       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3773       break;
3774
3775     case GFC_ISYM_ALL:
3776       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3777       break;
3778
3779     case GFC_ISYM_ANINT:
3780       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3781       break;
3782
3783     case GFC_ISYM_AND:
3784       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3785       break;
3786
3787     case GFC_ISYM_ANY:
3788       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3789       break;
3790
3791     case GFC_ISYM_BTEST:
3792       gfc_conv_intrinsic_btest (se, expr);
3793       break;
3794
3795     case GFC_ISYM_ACHAR:
3796     case GFC_ISYM_CHAR:
3797       gfc_conv_intrinsic_char (se, expr);
3798       break;
3799
3800     case GFC_ISYM_CONVERSION:
3801     case GFC_ISYM_REAL:
3802     case GFC_ISYM_LOGICAL:
3803     case GFC_ISYM_DBLE:
3804       gfc_conv_intrinsic_conversion (se, expr);
3805       break;
3806
3807       /* Integer conversions are handled separately to make sure we get the
3808          correct rounding mode.  */
3809     case GFC_ISYM_INT:
3810     case GFC_ISYM_INT2:
3811     case GFC_ISYM_INT8:
3812     case GFC_ISYM_LONG:
3813       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3814       break;
3815
3816     case GFC_ISYM_NINT:
3817       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3818       break;
3819
3820     case GFC_ISYM_CEILING:
3821       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3822       break;
3823
3824     case GFC_ISYM_FLOOR:
3825       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3826       break;
3827
3828     case GFC_ISYM_MOD:
3829       gfc_conv_intrinsic_mod (se, expr, 0);
3830       break;
3831
3832     case GFC_ISYM_MODULO:
3833       gfc_conv_intrinsic_mod (se, expr, 1);
3834       break;
3835
3836     case GFC_ISYM_CMPLX:
3837       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3838       break;
3839
3840     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3841       gfc_conv_intrinsic_iargc (se, expr);
3842       break;
3843
3844     case GFC_ISYM_COMPLEX:
3845       gfc_conv_intrinsic_cmplx (se, expr, 1);
3846       break;
3847
3848     case GFC_ISYM_CONJG:
3849       gfc_conv_intrinsic_conjg (se, expr);
3850       break;
3851
3852     case GFC_ISYM_COUNT:
3853       gfc_conv_intrinsic_count (se, expr);
3854       break;
3855
3856     case GFC_ISYM_CTIME:
3857       gfc_conv_intrinsic_ctime (se, expr);
3858       break;
3859
3860     case GFC_ISYM_DIM:
3861       gfc_conv_intrinsic_dim (se, expr);
3862       break;
3863
3864     case GFC_ISYM_DOT_PRODUCT:
3865       gfc_conv_intrinsic_dot_product (se, expr);
3866       break;
3867
3868     case GFC_ISYM_DPROD:
3869       gfc_conv_intrinsic_dprod (se, expr);
3870       break;
3871
3872     case GFC_ISYM_FDATE:
3873       gfc_conv_intrinsic_fdate (se, expr);
3874       break;
3875
3876     case GFC_ISYM_IAND:
3877       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3878       break;
3879
3880     case GFC_ISYM_IBCLR:
3881       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3882       break;
3883
3884     case GFC_ISYM_IBITS:
3885       gfc_conv_intrinsic_ibits (se, expr);
3886       break;
3887
3888     case GFC_ISYM_IBSET:
3889       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3890       break;
3891
3892     case GFC_ISYM_IACHAR:
3893     case GFC_ISYM_ICHAR:
3894       /* We assume ASCII character sequence.  */
3895       gfc_conv_intrinsic_ichar (se, expr);
3896       break;
3897
3898     case GFC_ISYM_IARGC:
3899       gfc_conv_intrinsic_iargc (se, expr);
3900       break;
3901
3902     case GFC_ISYM_IEOR:
3903       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3904       break;
3905
3906     case GFC_ISYM_INDEX:
3907       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
3908       break;
3909
3910     case GFC_ISYM_IOR:
3911       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3912       break;
3913
3914     case GFC_ISYM_ISNAN:
3915       gfc_conv_intrinsic_isnan (se, expr);
3916       break;
3917
3918     case GFC_ISYM_LSHIFT:
3919       gfc_conv_intrinsic_rlshift (se, expr, 0);
3920       break;
3921
3922     case GFC_ISYM_RSHIFT:
3923       gfc_conv_intrinsic_rlshift (se, expr, 1);
3924       break;
3925
3926     case GFC_ISYM_ISHFT:
3927       gfc_conv_intrinsic_ishft (se, expr);
3928       break;
3929
3930     case GFC_ISYM_ISHFTC:
3931       gfc_conv_intrinsic_ishftc (se, expr);
3932       break;
3933
3934     case GFC_ISYM_LBOUND:
3935       gfc_conv_intrinsic_bound (se, expr, 0);
3936       break;
3937
3938     case GFC_ISYM_TRANSPOSE:
3939       if (se->ss && se->ss->useflags)
3940         {
3941           gfc_conv_tmp_array_ref (se);
3942           gfc_advance_se_ss_chain (se);
3943         }
3944       else
3945         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3946       break;
3947
3948     case GFC_ISYM_LEN:
3949       gfc_conv_intrinsic_len (se, expr);
3950       break;
3951
3952     case GFC_ISYM_LEN_TRIM:
3953       gfc_conv_intrinsic_len_trim (se, expr);
3954       break;
3955
3956     case GFC_ISYM_LGE:
3957       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3958       break;
3959
3960     case GFC_ISYM_LGT:
3961       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3962       break;
3963
3964     case GFC_ISYM_LLE:
3965       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3966       break;
3967
3968     case GFC_ISYM_LLT:
3969       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3970       break;
3971
3972     case GFC_ISYM_MAX:
3973       if (expr->ts.type == BT_CHARACTER)
3974         gfc_conv_intrinsic_minmax_char (se, expr, 1);
3975       else
3976         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3977       break;
3978
3979     case GFC_ISYM_MAXLOC:
3980       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3981       break;
3982
3983     case GFC_ISYM_MAXVAL:
3984       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3985       break;
3986
3987     case GFC_ISYM_MERGE:
3988       gfc_conv_intrinsic_merge (se, expr);
3989       break;
3990
3991     case GFC_ISYM_MIN:
3992       if (expr->ts.type == BT_CHARACTER)
3993         gfc_conv_intrinsic_minmax_char (se, expr, -1);
3994       else
3995         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3996       break;
3997
3998     case GFC_ISYM_MINLOC:
3999       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4000       break;
4001
4002     case GFC_ISYM_MINVAL:
4003       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4004       break;
4005
4006     case GFC_ISYM_NOT:
4007       gfc_conv_intrinsic_not (se, expr);
4008       break;
4009
4010     case GFC_ISYM_OR:
4011       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4012       break;
4013
4014     case GFC_ISYM_PRESENT:
4015       gfc_conv_intrinsic_present (se, expr);
4016       break;
4017
4018     case GFC_ISYM_PRODUCT:
4019       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4020       break;
4021
4022     case GFC_ISYM_SIGN:
4023       gfc_conv_intrinsic_sign (se, expr);
4024       break;
4025
4026     case GFC_ISYM_SIZE:
4027       gfc_conv_intrinsic_size (se, expr);
4028       break;
4029
4030     case GFC_ISYM_SIZEOF:
4031       gfc_conv_intrinsic_sizeof (se, expr);
4032       break;
4033
4034     case GFC_ISYM_SUM:
4035       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4036       break;
4037
4038     case GFC_ISYM_TRANSFER:
4039       if (se->ss)
4040         {
4041           if (se->ss->useflags)
4042             {
4043               /* Access the previously obtained result.  */
4044               gfc_conv_tmp_array_ref (se);
4045               gfc_advance_se_ss_chain (se);
4046               break;
4047             }
4048           else
4049             gfc_conv_intrinsic_array_transfer (se, expr);
4050         }
4051       else
4052         gfc_conv_intrinsic_transfer (se, expr);
4053       break;
4054
4055     case GFC_ISYM_TTYNAM:
4056       gfc_conv_intrinsic_ttynam (se, expr);
4057       break;
4058
4059     case GFC_ISYM_UBOUND:
4060       gfc_conv_intrinsic_bound (se, expr, 1);
4061       break;
4062
4063     case GFC_ISYM_XOR:
4064       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4065       break;
4066
4067     case GFC_ISYM_LOC:
4068       gfc_conv_intrinsic_loc (se, expr);
4069       break;
4070
4071     case GFC_ISYM_ACCESS:
4072     case GFC_ISYM_CHDIR:
4073     case GFC_ISYM_CHMOD:
4074     case GFC_ISYM_ETIME:
4075     case GFC_ISYM_FGET:
4076     case GFC_ISYM_FGETC:
4077     case GFC_ISYM_FNUM:
4078     case GFC_ISYM_FPUT:
4079     case GFC_ISYM_FPUTC:
4080     case GFC_ISYM_FSTAT:
4081     case GFC_ISYM_FTELL:
4082     case GFC_ISYM_GETCWD:
4083     case GFC_ISYM_GETGID:
4084     case GFC_ISYM_GETPID:
4085     case GFC_ISYM_GETUID:
4086     case GFC_ISYM_HOSTNM:
4087     case GFC_ISYM_KILL:
4088     case GFC_ISYM_IERRNO:
4089     case GFC_ISYM_IRAND:
4090     case GFC_ISYM_ISATTY:
4091     case GFC_ISYM_LINK:
4092     case GFC_ISYM_LSTAT:
4093     case GFC_ISYM_MALLOC:
4094     case GFC_ISYM_MATMUL:
4095     case GFC_ISYM_MCLOCK:
4096     case GFC_ISYM_MCLOCK8:
4097     case GFC_ISYM_RAND:
4098     case GFC_ISYM_RENAME:
4099     case GFC_ISYM_SECOND:
4100     case GFC_ISYM_SECNDS:
4101     case GFC_ISYM_SIGNAL:
4102     case GFC_ISYM_STAT:
4103     case GFC_ISYM_SYMLNK:
4104     case GFC_ISYM_SYSTEM:
4105     case GFC_ISYM_TIME:
4106     case GFC_ISYM_TIME8:
4107     case GFC_ISYM_UMASK:
4108     case GFC_ISYM_UNLINK:
4109       gfc_conv_intrinsic_funcall (se, expr);
4110       break;
4111
4112     default:
4113       gfc_conv_intrinsic_lib_function (se, expr);
4114       break;
4115     }
4116 }
4117
4118
4119 /* This generates code to execute before entering the scalarization loop.
4120    Currently does nothing.  */
4121
4122 void
4123 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4124 {
4125   switch (ss->expr->value.function.isym->id)
4126     {
4127     case GFC_ISYM_UBOUND:
4128     case GFC_ISYM_LBOUND:
4129       break;
4130
4131     default:
4132       gcc_unreachable ();
4133     }
4134 }
4135
4136
4137 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4138    inside the scalarization loop.  */
4139
4140 static gfc_ss *
4141 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4142 {
4143   gfc_ss *newss;
4144
4145   /* The two argument version returns a scalar.  */
4146   if (expr->value.function.actual->next->expr)
4147     return ss;
4148
4149   newss = gfc_get_ss ();
4150   newss->type = GFC_SS_INTRINSIC;
4151   newss->expr = expr;
4152   newss->next = ss;
4153   newss->data.info.dimen = 1;
4154
4155   return newss;
4156 }
4157
4158
4159 /* Walk an intrinsic array libcall.  */
4160
4161 static gfc_ss *
4162 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4163 {
4164   gfc_ss *newss;
4165
4166   gcc_assert (expr->rank > 0);
4167
4168   newss = gfc_get_ss ();
4169   newss->type = GFC_SS_FUNCTION;
4170   newss->expr = expr;
4171   newss->next = ss;
4172   newss->data.info.dimen = expr->rank;
4173
4174   return newss;
4175 }
4176
4177
4178 /* Returns nonzero if the specified intrinsic function call maps directly to a
4179    an external library call.  Should only be used for functions that return
4180    arrays.  */
4181
4182 int
4183 gfc_is_intrinsic_libcall (gfc_expr * expr)
4184 {
4185   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4186   gcc_assert (expr->rank > 0);
4187
4188   switch (expr->value.function.isym->id)
4189     {
4190     case GFC_ISYM_ALL:
4191     case GFC_ISYM_ANY:
4192     case GFC_ISYM_COUNT:
4193     case GFC_ISYM_MATMUL:
4194     case GFC_ISYM_MAXLOC:
4195     case GFC_ISYM_MAXVAL:
4196     case GFC_ISYM_MINLOC:
4197     case GFC_ISYM_MINVAL:
4198     case GFC_ISYM_PRODUCT:
4199     case GFC_ISYM_SUM:
4200     case GFC_ISYM_SHAPE:
4201     case GFC_ISYM_SPREAD:
4202     case GFC_ISYM_TRANSPOSE:
4203       /* Ignore absent optional parameters.  */
4204       return 1;
4205
4206     case GFC_ISYM_RESHAPE:
4207     case GFC_ISYM_CSHIFT:
4208     case GFC_ISYM_EOSHIFT:
4209     case GFC_ISYM_PACK:
4210     case GFC_ISYM_UNPACK:
4211       /* Pass absent optional parameters.  */
4212       return 2;
4213
4214     default:
4215       return 0;
4216     }
4217 }
4218
4219 /* Walk an intrinsic function.  */
4220 gfc_ss *
4221 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4222                              gfc_intrinsic_sym * isym)
4223 {
4224   gcc_assert (isym);
4225
4226   if (isym->elemental)
4227     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4228
4229   if (expr->rank == 0)
4230     return ss;
4231
4232   if (gfc_is_intrinsic_libcall (expr))
4233     return gfc_walk_intrinsic_libfunc (ss, expr);
4234
4235   /* Special cases.  */
4236   switch (isym->id)
4237     {
4238     case GFC_ISYM_LBOUND:
4239     case GFC_ISYM_UBOUND:
4240       return gfc_walk_intrinsic_bound (ss, expr);
4241
4242     case GFC_ISYM_TRANSFER:
4243       return gfc_walk_intrinsic_libfunc (ss, expr);
4244
4245     default:
4246       /* This probably meant someone forgot to add an intrinsic to the above
4247          list(s) when they implemented it, or something's gone horribly wrong.
4248        */
4249       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4250                       expr->value.function.name);
4251     }
4252 }
4253
4254 #include "gt-fortran-trans-intrinsic.h"