gcc/fortran/trans-intrinsic.c

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