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