gcc/fortran/trans-intrinsic.c

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