gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 2, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING.  If not, write to the Free
  21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  22 02110-1301, USA.  */
  23
  24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  25
  26 #include "config.h"
  27 #include "system.h"
  28 #include "coretypes.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "tree-gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct gfc_intrinsic_map_t      GTY(())
  49 {
  50   /* The explicit enum is required to work around inadequacies in the
  51      garbage collection/gengtype parsing mechanism.  */
  52   enum gfc_isym_id id;
  53
  54   /* Enum value from the "language-independent", aka C-centric, part
  55      of gcc, or END_BUILTINS of no such value set.  */
  56   enum built_in_function code_r4;
  57   enum built_in_function code_r8;
  58   enum built_in_function code_r10;
  59   enum built_in_function code_r16;
  60   enum built_in_function code_c4;
  61   enum built_in_function code_c8;
  62   enum built_in_function code_c10;
  63   enum built_in_function code_c16;
  64
  65   /* True if the naming pattern is to prepend "c" for complex and
  66      append "f" for kind=4.  False if the naming pattern is to
  67      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  68   bool libm_name;
  69
  70   /* True if a complex version of the function exists.  */
  71   bool complex_available;
  72
  73   /* True if the function should be marked const.  */
  74   bool is_constant;
  75
  76   /* The base library name of this function.  */
  77   const char *name;
  78
  79   /* Cache decls created for the various operand types.  */
  80   tree real4_decl;
  81   tree real8_decl;
  82   tree real10_decl;
  83   tree real16_decl;
  84   tree complex4_decl;
  85   tree complex8_decl;
  86   tree complex10_decl;
  87   tree complex16_decl;
  88 }
  89 gfc_intrinsic_map_t;
  90
  91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  92    defines complex variants of all of the entries in mathbuiltins.def
  93    except for atan2.  */
  94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  95   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  96     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  97     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  99
 100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 106
 107 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 112
 113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 114   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 115     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 116     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 117     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 118
 119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 120 {
 121   /* Functions built into gcc itself.  */
 122 #include "mathbuiltins.def"
 123
 124   /* Functions in libm.  */
 125   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 126      pattern for other mathbuiltins.def entries.  At present we have no
 127      optimizations for this in the common sources.  */
 128   LIBM_FUNCTION (SCALE, "scalbn", false),
 129
 130   /* Functions in libgfortran.  */
 131   LIBF_FUNCTION (FRACTION, "fraction", false),
 132   LIBF_FUNCTION (NEAREST, "nearest", false),
 133   LIBF_FUNCTION (RRSPACING, "rrspacing", false),
 134   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 135   LIBF_FUNCTION (SPACING, "spacing", false),
 136
 137   /* End the list.  */
 138   LIBF_FUNCTION (NONE, NULL, false)
 139 };
 140 #undef DEFINE_MATH_BUILTIN
 141 #undef DEFINE_MATH_BUILTIN_C
 142 #undef LIBM_FUNCTION
 143 #undef LIBF_FUNCTION
 144
 145 /* Structure for storing components of a floating number to be used by
 146    elemental functions to manipulate reals.  */
 147 typedef struct
 148 {
 149   tree arg;     /* Variable tree to view convert to integer.  */
 150   tree expn;    /* Variable tree to save exponent.  */
 151   tree frac;    /* Variable tree to save fraction.  */
 152   tree smask;   /* Constant tree of sign's mask.  */
 153   tree emask;   /* Constant tree of exponent's mask.  */
 154   tree fmask;   /* Constant tree of fraction's mask.  */
 155   tree edigits; /* Constant tree of the number of exponent bits.  */
 156   tree fdigits; /* Constant tree of the number of fraction bits.  */
 157   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 158   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 159   tree type;    /* Type tree of arg1.  */
 160   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 161 }
 162 real_compnt_info;
 163
 164 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 165
 166 /* Evaluate the arguments to an intrinsic function.  */
 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_isym_id id;
 653
 654   id = expr->value.function.isym->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->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   tree offset;
