gcc/fortran/trans-intrinsic.c

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