gcc/fortran/trans-intrinsic.c

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