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