1932   gfc_loopinfo loop;
1933   gfc_actual_arglist *actual;
1934   gfc_ss *arrayss;
1935   gfc_ss *maskss;
1936   gfc_se arrayse;
1937   gfc_se maskse;
1938   gfc_expr *arrayexpr;
1939   gfc_expr *maskexpr;
1940   tree pos;
1941   int n;
1942
1943   if (se->ss)
1944     {
1945       gfc_conv_intrinsic_funcall (se, expr);
1946       return;
1947     }
1948
1949   /* Initialize the result.  */
1950   pos = gfc_create_var (gfc_array_index_type, "pos");
1951   offset = gfc_create_var (gfc_array_index_type, "offset");
1952   type = gfc_typenode_for_spec (&expr->ts);
1953
1954   /* Walk the arguments.  */
1955   actual = expr->value.function.actual;
1956   arrayexpr = actual->expr;
1957   arrayss = gfc_walk_expr (arrayexpr);
1958   gcc_assert (arrayss != gfc_ss_terminator);
1959
1960   actual = actual->next->next;
1961   gcc_assert (actual);
1962   maskexpr = actual->expr;
1963   if (maskexpr && maskexpr->rank != 0)
1964     {
1965       maskss = gfc_walk_expr (maskexpr);
1966       gcc_assert (maskss != gfc_ss_terminator);
1967     }
1968   else
1969     maskss = NULL;
1970
1971   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1972   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1973   switch (arrayexpr->ts.type)
1974     {
1975     case BT_REAL:
1976       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1977       break;
1978
1979     case BT_INTEGER:
1980       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1981                                   arrayexpr->ts.kind);
1982       break;
1983
1984     default:
1985       gcc_unreachable ();
1986     }
1987
1988   /* We start with the most negative possible value for MAXLOC, and the most
1989      positive possible value for MINLOC. The most negative possible value is
1990      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
1991      possible value is HUGE in both cases.  */
1992   if (op == GT_EXPR)
1993     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1994   gfc_add_modify_expr (&se->pre, limit, tmp);
1995
1996   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
1997     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
1998                   build_int_cst (type, 1));
1999
2000   /* Initialize the scalarizer.  */
2001   gfc_init_loopinfo (&loop);
2002   gfc_add_ss_to_loop (&loop, arrayss);
2003   if (maskss)
2004     gfc_add_ss_to_loop (&loop, maskss);
2005
2006   /* Initialize the loop.  */
2007   gfc_conv_ss_startstride (&loop);
2008   gfc_conv_loop_setup (&loop);
2009
2010   gcc_assert (loop.dimen == 1);
2011
2012   /* Initialize the position to zero, following Fortran 2003.  We are free
2013      to do this because Fortran 95 allows the result of an entirely false
2014      mask to be processor dependent.  */
2015   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2016
2017   gfc_mark_ss_chain_used (arrayss, 1);
2018   if (maskss)
2019     gfc_mark_ss_chain_used (maskss, 1);
2020   /* Generate the loop body.  */
2021   gfc_start_scalarized_body (&loop, &body);
2022
2023   /* If we have a mask, only check this element if the mask is set.  */
2024   if (maskss)
2025     {
2026       gfc_init_se (&maskse, NULL);
2027       gfc_copy_loopinfo_to_se (&maskse, &loop);
2028       maskse.ss = maskss;
2029       gfc_conv_expr_val (&maskse, maskexpr);
2030       gfc_add_block_to_block (&body, &maskse.pre);
2031
2032       gfc_start_block (&block);
2033     }
2034   else
2035     gfc_init_block (&block);
2036
2037   /* Compare with the current limit.  */
2038   gfc_init_se (&arrayse, NULL);
2039   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2040   arrayse.ss = arrayss;
2041   gfc_conv_expr_val (&arrayse, arrayexpr);
2042   gfc_add_block_to_block (&block, &arrayse.pre);
2043
2044   /* We do the following if this is a more extreme value.  */
2045   gfc_start_block (&ifblock);
2046
2047   /* Assign the value to the limit...  */
2048   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2049
2050   /* Remember where we are.  An offset must be added to the loop
2051      counter to obtain the required position.  */
2052   if (loop.temp_dim)
2053     tmp = build_int_cst (gfc_array_index_type, 1);
2054   else
2055     tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2056                          gfc_index_one_node, loop.from[0]);
2057   gfc_add_modify_expr (&block, offset, tmp);
2058
2059   tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2060                 loop.loopvar[0], offset);
2061   gfc_add_modify_expr (&ifblock, pos, tmp);
2062
2063   ifbody = gfc_finish_block (&ifblock);
2064
2065   /* If it is a more extreme value or pos is still zero and the value
2066      equal to the limit.  */
2067   tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2068                 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2069                 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2070   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2071                 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2072   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2073   gfc_add_expr_to_block (&block, tmp);
2074
2075   if (maskss)
2076     {
2077       /* We enclose the above in if (mask) {...}.  */
2078       tmp = gfc_finish_block (&block);
2079
2080       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2081     }
2082   else
2083     tmp = gfc_finish_block (&block);
2084   gfc_add_expr_to_block (&body, tmp);
2085
2086   gfc_trans_scalarizing_loops (&loop, &body);
2087
2088   /* For a scalar mask, enclose the loop in an if statement.  */
2089   if (maskexpr && maskss == NULL)
2090     {
2091       gfc_init_se (&maskse, NULL);
2092       gfc_conv_expr_val (&maskse, maskexpr);
2093       gfc_init_block (&block);
2094       gfc_add_block_to_block (&block, &loop.pre);
2095       gfc_add_block_to_block (&block, &loop.post);
2096       tmp = gfc_finish_block (&block);
2097
2098       /* For the else part of the scalar mask, just initialize
2099          the pos variable the same way as above.  */
2100
2101       gfc_init_block (&elseblock);
2102       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2103       elsetmp = gfc_finish_block (&elseblock);
2104
2105       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2106       gfc_add_expr_to_block (&block, tmp);
2107       gfc_add_block_to_block (&se->pre, &block);
2108     }
2109   else
2110     {
2111       gfc_add_block_to_block (&se->pre, &loop.pre);
2112       gfc_add_block_to_block (&se->pre, &loop.post);
2113     }
2114   gfc_cleanup_loop (&loop);
2115
2116   se->expr = convert (type, pos);
2117 }
2118
2119 static void
2120 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2121 {
2122   tree limit;
2123   tree type;
2124   tree tmp;
2125   tree ifbody;
2126   stmtblock_t body;
2127   stmtblock_t block;
2128   gfc_loopinfo loop;
2129   gfc_actual_arglist *actual;
2130   gfc_ss *arrayss;
2131   gfc_ss *maskss;
2132   gfc_se arrayse;
2133   gfc_se maskse;
2134   gfc_expr *arrayexpr;
2135   gfc_expr *maskexpr;
2136   int n;
2137
2138   if (se->ss)
2139     {
2140       gfc_conv_intrinsic_funcall (se, expr);
2141       return;
2142     }
2143
2144   type = gfc_typenode_for_spec (&expr->ts);
2145   /* Initialize the result.  */
2146   limit = gfc_create_var (type, "limit");
2147   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2148   switch (expr->ts.type)
2149     {
2150     case BT_REAL:
2151       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2152       break;
2153
2154     case BT_INTEGER:
2155       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2156       break;
2157
2158     default:
2159       gcc_unreachable ();
2160     }
2161
2162   /* We start with the most negative possible value for MAXVAL, and the most
2163      positive possible value for MINVAL. The most negative possible value is
2164      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2165      possible value is HUGE in both cases.  */
2166   if (op == GT_EXPR)
2167     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2168
2169   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2170     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2171                   build_int_cst (type, 1));
2172
2173   gfc_add_modify_expr (&se->pre, limit, tmp);
2174
2175   /* Walk the arguments.  */
2176   actual = expr->value.function.actual;
2177   arrayexpr = actual->expr;
2178   arrayss = gfc_walk_expr (arrayexpr);
2179   gcc_assert (arrayss != gfc_ss_terminator);
2180
2181   actual = actual->next->next;
2182   gcc_assert (actual);
2183   maskexpr = actual->expr;
2184   if (maskexpr && maskexpr->rank != 0)
2185     {
2186       maskss = gfc_walk_expr (maskexpr);
2187       gcc_assert (maskss != gfc_ss_terminator);
2188     }
2189   else
2190     maskss = NULL;
2191
2192   /* Initialize the scalarizer.  */
2193   gfc_init_loopinfo (&loop);
2194   gfc_add_ss_to_loop (&loop, arrayss);
2195   if (maskss)
2196     gfc_add_ss_to_loop (&loop, maskss);
2197
2198   /* Initialize the loop.  */
2199   gfc_conv_ss_startstride (&loop);
2200   gfc_conv_loop_setup (&loop);
2201
2202   gfc_mark_ss_chain_used (arrayss, 1);
2203   if (maskss)
2204     gfc_mark_ss_chain_used (maskss, 1);
2205   /* Generate the loop body.  */
2206   gfc_start_scalarized_body (&loop, &body);
2207
2208   /* If we have a mask, only add this element if the mask is set.  */
2209   if (maskss)
2210     {
2211       gfc_init_se (&maskse, NULL);
2212       gfc_copy_loopinfo_to_se (&maskse, &loop);
2213       maskse.ss = maskss;
2214       gfc_conv_expr_val (&maskse, maskexpr);
2215       gfc_add_block_to_block (&body, &maskse.pre);
2216
2217       gfc_start_block (&block);
2218     }
2219   else
2220     gfc_init_block (&block);
2221
2222   /* Compare with the current limit.  */
2223   gfc_init_se (&arrayse, NULL);
2224   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2225   arrayse.ss = arrayss;
2226   gfc_conv_expr_val (&arrayse, arrayexpr);
2227   gfc_add_block_to_block (&block, &arrayse.pre);
2228
2229   /* Assign the value to the limit...  */
2230   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2231
2232   /* If it is a more extreme value.  */
2233   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2234   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2235   gfc_add_expr_to_block (&block, tmp);
2236   gfc_add_block_to_block (&block, &arrayse.post);
2237
2238   tmp = gfc_finish_block (&block);
2239   if (maskss)
2240     /* We enclose the above in if (mask) {...}.  */
2241     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2242   gfc_add_expr_to_block (&body, tmp);
2243
2244   gfc_trans_scalarizing_loops (&loop, &body);
2245
2246   /* For a scalar mask, enclose the loop in an if statement.  */
2247   if (maskexpr && maskss == NULL)
2248     {
2249       gfc_init_se (&maskse, NULL);
2250       gfc_conv_expr_val (&maskse, maskexpr);
2251       gfc_init_block (&block);
2252       gfc_add_block_to_block (&block, &loop.pre);
2253       gfc_add_block_to_block (&block, &loop.post);
2254       tmp = gfc_finish_block (&block);
2255
2256       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2257       gfc_add_expr_to_block (&block, tmp);
2258       gfc_add_block_to_block (&se->pre, &block);
2259     }
2260   else
2261     {
2262       gfc_add_block_to_block (&se->pre, &loop.pre);
2263       gfc_add_block_to_block (&se->pre, &loop.post);
2264     }
2265
2266   gfc_cleanup_loop (&loop);
2267
2268   se->expr = limit;
2269 }
2270
2271 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2272 static void
2273 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2274 {
2275   tree arg;
2276   tree arg2;
2277   tree type;
2278   tree tmp;
2279
2280   arg = gfc_conv_intrinsic_function_args (se, expr);
2281   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2282   arg = TREE_VALUE (arg);
2283   type = TREE_TYPE (arg);
2284
2285   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2286   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
2287   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2288                      build_int_cst (type, 0));
2289   type = gfc_typenode_for_spec (&expr->ts);
2290   se->expr = convert (type, tmp);
2291 }
2292
2293 /* Generate code to perform the specified operation.  */
2294 static void
2295 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2296 {
2297   tree arg;
2298   tree arg2;
2299   tree type;
2300
2301   arg = gfc_conv_intrinsic_function_args (se, expr);
2302   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2303   arg = TREE_VALUE (arg);
2304   type = TREE_TYPE (arg);
2305
2306   se->expr = fold_build2 (op, type, arg, arg2);
2307 }
2308
2309 /* Bitwise not.  */
2310 static void
2311 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2312 {
2313   tree arg;
2314
2315   arg = gfc_conv_intrinsic_function_args (se, expr);
2316   arg = TREE_VALUE (arg);
2317
2318   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2319 }
2320
2321 /* Set or clear a single bit.  */
2322 static void
2323 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2324 {
2325   tree arg;
2326   tree arg2;
2327   tree type;
2328   tree tmp;
2329   int op;
2330
2331   arg = gfc_conv_intrinsic_function_args (se, expr);
2332   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2333   arg = TREE_VALUE (arg);
2334   type = TREE_TYPE (arg);
2335
2336   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2337   if (set)
2338     op = BIT_IOR_EXPR;
2339   else
2340     {
2341       op = BIT_AND_EXPR;
2342       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2343     }
2344   se->expr = fold_build2 (op, type, arg, tmp);
2345 }
2346
2347 /* Extract a sequence of bits.
2348     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2349 static void
2350 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2351 {
2352   tree arg;
2353   tree arg2;
2354   tree arg3;
2355   tree type;
2356   tree tmp;
2357   tree mask;
2358
2359   arg = gfc_conv_intrinsic_function_args (se, expr);
2360   arg2 = TREE_CHAIN (arg);
2361   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
2362   arg = TREE_VALUE (arg);
2363   arg2 = TREE_VALUE (arg2);
2364   type = TREE_TYPE (arg);
2365
2366   mask = build_int_cst (type, -1);
2367   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
2368   mask = build1 (BIT_NOT_EXPR, type, mask);
2369
2370   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
2371
2372   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2373 }
2374
2375 /* RSHIFT (I, SHIFT) = I >> SHIFT
2376    LSHIFT (I, SHIFT) = I << SHIFT  */
2377 static void
2378 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2379 {
2380   tree arg;
2381   tree arg2;
2382
2383   arg = gfc_conv_intrinsic_function_args (se, expr);
2384   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2385   arg = TREE_VALUE (arg);
2386
2387   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2388                           TREE_TYPE (arg), arg, arg2);
2389 }
2390
2391 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2392                         ? 0
2393                         : ((shift >= 0) ? i << shift : i >> -shift)
2394    where all shifts are logical shifts.  */
2395 static void
2396 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2397 {
2398   tree arg;
2399   tree arg2;
2400   tree type;
2401   tree utype;
2402   tree tmp;
2403   tree width;
2404   tree num_bits;
2405   tree cond;
2406   tree lshift;
2407   tree rshift;
2408
2409   arg = gfc_conv_intrinsic_function_args (se, expr);
2410   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2411   arg = TREE_VALUE (arg);
2412   type = TREE_TYPE (arg);
2413   utype = unsigned_type_for (type);
2414
2415   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2416
2417   /* Left shift if positive.  */
2418   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2419
2420   /* Right shift if negative.
2421      We convert to an unsigned type because we want a logical shift.
2422      The standard doesn't define the case of shifting negative
2423      numbers, and we try to be compatible with other compilers, most
2424      notably g77, here.  */
2425   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2426                                        convert (utype, arg), width));
2427
2428   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2429                      build_int_cst (TREE_TYPE (arg2), 0));
2430   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2431
2432   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2433      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2434      special case.  */
2435   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2436   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2437
2438   se->expr = fold_build3 (COND_EXPR, type, cond,
2439                           build_int_cst (type, 0), tmp);
2440 }
2441
2442 /* Circular shift.  AKA rotate or barrel shift.  */
2443 static void
2444 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2445 {
2446   tree arg;
2447   tree arg2;
2448   tree arg3;
2449   tree type;
2450   tree tmp;
2451   tree lrot;
2452   tree rrot;
2453   tree zero;
2454
2455   arg = gfc_conv_intrinsic_function_args (se, expr);
2456   arg2 = TREE_CHAIN (arg);
2457   arg3 = TREE_CHAIN (arg2);
2458   if (arg3)
2459     {
2460       /* Use a library function for the 3 parameter version.  */
2461       tree int4type = gfc_get_int_type (4);
2462
2463       type = TREE_TYPE (TREE_VALUE (arg));
2464       /* We convert the first argument to at least 4 bytes, and
2465          convert back afterwards.  This removes the need for library
2466          functions for all argument sizes, and function will be
2467          aligned to at least 32 bits, so there's no loss.  */
2468       if (expr->ts.kind < 4)
2469         {
2470           tmp = convert (int4type, TREE_VALUE (arg));
2471           TREE_VALUE (arg) = tmp;
2472         }
2473       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2474          need loads of library  functions.  They cannot have values >
2475          BIT_SIZE (I) so the conversion is safe.  */
2476       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2477       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2478
2479       switch (expr->ts.kind)
2480         {
2481         case 1:
2482         case 2:
2483         case 4:
2484           tmp = gfor_fndecl_math_ishftc4;
2485           break;
2486         case 8:
2487           tmp = gfor_fndecl_math_ishftc8;
2488           break;
2489         case 16:
2490           tmp = gfor_fndecl_math_ishftc16;
2491           break;
2492         default:
2493           gcc_unreachable ();
2494         }
2495       se->expr = build_function_call_expr (tmp, arg);
2496       /* Convert the result back to the original type, if we extended
2497          the first argument's width above.  */
2498       if (expr->ts.kind < 4)
2499         se->expr = convert (type, se->expr);
2500
2501       return;
2502     }
2503   arg = TREE_VALUE (arg);
2504   arg2 = TREE_VALUE (arg2);
2505   type = TREE_TYPE (arg);
2506
2507   /* Rotate left if positive.  */
2508   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2509
2510   /* Rotate right if negative.  */
2511   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2512   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2513
2514   zero = build_int_cst (TREE_TYPE (arg2), 0);
2515   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2516   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2517
2518   /* Do nothing if shift == 0.  */
2519   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2520   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2521 }
2522
2523 /* The length of a character string.  */
2524 static void
2525 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2526 {
2527   tree len;
2528   tree type;
2529   tree decl;
2530   gfc_symbol *sym;
2531   gfc_se argse;
2532   gfc_expr *arg;
2533   gfc_ss *ss;
2534
2535   gcc_assert (!se->ss);
2536
2537   arg = expr->value.function.actual->expr;
2538
2539   type = gfc_typenode_for_spec (&expr->ts);
2540   switch (arg->expr_type)
2541     {
2542     case EXPR_CONSTANT:
2543       len = build_int_cst (NULL_TREE, arg->value.character.length);
2544       break;
2545
2546     case EXPR_ARRAY:
2547       /* Obtain the string length from the function used by
2548          trans-array.c(gfc_trans_array_constructor).  */
2549       len = NULL_TREE;
2550       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2551       break;
2552
2553     case EXPR_VARIABLE:
2554       if (arg->ref == NULL
2555             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2556         {
2557           /* This doesn't catch all cases.
2558              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2559              and the surrounding thread.  */
2560           sym = arg->symtree->n.sym;
2561           decl = gfc_get_symbol_decl (sym);
2562           if (decl == current_function_decl && sym->attr.function
2563                 && (sym->result == sym))
2564             decl = gfc_get_fake_result_decl (sym, 0);
2565
2566           len = sym->ts.cl->backend_decl;
2567           gcc_assert (len);
2568           break;
2569         }
2570
2571       /* Otherwise fall through.  */
2572
2573     default:
2574       /* Anybody stupid enough to do this deserves inefficient code.  */
2575       ss = gfc_walk_expr (arg);
2576       gfc_init_se (&argse, se);
2577       if (ss == gfc_ss_terminator)
2578         gfc_conv_expr (&argse, arg);
2579       else
2580         gfc_conv_expr_descriptor (&argse, arg, ss);
2581       gfc_add_block_to_block (&se->pre, &argse.pre);
2582       gfc_add_block_to_block (&se->post, &argse.post);
2583       len = argse.string_length;
2584       break;
2585     }
2586   se->expr = convert (type, len);
2587 }
2588
2589 /* The length of a character string not including trailing blanks.  */
2590 static void
2591 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2592 {
2593   tree args;
2594   tree type;
2595
2596   args = gfc_conv_intrinsic_function_args (se, expr);
2597   type = gfc_typenode_for_spec (&expr->ts);
2598   se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2599   se->expr = convert (type, se->expr);
2600 }
2601
2602
2603 /* Returns the starting position of a substring within a string.  */
2604
2605 static void
2606 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2607 {
2608   tree logical4_type_node = gfc_get_logical_type (4);
2609   tree args;
2610   tree back;
2611   tree type;
2612   tree tmp;
2613
2614   args = gfc_conv_intrinsic_function_args (se, expr);
2615   type = gfc_typenode_for_spec (&expr->ts);
2616   tmp = gfc_advance_chain (args, 3);
2617   if (TREE_CHAIN (tmp) == NULL_TREE)
2618     {
2619       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2620                         NULL_TREE);
2621       TREE_CHAIN (tmp) = back;
2622     }
2623   else
2624     {
2625       back = TREE_CHAIN (tmp);
2626       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2627     }
2628
2629   se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2630   se->expr = convert (type, se->expr);
2631 }
2632
2633 /* The ascii value for a single character.  */
2634 static void
2635 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2636 {
2637   tree arg;
2638   tree type;
2639
2640   arg = gfc_conv_intrinsic_function_args (se, expr);
2641   arg = TREE_VALUE (TREE_CHAIN (arg));
2642   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2643   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2644   type = gfc_typenode_for_spec (&expr->ts);
2645
2646   se->expr = build_fold_indirect_ref (arg);
2647   se->expr = convert (type, se->expr);
2648 }
2649
2650
2651 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2652
2653 static void
2654 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2655 {
2656   tree arg;
2657   tree tsource;
2658   tree fsource;
2659   tree mask;
2660   tree type;
2661   tree len;
2662
2663   arg = gfc_conv_intrinsic_function_args (se, expr);
2664   if (expr->ts.type != BT_CHARACTER)
2665     {
2666       tsource = TREE_VALUE (arg);
2667       arg = TREE_CHAIN (arg);
2668       fsource = TREE_VALUE (arg);
2669       mask = TREE_VALUE (TREE_CHAIN (arg));
2670     }
2671   else
2672     {
2673       /* We do the same as in the non-character case, but the argument
2674          list is different because of the string length arguments. We
2675          also have to set the string length for the result.  */
2676       len = TREE_VALUE (arg);
2677       arg = TREE_CHAIN (arg);
2678       tsource = TREE_VALUE (arg);
2679       arg = TREE_CHAIN (TREE_CHAIN (arg));
2680       fsource = TREE_VALUE (arg);
2681       mask = TREE_VALUE (TREE_CHAIN (arg));
2682
2683       se->string_length = len;
2684     }
2685   type = TREE_TYPE (tsource);
2686   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2687 }
2688
2689
2690 static void
2691 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2692 {
2693   gfc_actual_arglist *actual;
2694   tree arg1;
2695   tree type;
2696   tree fncall0;
2697   tree fncall1;
2698   gfc_se argse;
2699   gfc_ss *ss;
2700
2701   gfc_init_se (&argse, NULL);
2702   actual = expr->value.function.actual;
2703
2704   ss = gfc_walk_expr (actual->expr);
2705   gcc_assert (ss != gfc_ss_terminator);
2706   argse.want_pointer = 1;
2707   argse.data_not_needed = 1;
2708   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2709   gfc_add_block_to_block (&se->pre, &argse.pre);
2710   gfc_add_block_to_block (&se->post, &argse.post);
2711   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2712
2713   /* Build the call to size0.  */
2714   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2715
2716   actual = actual->next;
2717
2718   if (actual->expr)
2719     {
2720       gfc_init_se (&argse, NULL);
2721       gfc_conv_expr_type (&argse, actual->expr,
2722                           gfc_array_index_type);
2723       gfc_add_block_to_block (&se->pre, &argse.pre);
2724
2725       /* Build the call to size1.  */
2726       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2727                                  arg1, argse.expr);
2728
2729       /* Unusually, for an intrinsic, size does not exclude
2730          an optional arg2, so we must test for it.  */
2731       if (actual->expr->expr_type == EXPR_VARIABLE
2732             && actual->expr->symtree->n.sym->attr.dummy
2733             && actual->expr->symtree->n.sym->attr.optional)
2734         {
2735           tree tmp;
2736           gfc_init_se (&argse, NULL);
2737           argse.want_pointer = 1;
2738           argse.data_not_needed = 1;
2739           gfc_conv_expr (&argse, actual->expr);
2740           gfc_add_block_to_block (&se->pre, &argse.pre);
2741           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2742                         null_pointer_node);
2743           tmp = gfc_evaluate_now (tmp, &se->pre);
2744           se->expr = build3 (COND_EXPR, pvoid_type_node,
2745                              tmp, fncall1, fncall0);
2746         }
2747       else
2748         se->expr = fncall1;
2749     }
2750   else
2751     se->expr = fncall0;
2752
2753   type = gfc_typenode_for_spec (&expr->ts);
2754   se->expr = convert (type, se->expr);
2755 }
2756
2757
2758 static void
2759 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2760 {
2761   gfc_expr *arg;
2762   gfc_ss *ss;
2763   gfc_se argse;
2764   tree source;
2765   tree source_bytes;
2766   tree type;
2767   tree tmp;
2768   tree lower;
2769   tree upper;
2770   /*tree stride;*/
2771   int n;
2772
2773   arg = expr->value.function.actual->expr;
2774
2775   gfc_init_se (&argse, NULL);
2776   ss = gfc_walk_expr (arg);
2777
2778   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2779
2780   if (ss == gfc_ss_terminator)
2781     {
2782       gfc_conv_expr_reference (&argse, arg);
2783       source = argse.expr;
2784
2785       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2786
2787       /* Obtain the source word length.  */
2788       if (arg->ts.type == BT_CHARACTER)
2789         source_bytes = fold_convert (gfc_array_index_type,
2790                                      argse.string_length);
2791       else
2792         source_bytes = fold_convert (gfc_array_index_type,
2793                                      size_in_bytes (type));
2794     }
2795   else
2796     {
2797       argse.want_pointer = 0;
2798       gfc_conv_expr_descriptor (&argse, arg, ss);
2799       source = gfc_conv_descriptor_data_get (argse.expr);
2800       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2801
2802       /* Obtain the argument's word length.  */
2803       if (arg->ts.type == BT_CHARACTER)
2804         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2805       else
2806         tmp = fold_convert (gfc_array_index_type,
2807                             size_in_bytes (type));
2808       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2809
2810       /* Obtain the size of the array in bytes.  */
2811       for (n = 0; n < arg->rank; n++)
2812         {
2813           tree idx;
2814           idx = gfc_rank_cst[n];
2815           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2816           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2817           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2818                              upper, lower);
2819           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2820                              tmp, gfc_index_one_node);
2821           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2822                              tmp, source_bytes);
2823           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2824         }
2825     }
2826
2827   gfc_add_block_to_block (&se->pre, &argse.pre);
2828   se->expr = source_bytes;
2829 }
2830
2831
2832 /* Intrinsic string comparison functions.  */
2833
2834 static void
2835 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2836 {
2837   tree type;
2838   tree args;
2839   tree arg2;
2840
2841   args = gfc_conv_intrinsic_function_args (se, expr);
2842   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2843
2844   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2845                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2846                 TREE_VALUE (TREE_CHAIN (arg2)));
2847
2848   type = gfc_typenode_for_spec (&expr->ts);
2849   se->expr = fold_build2 (op, type, se->expr,
2850                      build_int_cst (TREE_TYPE (se->expr), 0));
2851 }
2852
2853 /* Generate a call to the adjustl/adjustr library function.  */
2854 static void
2855 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2856 {
2857   tree args;
2858   tree len;
2859   tree type;
2860   tree var;
2861   tree tmp;
2862
2863   args = gfc_conv_intrinsic_function_args (se, expr);
2864   len = TREE_VALUE (args);
2865
2866   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2867   var = gfc_conv_string_tmp (se, type, len);
2868   args = tree_cons (NULL_TREE, var, args);
2869
2870   tmp = build_function_call_expr (fndecl, args);
2871   gfc_add_expr_to_block (&se->pre, tmp);
2872   se->expr = var;
2873   se->string_length = len;
2874 }
2875
2876
2877 /* Array transfer statement.
2878      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2879    where:
2880      typeof<DEST> = typeof<MOLD>
2881    and:
2882      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2883               sizeof (DEST(0) * SIZE).  */
2884
2885 static void
2886 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2887 {
2888   tree tmp;
2889   tree extent;
2890   tree source;
2891   tree source_type;
2892   tree source_bytes;
2893   tree mold_type;
2894   tree dest_word_len;
2895   tree size_words;
2896   tree size_bytes;
2897   tree upper;
2898   tree lower;
2899   tree stride;
2900   tree stmt;
2901   gfc_actual_arglist *arg;
2902   gfc_se argse;
2903   gfc_ss *ss;
2904   gfc_ss_info *info;
2905   stmtblock_t block;
2906   int n;
2907
2908   gcc_assert (se->loop);
2909   info = &se->ss->data.info;
2910
2911   /* Convert SOURCE.  The output from this stage is:-
2912         source_bytes = length of the source in bytes
2913         source = pointer to the source data.  */
2914   arg = expr->value.function.actual;
2915   gfc_init_se (&argse, NULL);
2916   ss = gfc_walk_expr (arg->expr);
2917
2918   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
2919
2920   /* Obtain the pointer to source and the length of source in bytes.  */
2921   if (ss == gfc_ss_terminator)
2922     {
2923       gfc_conv_expr_reference (&argse, arg->expr);
2924       source = argse.expr;
2925
2926       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2927
2928       /* Obtain the source word length.  */
2929       if (arg->expr->ts.type == BT_CHARACTER)
2930         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2931       else
2932         tmp = fold_convert (gfc_array_index_type,
2933                             size_in_bytes (source_type));
2934     }
2935   else
2936     {
2937       argse.want_pointer = 0;
2938       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2939       source = gfc_conv_descriptor_data_get (argse.expr);
2940       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
2941
2942       /* Repack the source if not a full variable array.  */
2943       if (!(arg->expr->expr_type == EXPR_VARIABLE
2944               && arg->expr->ref->u.ar.type == AR_FULL))
2945         {
2946           tmp = build_fold_addr_expr (argse.expr);
2947           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
2948           source = gfc_evaluate_now (source, &argse.pre);
2949
2950           /* Free the temporary.  */
2951           gfc_start_block (&block);
2952           tmp = gfc_call_free (convert (pvoid_type_node, source));
2953           gfc_add_expr_to_block (&block, tmp);
2954           stmt = gfc_finish_block (&block);
2955
2956           /* Clean up if it was repacked.  */
2957           gfc_init_block (&block);
2958           tmp = gfc_conv_array_data (argse.expr);
2959           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
2960           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
2961           gfc_add_expr_to_block (&block, tmp);
2962           gfc_add_block_to_block (&block, &se->post);
2963           gfc_init_block (&se->post);
2964           gfc_add_block_to_block (&se->post, &block);
2965         }
2966
2967       /* Obtain the source word length.  */
2968       if (arg->expr->ts.type == BT_CHARACTER)
2969         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2970       else
2971         tmp = fold_convert (gfc_array_index_type,
2972                             size_in_bytes (source_type));
2973
2974       /* Obtain the size of the array in bytes.  */
2975       extent = gfc_create_var (gfc_array_index_type, NULL);
2976       for (n = 0; n < arg->expr->rank; n++)
2977         {
2978           tree idx;
2979           idx = gfc_rank_cst[n];
2980           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2981           stride = gfc_conv_descriptor_stride (argse.expr, idx);
2982           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2983           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2984           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2985                              upper, lower);
2986           gfc_add_modify_expr (&argse.pre, extent, tmp);
2987           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2988                              extent, gfc_index_one_node);
2989           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2990                              tmp, source_bytes);
2991         }
2992     }
2993
2994   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2995   gfc_add_block_to_block (&se->pre, &argse.pre);
2996   gfc_add_block_to_block (&se->post, &argse.post);
2997
2998   /* Now convert MOLD.  The outputs are:
2999         mold_type = the TREE type of MOLD
3000         dest_word_len = destination word length in bytes.  */
3001   arg = arg->next;
3002
3003   gfc_init_se (&argse, NULL);
3004   ss = gfc_walk_expr (arg->expr);
3005
3006   if (ss == gfc_ss_terminator)
3007     {
3008       gfc_conv_expr_reference (&argse, arg->expr);
3009       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3010     }
3011   else
3012     {
3013       gfc_init_se (&argse, NULL);
3014       argse.want_pointer = 0;
3015       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3016       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3017     }
3018
3019   if (arg->expr->ts.type == BT_CHARACTER)
3020     {
3021       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3022       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3023     }
3024   else
3025     tmp = fold_convert (gfc_array_index_type,
3026                         size_in_bytes (mold_type));
3027
3028   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3029   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3030
3031   /* Finally convert SIZE, if it is present.  */
3032   arg = arg->next;
3033   size_words = gfc_create_var (gfc_array_index_type, NULL);
3034
3035   if (arg->expr)
3036     {
3037       gfc_init_se (&argse, NULL);
3038       gfc_conv_expr_reference (&argse, arg->expr);
3039       tmp = convert (gfc_array_index_type,
3040                          build_fold_indirect_ref (argse.expr));
3041       gfc_add_block_to_block (&se->pre, &argse.pre);
3042       gfc_add_block_to_block (&se->post, &argse.post);
3043     }
3044   else
3045     tmp = NULL_TREE;
3046
3047   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3048   if (tmp != NULL_TREE)
3049     {
3050       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3051                          tmp, dest_word_len);
3052       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3053                          tmp, source_bytes);
3054     }
3055   else
3056     tmp = source_bytes;
3057
3058   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3059   gfc_add_modify_expr (&se->pre, size_words,
3060                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3061                                     size_bytes, dest_word_len));
3062
3063   /* Evaluate the bounds of the result.  If the loop range exists, we have
3064      to check if it is too large.  If so, we modify loop->to be consistent
3065      with min(size, size(source)).  Otherwise, size is made consistent with
3066      the loop range, so that the right number of bytes is transferred.*/
3067   n = se->loop->order[0];
3068   if (se->loop->to[n] != NULL_TREE)
3069     {
3070       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3071                          se->loop->to[n], se->loop->from[n]);
3072       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3073                          tmp, gfc_index_one_node);
3074       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3075                          tmp, size_words);
3076       gfc_add_modify_expr (&se->pre, size_words, tmp);
3077       gfc_add_modify_expr (&se->pre, size_bytes,
3078                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3079                                         size_words, dest_word_len));
3080       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3081                            size_words, se->loop->from[n]);
3082       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3083                            upper, gfc_index_one_node);
3084     }
3085   else
3086     {
3087       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3088                            size_words, gfc_index_one_node);
3089       se->loop->from[n] = gfc_index_zero_node;
3090     }
3091
3092   se->loop->to[n] = upper;
3093
3094   /* Build a destination descriptor, using the pointer, source, as the
3095      data field.  This is already allocated so set callee_alloc.
3096      FIXME callee_alloc is not set!  */
3097
3098   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3099                                info, mold_type, false, true, false);
3100
3101   /* Cast the pointer to the result.  */
3102   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3103   tmp = fold_convert (pvoid_type_node, tmp);
3104
3105   /* Use memcpy to do the transfer.  */
3106   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3107                          3,
3108                          tmp,
3109                          fold_convert (pvoid_type_node, source),
3110                          size_bytes);
3111   gfc_add_expr_to_block (&se->pre, tmp);
3112
3113   se->expr = info->descriptor;
3114   if (expr->ts.type == BT_CHARACTER)
3115     se->string_length = dest_word_len;
3116 }
3117
3118
3119 /* Scalar transfer statement.
3120    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3121
3122 static void
3123 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3124 {
3125   gfc_actual_arglist *arg;
3126   gfc_se argse;
3127   tree type;
3128   tree ptr;
3129   gfc_ss *ss;
3130   tree tmpdecl, tmp;
3131
3132   /* Get a pointer to the source.  */
3133   arg = expr->value.function.actual;
3134   ss = gfc_walk_expr (arg->expr);
3135   gfc_init_se (&argse, NULL);
3136   if (ss == gfc_ss_terminator)
3137     gfc_conv_expr_reference (&argse, arg->expr);
3138   else
3139     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3140   gfc_add_block_to_block (&se->pre, &argse.pre);
3141   gfc_add_block_to_block (&se->post, &argse.post);
3142   ptr = argse.expr;
3143
3144   arg = arg->next;
3145   type = gfc_typenode_for_spec (&expr->ts);
3146
3147   if (expr->ts.type == BT_CHARACTER)
3148     {
3149       ptr = convert (build_pointer_type (type), ptr);
3150       gfc_init_se (&argse, NULL);
3151       gfc_conv_expr (&argse, arg->expr);
3152       gfc_add_block_to_block (&se->pre, &argse.pre);
3153       gfc_add_block_to_block (&se->post, &argse.post);
3154       se->expr = ptr;
3155       se->string_length = argse.string_length;
3156     }
3157   else
3158     {
3159       tree moldsize;
3160       tmpdecl = gfc_create_var (type, "transfer");
3161       moldsize = size_in_bytes (type);
3162
3163       /* Use memcpy to do the transfer.  */
3164       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3165       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3166                              fold_convert (pvoid_type_node, tmp),
3167                              fold_convert (pvoid_type_node, ptr),
3168                              moldsize);
3169       gfc_add_expr_to_block (&se->pre, tmp);
3170
3171       se->expr = tmpdecl;
3172     }
3173 }
3174
3175
3176 /* Generate code for the ALLOCATED intrinsic.
3177    Generate inline code that directly check the address of the argument.  */
3178
3179 static void
3180 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3181 {
3182   gfc_actual_arglist *arg1;
3183   gfc_se arg1se;
3184   gfc_ss *ss1;
3185   tree tmp;
3186
3187   gfc_init_se (&arg1se, NULL);
3188   arg1 = expr->value.function.actual;
3189   ss1 = gfc_walk_expr (arg1->expr);
3190   arg1se.descriptor_only = 1;
3191   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3192
3193   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3194   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3195                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3196   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3197 }
3198
3199
3200 /* Generate code for the ASSOCIATED intrinsic.
3201    If both POINTER and TARGET are arrays, generate a call to library function
3202    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3203    In other cases, generate inline code that directly compare the address of
3204    POINTER with the address of TARGET.  */
3205
3206 static void
3207 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3208 {
3209   gfc_actual_arglist *arg1;
3210   gfc_actual_arglist *arg2;
3211   gfc_se arg1se;
3212   gfc_se arg2se;
3213   tree tmp2;
3214   tree tmp;
3215   tree fndecl;
3216   tree nonzero_charlen;
3217   tree nonzero_arraylen;
3218   gfc_ss *ss1, *ss2;
3219
3220   gfc_init_se (&arg1se, NULL);
3221   gfc_init_se (&arg2se, NULL);
3222   arg1 = expr->value.function.actual;
3223   arg2 = arg1->next;
3224   ss1 = gfc_walk_expr (arg1->expr);
3225
3226   if (!arg2->expr)
3227     {
3228       /* No optional target.  */
3229       if (ss1 == gfc_ss_terminator)
3230         {
3231           /* A pointer to a scalar.  */
3232           arg1se.want_pointer = 1;
3233           gfc_conv_expr (&arg1se, arg1->expr);
3234           tmp2 = arg1se.expr;
3235         }
3236       else
3237         {
3238           /* A pointer to an array.  */
3239           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3240           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3241         }
3242       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3243       gfc_add_block_to_block (&se->post, &arg1se.post);
3244       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3245                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3246       se->expr = tmp;
3247     }
3248   else
3249     {
3250       /* An optional target.  */
3251       ss2 = gfc_walk_expr (arg2->expr);
3252
3253       nonzero_charlen = NULL_TREE;
3254       if (arg1->expr->ts.type == BT_CHARACTER)
3255         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3256                                   arg1->expr->ts.cl->backend_decl,
3257                                   integer_zero_node);
3258
3259       if (ss1 == gfc_ss_terminator)
3260         {
3261           /* A pointer to a scalar.  */
3262           gcc_assert (ss2 == gfc_ss_terminator);
3263           arg1se.want_pointer = 1;
3264           gfc_conv_expr (&arg1se, arg1->expr);
3265           arg2se.want_pointer = 1;
3266           gfc_conv_expr (&arg2se, arg2->expr);
3267           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3268           gfc_add_block_to_block (&se->post, &arg1se.post);
3269           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3270           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3271                          null_pointer_node);
3272           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3273         }
3274       else
3275         {
3276
3277           /* An array pointer of zero length is not associated if target is
3278              present.  */
3279           arg1se.descriptor_only = 1;
3280           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3281           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3282                                             gfc_rank_cst[arg1->expr->rank - 1]);
3283           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3284                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3285
3286           /* A pointer to an array, call library function _gfor_associated.  */
3287           gcc_assert (ss2 != gfc_ss_terminator);
3288           arg1se.want_pointer = 1;
3289           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3290
3291           arg2se.want_pointer = 1;
3292           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3293           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3294           gfc_add_block_to_block (&se->post, &arg2se.post);
3295           fndecl = gfor_fndecl_associated;
3296           se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
3297           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3298                              se->expr, nonzero_arraylen);
3299
3300         }
3301
3302       /* If target is present zero character length pointers cannot
3303          be associated.  */
3304       if (nonzero_charlen != NULL_TREE)
3305         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3306                            se->expr, nonzero_charlen);
3307     }
3308
3309   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3310 }
3311
3312
3313 /* Scan a string for any one of the characters in a set of characters.  */
3314
3315 static void
3316 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3317 {
3318   tree logical4_type_node = gfc_get_logical_type (4);
3319   tree args;
3320   tree back;
3321   tree type;
3322   tree tmp;
3323
3324   args = gfc_conv_intrinsic_function_args (se, expr);
3325   type = gfc_typenode_for_spec (&expr->ts);
3326   tmp = gfc_advance_chain (args, 3);
3327   if (TREE_CHAIN (tmp) == NULL_TREE)
3328     {
3329       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3330                         NULL_TREE);
3331       TREE_CHAIN (tmp) = back;
3332     }
3333   else
3334     {
3335       back = TREE_CHAIN (tmp);
3336       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3337     }
3338
3339   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
3340   se->expr = convert (type, se->expr);
3341 }
3342
3343
3344 /* Verify that a set of characters contains all the characters in a string
3345    by identifying the position of the first character in a string of
3346    characters that does not appear in a given set of characters.  */
3347
3348 static void
3349 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3350 {
3351   tree logical4_type_node = gfc_get_logical_type (4);
3352   tree args;
3353   tree back;
3354   tree type;
3355   tree tmp;
3356
3357   args = gfc_conv_intrinsic_function_args (se, expr);
3358   type = gfc_typenode_for_spec (&expr->ts);
3359   tmp = gfc_advance_chain (args, 3);
3360   if (TREE_CHAIN (tmp) == NULL_TREE)
3361     {
3362       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3363                         NULL_TREE);
3364       TREE_CHAIN (tmp) = back;
3365     }
3366   else
3367     {
3368       back = TREE_CHAIN (tmp);
3369       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3370     }
3371
3372   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
3373   se->expr = convert (type, se->expr);
3374 }
3375
3376
3377 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3378
3379 static void
3380 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3381 {
3382   tree args;
3383
3384   args = gfc_conv_intrinsic_function_args (se, expr);
3385   args = TREE_VALUE (args);
3386   args = build_fold_addr_expr (args);
3387   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, args);
3388 }
3389
3390 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3391
3392 static void
3393 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3394 {
3395   gfc_actual_arglist *actual;
3396   tree args;
3397   gfc_se argse;
3398
3399   args = NULL_TREE;
3400   for (actual = expr->value.function.actual; actual; actual = actual->next)
3401     {
3402       gfc_init_se (&argse, se);
3403
3404       /* Pass a NULL pointer for an absent arg.  */
3405       if (actual->expr == NULL)
3406         argse.expr = null_pointer_node;
3407       else
3408         gfc_conv_expr_reference (&argse, actual->expr);
3409
3410       gfc_add_block_to_block (&se->pre, &argse.pre);
3411       gfc_add_block_to_block (&se->post, &argse.post);
3412       args = gfc_chainon_list (args, argse.expr);
3413     }
3414   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3415 }
3416
3417
3418 /* Generate code for TRIM (A) intrinsic function.  */
3419
3420 static void
3421 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3422 {
3423   tree gfc_int4_type_node = gfc_get_int_type (4);
3424   tree var;
3425   tree len;
3426   tree addr;
3427   tree tmp;
3428   tree arglist;
3429   tree type;
3430   tree cond;
3431
3432   arglist = NULL_TREE;
3433
3434   type = build_pointer_type (gfc_character1_type_node);
3435   var = gfc_create_var (type, "pstr");
3436   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3437   len = gfc_create_var (gfc_int4_type_node, "len");
3438
3439   tmp = gfc_conv_intrinsic_function_args (se, expr);
3440   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3441   arglist = gfc_chainon_list (arglist, addr);
3442   arglist = chainon (arglist, tmp);
3443
3444   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3445   gfc_add_expr_to_block (&se->pre, tmp);
3446
3447   /* Free the temporary afterwards, if necessary.  */
3448   cond = build2 (GT_EXPR, boolean_type_node, len,
3449                  build_int_cst (TREE_TYPE (len), 0));
3450   tmp = gfc_call_free (var);
3451   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3452   gfc_add_expr_to_block (&se->post, tmp);
3453
3454   se->expr = var;
3455   se->string_length = len;
3456 }
3457
3458
3459 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3460
3461 static void
3462 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3463 {
3464   tree args, ncopies, dest, dlen, src, slen, ncopies_type;
3465   tree type, cond, tmp, count, exit_label, n, max, largest;
3466   stmtblock_t block, body;
3467   int i;
3468
3469   /* Get the arguments.  */
3470   args = gfc_conv_intrinsic_function_args (se, expr);
3471   slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args),
3472                                                          &se->pre));
3473   src = TREE_VALUE (TREE_CHAIN (args));
3474   ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args)));
3475   ncopies = gfc_evaluate_now (ncopies, &se->pre);
3476   ncopies_type = TREE_TYPE (ncopies);
3477
3478   /* Check that NCOPIES is not negative.  */
3479   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3480                       build_int_cst (ncopies_type, 0));
3481   gfc_trans_runtime_check (cond,
3482                            "Argument NCOPIES of REPEAT intrinsic is negative",
3483                            &se->pre, &expr->where);
3484
3485   /* If the source length is zero, any non negative value of NCOPIES
3486      is valid, and nothing happens.  */
3487   n = gfc_create_var (ncopies_type, "ncopies");
3488   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3489                       build_int_cst (size_type_node, 0));
3490   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3491                      build_int_cst (ncopies_type, 0), ncopies);
3492   gfc_add_modify_expr (&se->pre, n, tmp);
3493   ncopies = n;
3494
3495   /* Check that ncopies is not too large: ncopies should be less than
3496      (or equal to) MAX / slen, where MAX is the maximal integer of
3497      the gfc_charlen_type_node type.  If slen == 0, we need a special
3498      case to avoid the division by zero.  */
3499   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3500   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3501   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3502                      fold_convert (size_type_node, max), slen);
3503   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3504               ? size_type_node : ncopies_type;
3505   cond = fold_build2 (GT_EXPR, boolean_type_node,
3506                       fold_convert (largest, ncopies),
3507                       fold_convert (largest, max));
3508   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3509                      build_int_cst (size_type_node, 0));
3510   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3511                       cond);
3512   gfc_trans_runtime_check (cond,
3513                            "Argument NCOPIES of REPEAT intrinsic is too large",
3514                            &se->pre, &expr->where);
3515
3516   /* Compute the destination length.  */
3517   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies);
3518   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3519   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3520
3521   /* Generate the code to do the repeat operation:
3522        for (i = 0; i < ncopies; i++)
3523          memmove (dest + (i * slen), src, slen);  */
3524   gfc_start_block (&block);
3525   count = gfc_create_var (ncopies_type, "count");
3526   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3527   exit_label = gfc_build_label_decl (NULL_TREE);
3528
3529   /* Start the loop body.  */
3530   gfc_start_block (&body);
3531
3532   /* Exit the loop if count >= ncopies.  */
3533   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3534   tmp = build1_v (GOTO_EXPR, exit_label);
3535   TREE_USED (exit_label) = 1;
3536   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3537                      build_empty_stmt ());
3538   gfc_add_expr_to_block (&body, tmp);
3539
3540   /* Call memmove (dest + (i*slen), src, slen).  */
3541   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen,
3542                      fold_convert (gfc_charlen_type_node, count));
3543   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node, dest,
3544                      fold_convert (sizetype, tmp));
3545   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3546                          tmp, src, slen);
3547   gfc_add_expr_to_block (&body, tmp);
3548
3549   /* Increment count.  */
3550   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3551                 build_int_cst (TREE_TYPE (count), 1));
3552   gfc_add_modify_expr (&body, count, tmp);
3553
3554   /* Build the loop.  */
3555   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3556   gfc_add_expr_to_block (&block, tmp);
3557
3558   /* Add the exit label.  */
3559   tmp = build1_v (LABEL_EXPR, exit_label);
3560   gfc_add_expr_to_block (&block, tmp);
3561
3562   /* Finish the block.  */
3563   tmp = gfc_finish_block (&block);
3564   gfc_add_expr_to_block (&se->pre, tmp);
3565
3566   /* Set the result value.  */
3567   se->expr = dest;
3568   se->string_length = dlen;
3569 }
3570
3571
3572 /* Generate code for the IARGC intrinsic.  */
3573
3574 static void
3575 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3576 {
3577   tree tmp;
3578   tree fndecl;
3579   tree type;
3580
3581   /* Call the library function.  This always returns an INTEGER(4).  */
3582   fndecl = gfor_fndecl_iargc;
3583   tmp = build_call_expr (fndecl, 0);
3584
3585   /* Convert it to the required type.  */
3586   type = gfc_typenode_for_spec (&expr->ts);
3587   tmp = fold_convert (type, tmp);
3588
3589   se->expr = tmp;
3590 }
3591
3592
3593 /* The loc intrinsic returns the address of its argument as
3594    gfc_index_integer_kind integer.  */
3595
3596 static void
3597 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3598 {
3599   tree temp_var;
3600   gfc_expr *arg_expr;
3601   gfc_ss *ss;
3602
3603   gcc_assert (!se->ss);
3604
3605   arg_expr = expr->value.function.actual->expr;
3606   ss = gfc_walk_expr (arg_expr);
3607   if (ss == gfc_ss_terminator)
3608     gfc_conv_expr_reference (se, arg_expr);
3609   else
3610     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3611   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3612
3613   /* Create a temporary variable for loc return value.  Without this,
3614      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3615   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3616   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3617   se->expr = temp_var;
3618 }
3619
3620 /* Generate code for an intrinsic function.  Some map directly to library
3621    calls, others get special handling.  In some cases the name of the function
3622    used depends on the type specifiers.  */
3623
3624 void
3625 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3626 {
3627   gfc_intrinsic_sym *isym;
3628   const char *name;
3629   int lib;
3630
3631   isym = expr->value.function.isym;
3632
3633   name = &expr->value.function.name[2];
3634
3635   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3636     {
3637       lib = gfc_is_intrinsic_libcall (expr);
3638       if (lib != 0)
3639         {
3640           if (lib == 1)
3641             se->ignore_optional = 1;
3642           gfc_conv_intrinsic_funcall (se, expr);
3643           return;
3644         }
3645     }
3646
3647   switch (expr->value.function.isym->id)
3648     {
3649     case GFC_ISYM_NONE:
3650       gcc_unreachable ();
3651
3652     case GFC_ISYM_REPEAT:
3653       gfc_conv_intrinsic_repeat (se, expr);
3654       break;
3655
3656     case GFC_ISYM_TRIM:
3657       gfc_conv_intrinsic_trim (se, expr);
3658       break;
3659
3660     case GFC_ISYM_SI_KIND:
3661       gfc_conv_intrinsic_si_kind (se, expr);
3662       break;
3663
3664     case GFC_ISYM_SR_KIND:
3665       gfc_conv_intrinsic_sr_kind (se, expr);
3666       break;
3667
3668     case GFC_ISYM_EXPONENT:
3669       gfc_conv_intrinsic_exponent (se, expr);
3670       break;
3671
3672     case GFC_ISYM_SCAN:
3673       gfc_conv_intrinsic_scan (se, expr);
3674       break;
3675
3676     case GFC_ISYM_VERIFY:
3677       gfc_conv_intrinsic_verify (se, expr);
3678       break;
3679
3680     case GFC_ISYM_ALLOCATED:
3681       gfc_conv_allocated (se, expr);
3682       break;
3683
3684     case GFC_ISYM_ASSOCIATED:
3685       gfc_conv_associated(se, expr);
3686       break;
3687
3688     case GFC_ISYM_ABS:
3689       gfc_conv_intrinsic_abs (se, expr);
3690       break;
3691
3692     case GFC_ISYM_ADJUSTL:
3693       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3694       break;
3695
3696     case GFC_ISYM_ADJUSTR:
3697       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3698       break;
3699
3700     case GFC_ISYM_AIMAG:
3701       gfc_conv_intrinsic_imagpart (se, expr);
3702       break;
3703
3704     case GFC_ISYM_AINT:
3705       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3706       break;
3707
3708     case GFC_ISYM_ALL:
3709       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3710       break;
3711
3712     case GFC_ISYM_ANINT:
3713       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3714       break;
3715
3716     case GFC_ISYM_AND:
3717       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3718       break;
3719
3720     case GFC_ISYM_ANY:
3721       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3722       break;
3723
3724     case GFC_ISYM_BTEST:
3725       gfc_conv_intrinsic_btest (se, expr);
3726       break;
3727
3728     case GFC_ISYM_ACHAR:
3729     case GFC_ISYM_CHAR:
3730       gfc_conv_intrinsic_char (se, expr);
3731       break;
3732
3733     case GFC_ISYM_CONVERSION:
3734     case GFC_ISYM_REAL:
3735     case GFC_ISYM_LOGICAL:
3736     case GFC_ISYM_DBLE:
3737       gfc_conv_intrinsic_conversion (se, expr);
3738       break;
3739
3740       /* Integer conversions are handled separately to make sure we get the
3741          correct rounding mode.  */
3742     case GFC_ISYM_INT:
3743     case GFC_ISYM_INT2:
3744     case GFC_ISYM_INT8:
3745     case GFC_ISYM_LONG:
3746       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3747       break;
3748
3749     case GFC_ISYM_NINT:
3750       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3751       break;
3752
3753     case GFC_ISYM_CEILING:
3754       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3755       break;
3756
3757     case GFC_ISYM_FLOOR:
3758       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3759       break;
3760
3761     case GFC_ISYM_MOD:
3762       gfc_conv_intrinsic_mod (se, expr, 0);
3763       break;
3764
3765     case GFC_ISYM_MODULO:
3766       gfc_conv_intrinsic_mod (se, expr, 1);
3767       break;
3768
3769     case GFC_ISYM_CMPLX:
3770       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3771       break;
3772
3773     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3774       gfc_conv_intrinsic_iargc (se, expr);
3775       break;
3776
3777     case GFC_ISYM_COMPLEX:
3778       gfc_conv_intrinsic_cmplx (se, expr, 1);
3779       break;
3780
3781     case GFC_ISYM_CONJG:
3782       gfc_conv_intrinsic_conjg (se, expr);
3783       break;
3784
3785     case GFC_ISYM_COUNT:
3786       gfc_conv_intrinsic_count (se, expr);
3787       break;
3788
3789     case GFC_ISYM_CTIME:
3790       gfc_conv_intrinsic_ctime (se, expr);
3791       break;
3792
3793     case GFC_ISYM_DIM:
3794       gfc_conv_intrinsic_dim (se, expr);
3795       break;
3796
3797     case GFC_ISYM_DOT_PRODUCT:
3798       gfc_conv_intrinsic_dot_product (se, expr);
3799       break;
3800
3801     case GFC_ISYM_DPROD:
3802       gfc_conv_intrinsic_dprod (se, expr);
3803       break;
3804
3805     case GFC_ISYM_FDATE:
3806       gfc_conv_intrinsic_fdate (se, expr);
3807       break;
3808
3809     case GFC_ISYM_IAND:
3810       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3811       break;
3812
3813     case GFC_ISYM_IBCLR:
3814       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3815       break;
3816
3817     case GFC_ISYM_IBITS:
3818       gfc_conv_intrinsic_ibits (se, expr);
3819       break;
3820
3821     case GFC_ISYM_IBSET:
3822       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3823       break;
3824
3825     case GFC_ISYM_IACHAR:
3826     case GFC_ISYM_ICHAR:
3827       /* We assume ASCII character sequence.  */
3828       gfc_conv_intrinsic_ichar (se, expr);
3829       break;
3830
3831     case GFC_ISYM_IARGC:
3832       gfc_conv_intrinsic_iargc (se, expr);
3833       break;
3834
3835     case GFC_ISYM_IEOR:
3836       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3837       break;
3838
3839     case GFC_ISYM_INDEX:
3840       gfc_conv_intrinsic_index (se, expr);
3841       break;
3842
3843     case GFC_ISYM_IOR:
3844       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3845       break;
3846
3847     case GFC_ISYM_LSHIFT:
3848       gfc_conv_intrinsic_rlshift (se, expr, 0);
3849       break;
3850
3851     case GFC_ISYM_RSHIFT:
3852       gfc_conv_intrinsic_rlshift (se, expr, 1);
3853       break;
3854
3855     case GFC_ISYM_ISHFT:
3856       gfc_conv_intrinsic_ishft (se, expr);
3857       break;
3858
3859     case GFC_ISYM_ISHFTC:
3860       gfc_conv_intrinsic_ishftc (se, expr);
3861       break;
3862
3863     case GFC_ISYM_LBOUND:
3864       gfc_conv_intrinsic_bound (se, expr, 0);
3865       break;
3866
3867     case GFC_ISYM_TRANSPOSE:
3868       if (se->ss && se->ss->useflags)
3869         {
3870           gfc_conv_tmp_array_ref (se);
3871           gfc_advance_se_ss_chain (se);
3872         }
3873       else
3874         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3875       break;
3876
3877     case GFC_ISYM_LEN:
3878       gfc_conv_intrinsic_len (se, expr);
3879       break;
3880
3881     case GFC_ISYM_LEN_TRIM:
3882       gfc_conv_intrinsic_len_trim (se, expr);
3883       break;
3884
3885     case GFC_ISYM_LGE:
3886       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3887       break;
3888
3889     case GFC_ISYM_LGT:
3890       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3891       break;
3892
3893     case GFC_ISYM_LLE:
3894       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3895       break;
3896
3897     case GFC_ISYM_LLT:
3898       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3899       break;
3900
3901     case GFC_ISYM_MAX:
3902       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3903       break;
3904
3905     case GFC_ISYM_MAXLOC:
3906       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3907       break;
3908
3909     case GFC_ISYM_MAXVAL:
3910       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3911       break;
3912
3913     case GFC_ISYM_MERGE:
3914       gfc_conv_intrinsic_merge (se, expr);
3915       break;
3916
3917     case GFC_ISYM_MIN:
3918       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3919       break;
3920
3921     case GFC_ISYM_MINLOC:
3922       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3923       break;
3924
3925     case GFC_ISYM_MINVAL:
3926       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3927       break;
3928
3929     case GFC_ISYM_NOT:
3930       gfc_conv_intrinsic_not (se, expr);
3931       break;
3932
3933     case GFC_ISYM_OR:
3934       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3935       break;
3936
3937     case GFC_ISYM_PRESENT:
3938       gfc_conv_intrinsic_present (se, expr);
3939       break;
3940
3941     case GFC_ISYM_PRODUCT:
3942       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3943       break;
3944
3945     case GFC_ISYM_SIGN:
3946       gfc_conv_intrinsic_sign (se, expr);
3947       break;
3948
3949     case GFC_ISYM_SIZE:
3950       gfc_conv_intrinsic_size (se, expr);
3951       break;
3952
3953     case GFC_ISYM_SIZEOF:
3954       gfc_conv_intrinsic_sizeof (se, expr);
3955       break;
3956
3957     case GFC_ISYM_SUM:
3958       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3959       break;
3960
3961     case GFC_ISYM_TRANSFER:
3962       if (se->ss)
3963         {
3964           if (se->ss->useflags)
3965             {
3966               /* Access the previously obtained result.  */
3967               gfc_conv_tmp_array_ref (se);
3968               gfc_advance_se_ss_chain (se);
3969               break;
3970             }
3971           else
3972             gfc_conv_intrinsic_array_transfer (se, expr);
3973         }
3974       else
3975         gfc_conv_intrinsic_transfer (se, expr);
3976       break;
3977
3978     case GFC_ISYM_TTYNAM:
3979       gfc_conv_intrinsic_ttynam (se, expr);
3980       break;
3981
3982     case GFC_ISYM_UBOUND:
3983       gfc_conv_intrinsic_bound (se, expr, 1);
3984       break;
3985
3986     case GFC_ISYM_XOR:
3987       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3988       break;
3989
3990     case GFC_ISYM_LOC:
3991       gfc_conv_intrinsic_loc (se, expr);
3992       break;
3993
3994     case GFC_ISYM_ACCESS:
3995     case GFC_ISYM_CHDIR:
3996     case GFC_ISYM_CHMOD:
3997     case GFC_ISYM_ETIME:
3998     case GFC_ISYM_FGET:
3999     case GFC_ISYM_FGETC:
4000     case GFC_ISYM_FNUM:
4001     case GFC_ISYM_FPUT:
4002     case GFC_ISYM_FPUTC:
4003     case GFC_ISYM_FSTAT:
4004     case GFC_ISYM_FTELL:
4005     case GFC_ISYM_GETCWD:
4006     case GFC_ISYM_GETGID:
4007     case GFC_ISYM_GETPID:
4008     case GFC_ISYM_GETUID:
4009     case GFC_ISYM_HOSTNM:
4010     case GFC_ISYM_KILL:
4011     case GFC_ISYM_IERRNO:
4012     case GFC_ISYM_IRAND:
4013     case GFC_ISYM_ISATTY:
4014     case GFC_ISYM_LINK:
4015     case GFC_ISYM_LSTAT:
4016     case GFC_ISYM_MALLOC:
4017     case GFC_ISYM_MATMUL:
4018     case GFC_ISYM_MCLOCK:
4019     case GFC_ISYM_MCLOCK8:
4020     case GFC_ISYM_RAND:
4021     case GFC_ISYM_RENAME:
4022     case GFC_ISYM_SECOND:
4023     case GFC_ISYM_SECNDS:
4024     case GFC_ISYM_SIGNAL:
4025     case GFC_ISYM_STAT:
4026     case GFC_ISYM_SYMLNK:
4027     case GFC_ISYM_SYSTEM:
4028     case GFC_ISYM_TIME:
4029     case GFC_ISYM_TIME8:
4030     case GFC_ISYM_UMASK:
4031     case GFC_ISYM_UNLINK:
4032       gfc_conv_intrinsic_funcall (se, expr);
4033       break;
4034
4035     default:
4036       gfc_conv_intrinsic_lib_function (se, expr);
4037       break;
4038     }
4039 }
4040
4041
4042 /* This generates code to execute before entering the scalarization loop.
4043    Currently does nothing.  */
4044
4045 void
4046 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4047 {
4048   switch (ss->expr->value.function.isym->id)
4049     {
4050     case GFC_ISYM_UBOUND:
4051     case GFC_ISYM_LBOUND:
4052       break;
4053
4054     default:
4055       gcc_unreachable ();
4056     }
4057 }
4058
4059
4060 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4061    inside the scalarization loop.  */
4062
4063 static gfc_ss *
4064 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4065 {
4066   gfc_ss *newss;
4067
4068   /* The two argument version returns a scalar.  */
4069   if (expr->value.function.actual->next->expr)
4070     return ss;
4071
4072   newss = gfc_get_ss ();
4073   newss->type = GFC_SS_INTRINSIC;
4074   newss->expr = expr;
4075   newss->next = ss;
4076   newss->data.info.dimen = 1;
4077
4078   return newss;
4079 }
4080
4081
4082 /* Walk an intrinsic array libcall.  */
4083
4084 static gfc_ss *
4085 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4086 {
4087   gfc_ss *newss;
4088
4089   gcc_assert (expr->rank > 0);
4090
4091   newss = gfc_get_ss ();
4092   newss->type = GFC_SS_FUNCTION;
4093   newss->expr = expr;
4094   newss->next = ss;
4095   newss->data.info.dimen = expr->rank;
4096
4097   return newss;
4098 }
4099
4100
4101 /* Returns nonzero if the specified intrinsic function call maps directly to a
4102    an external library call.  Should only be used for functions that return
4103    arrays.  */
4104
4105 int
4106 gfc_is_intrinsic_libcall (gfc_expr * expr)
4107 {
4108   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4109   gcc_assert (expr->rank > 0);
4110
4111   switch (expr->value.function.isym->id)
4112     {
4113     case GFC_ISYM_ALL:
4114     case GFC_ISYM_ANY:
4115     case GFC_ISYM_COUNT:
4116     case GFC_ISYM_MATMUL:
4117     case GFC_ISYM_MAXLOC:
4118     case GFC_ISYM_MAXVAL:
4119     case GFC_ISYM_MINLOC:
4120     case GFC_ISYM_MINVAL:
4121     case GFC_ISYM_PRODUCT:
4122     case GFC_ISYM_SUM:
4123     case GFC_ISYM_SHAPE:
4124     case GFC_ISYM_SPREAD:
4125     case GFC_ISYM_TRANSPOSE:
4126       /* Ignore absent optional parameters.  */
4127       return 1;
4128
4129     case GFC_ISYM_RESHAPE:
4130     case GFC_ISYM_CSHIFT:
4131     case GFC_ISYM_EOSHIFT:
4132     case GFC_ISYM_PACK:
4133     case GFC_ISYM_UNPACK:
4134       /* Pass absent optional parameters.  */
4135       return 2;
4136
4137     default:
4138       return 0;
4139     }
4140 }
4141
4142 /* Walk an intrinsic function.  */
4143 gfc_ss *
4144 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4145                              gfc_intrinsic_sym * isym)
4146 {
4147   gcc_assert (isym);
4148
4149   if (isym->elemental)
4150     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4151
4152   if (expr->rank == 0)
4153     return ss;
4154
4155   if (gfc_is_intrinsic_libcall (expr))
4156     return gfc_walk_intrinsic_libfunc (ss, expr);
4157
4158   /* Special cases.  */
4159   switch (isym->id)
4160     {
4161     case GFC_ISYM_LBOUND:
4162     case GFC_ISYM_UBOUND:
4163       return gfc_walk_intrinsic_bound (ss, expr);
4164
4165     case GFC_ISYM_TRANSFER:
4166       return gfc_walk_intrinsic_libfunc (ss, expr);
4167
4168     default:
4169       /* This probably meant someone forgot to add an intrinsic to the above
4170          list(s) when they implemented it, or something's gone horribly wrong.
4171        */
4172       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4173                       expr->value.function.name);
4174     }
4175 }
4176
4177 #include "gt-fortran-trans-intrinsic.h"