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