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 /* Generate code for the TRANSFER intrinsic:
3619         For scalar results:
3620           DEST = TRANSFER (SOURCE, MOLD)
3621         where:
3622           typeof<DEST> = typeof<MOLD>
3623         and:
3624           MOLD is scalar.
3625
3626         For array results:
3627           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3628         where:
3629           typeof<DEST> = typeof<MOLD>
3630         and:
3631           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3632               sizeof (DEST(0) * SIZE).  */
3633 static void
3634 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3635 {
3636   tree tmp;
3637   tree tmpdecl;
3638   tree ptr;
3639   tree extent;
3640   tree source;
3641   tree source_type;
3642   tree source_bytes;
3643   tree mold_type;
3644   tree dest_word_len;
3645   tree size_words;
3646   tree size_bytes;
3647   tree upper;
3648   tree lower;
3649   tree stride;
3650   tree stmt;
3651   gfc_actual_arglist *arg;
3652   gfc_se argse;
3653   gfc_ss *ss;
3654   gfc_ss_info *info;
3655   stmtblock_t block;
3656   int n;
3657   bool scalar_mold;
3658
3659   info = NULL;
3660   if (se->loop)
3661     info = &se->ss->data.info;
3662
3663   /* Convert SOURCE.  The output from this stage is:-
3664         source_bytes = length of the source in bytes
3665         source = pointer to the source data.  */
3666   arg = expr->value.function.actual;
3667
3668   /* Ensure double transfer through LOGICAL preserves all
3669      the needed bits.  */
3670   if (arg->expr->expr_type == EXPR_FUNCTION
3671         && arg->expr->value.function.esym == NULL
3672         && arg->expr->value.function.isym != NULL
3673         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
3674         && arg->expr->ts.type == BT_LOGICAL
3675         && expr->ts.type != arg->expr->ts.type)
3676     arg->expr->value.function.name = "__transfer_in_transfer";
3677
3678   gfc_init_se (&argse, NULL);
3679   ss = gfc_walk_expr (arg->expr);
3680
3681   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3682
3683   /* Obtain the pointer to source and the length of source in bytes.  */
3684   if (ss == gfc_ss_terminator)
3685     {
3686       gfc_conv_expr_reference (&argse, arg->expr);
3687       source = argse.expr;
3688
3689       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3690
3691       /* Obtain the source word length.  */
3692       if (arg->expr->ts.type == BT_CHARACTER)
3693         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3694                                        argse.string_length);
3695       else
3696         tmp = fold_convert (gfc_array_index_type,
3697                             size_in_bytes (source_type));
3698     }
3699   else
3700     {
3701       argse.want_pointer = 0;
3702       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3703       source = gfc_conv_descriptor_data_get (argse.expr);
3704       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3705
3706       /* Repack the source if not a full variable array.  */
3707       if (arg->expr->expr_type == EXPR_VARIABLE
3708               && arg->expr->ref->u.ar.type != AR_FULL)
3709         {
3710           tmp = build_fold_addr_expr (argse.expr);
3711
3712           if (gfc_option.warn_array_temp)
3713             gfc_warning ("Creating array temporary at %L", &expr->where);
3714
3715           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3716           source = gfc_evaluate_now (source, &argse.pre);
3717
3718           /* Free the temporary.  */
3719           gfc_start_block (&block);
3720           tmp = gfc_call_free (convert (pvoid_type_node, source));
3721           gfc_add_expr_to_block (&block, tmp);
3722           stmt = gfc_finish_block (&block);
3723
3724           /* Clean up if it was repacked.  */
3725           gfc_init_block (&block);
3726           tmp = gfc_conv_array_data (argse.expr);
3727           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3728           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3729           gfc_add_expr_to_block (&block, tmp);
3730           gfc_add_block_to_block (&block, &se->post);
3731           gfc_init_block (&se->post);
3732           gfc_add_block_to_block (&se->post, &block);
3733         }
3734
3735       /* Obtain the source word length.  */
3736       if (arg->expr->ts.type == BT_CHARACTER)
3737         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3738                                        argse.string_length);
3739       else
3740         tmp = fold_convert (gfc_array_index_type,
3741                             size_in_bytes (source_type));
3742
3743       /* Obtain the size of the array in bytes.  */
3744       extent = gfc_create_var (gfc_array_index_type, NULL);
3745       for (n = 0; n < arg->expr->rank; n++)
3746         {
3747           tree idx;
3748           idx = gfc_rank_cst[n];
3749           gfc_add_modify (&argse.pre, source_bytes, tmp);
3750           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3751           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3752           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3753           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3754                              upper, lower);
3755           gfc_add_modify (&argse.pre, extent, tmp);
3756           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3757                              extent, gfc_index_one_node);
3758           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3759                              tmp, source_bytes);
3760         }
3761     }
3762
3763   gfc_add_modify (&argse.pre, source_bytes, tmp);
3764   gfc_add_block_to_block (&se->pre, &argse.pre);
3765   gfc_add_block_to_block (&se->post, &argse.post);
3766
3767   /* Now convert MOLD.  The outputs are:
3768         mold_type = the TREE type of MOLD
3769         dest_word_len = destination word length in bytes.  */
3770   arg = arg->next;
3771
3772   gfc_init_se (&argse, NULL);
3773   ss = gfc_walk_expr (arg->expr);
3774
3775   scalar_mold = arg->expr->rank == 0;
3776
3777   if (ss == gfc_ss_terminator)
3778     {
3779       gfc_conv_expr_reference (&argse, arg->expr);
3780       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3781     }
3782   else
3783     {
3784       gfc_init_se (&argse, NULL);
3785       argse.want_pointer = 0;
3786       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3787       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3788     }
3789
3790   gfc_add_block_to_block (&se->pre, &argse.pre);
3791   gfc_add_block_to_block (&se->post, &argse.post);
3792
3793   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
3794     {
3795       /* If this TRANSFER is nested in another TRANSFER, use a type
3796          that preserves all bits.  */
3797       if (arg->expr->ts.type == BT_LOGICAL)
3798         mold_type = gfc_get_int_type (arg->expr->ts.kind);
3799     }
3800
3801   if (arg->expr->ts.type == BT_CHARACTER)
3802     {
3803       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
3804       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3805     }
3806   else
3807     tmp = fold_convert (gfc_array_index_type,
3808                         size_in_bytes (mold_type));
3809
3810   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3811   gfc_add_modify (&se->pre, dest_word_len, tmp);
3812
3813   /* Finally convert SIZE, if it is present.  */
3814   arg = arg->next;
3815   size_words = gfc_create_var (gfc_array_index_type, NULL);
3816
3817   if (arg->expr)
3818     {
3819       gfc_init_se (&argse, NULL);
3820       gfc_conv_expr_reference (&argse, arg->expr);
3821       tmp = convert (gfc_array_index_type,
3822                          build_fold_indirect_ref (argse.expr));
3823       gfc_add_block_to_block (&se->pre, &argse.pre);
3824       gfc_add_block_to_block (&se->post, &argse.post);
3825     }
3826   else
3827     tmp = NULL_TREE;
3828
3829   /* Separate array and scalar results.  */
3830   if (scalar_mold && tmp == NULL_TREE)
3831     goto scalar_transfer;
3832
3833   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3834   if (tmp != NULL_TREE)
3835     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3836                        tmp, dest_word_len);
3837   else
3838     tmp = source_bytes;
3839
3840   gfc_add_modify (&se->pre, size_bytes, tmp);
3841   gfc_add_modify (&se->pre, size_words,
3842                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3843                                     size_bytes, dest_word_len));
3844
3845   /* Evaluate the bounds of the result.  If the loop range exists, we have
3846      to check if it is too large.  If so, we modify loop->to be consistent
3847      with min(size, size(source)).  Otherwise, size is made consistent with
3848      the loop range, so that the right number of bytes is transferred.*/
3849   n = se->loop->order[0];
3850   if (se->loop->to[n] != NULL_TREE)
3851     {
3852       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3853                          se->loop->to[n], se->loop->from[n]);
3854       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3855                          tmp, gfc_index_one_node);
3856       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3857                          tmp, size_words);
3858       gfc_add_modify (&se->pre, size_words, tmp);
3859       gfc_add_modify (&se->pre, size_bytes,
3860                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3861                                         size_words, dest_word_len));
3862       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3863                            size_words, se->loop->from[n]);
3864       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3865                            upper, gfc_index_one_node);
3866     }
3867   else
3868     {
3869       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3870                            size_words, gfc_index_one_node);
3871       se->loop->from[n] = gfc_index_zero_node;
3872     }
3873
3874   se->loop->to[n] = upper;
3875
3876   /* Build a destination descriptor, using the pointer, source, as the
3877      data field.  */
3878   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3879                                info, mold_type, NULL_TREE, false, true, false,
3880                                &expr->where);
3881
3882   /* Cast the pointer to the result.  */
3883   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3884   tmp = fold_convert (pvoid_type_node, tmp);
3885
3886   /* Use memcpy to do the transfer.  */
3887   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3888                          3,
3889                          tmp,
3890                          fold_convert (pvoid_type_node, source),
3891                          fold_build2 (MIN_EXPR, gfc_array_index_type,
3892                                       size_bytes, source_bytes));
3893   gfc_add_expr_to_block (&se->pre, tmp);
3894
3895   se->expr = info->descriptor;
3896   if (expr->ts.type == BT_CHARACTER)
3897     se->string_length = dest_word_len;
3898
3899   return;
3900
3901 /* Deal with scalar results.  */
3902 scalar_transfer:
3903   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
3904                         dest_word_len, source_bytes);
3905
3906   if (expr->ts.type == BT_CHARACTER)
3907     {
3908       tree direct;
3909       tree indirect;
3910
3911       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
3912       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
3913                                 "transfer");
3914
3915       /* If source is longer than the destination, use a pointer to
3916          the source directly.  */
3917       gfc_init_block (&block);
3918       gfc_add_modify (&block, tmpdecl, ptr);
3919       direct = gfc_finish_block (&block);
3920
3921       /* Otherwise, allocate a string with the length of the destination
3922          and copy the source into it.  */
3923       gfc_init_block (&block);
3924       tmp = gfc_get_pchar_type (expr->ts.kind);
3925       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
3926       gfc_add_modify (&block, tmpdecl,
3927                       fold_convert (TREE_TYPE (ptr), tmp));
3928       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3929                              fold_convert (pvoid_type_node, tmpdecl),
3930                              fold_convert (pvoid_type_node, ptr),
3931                              extent);
3932       gfc_add_expr_to_block (&block, tmp);
3933       indirect = gfc_finish_block (&block);
3934
3935       /* Wrap it up with the condition.  */
3936       tmp = fold_build2 (LE_EXPR, boolean_type_node,
3937                          dest_word_len, source_bytes);
3938       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
3939       gfc_add_expr_to_block (&se->pre, tmp);
3940
3941       se->expr = tmpdecl;
3942       se->string_length = dest_word_len;
3943     }
3944   else
3945     {
3946       tmpdecl = gfc_create_var (mold_type, "transfer");
3947
3948       ptr = convert (build_pointer_type (mold_type), source);
3949
3950       /* Use memcpy to do the transfer.  */
3951       tmp = build_fold_addr_expr (tmpdecl);
3952       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3953                              fold_convert (pvoid_type_node, tmp),
3954                              fold_convert (pvoid_type_node, ptr),
3955                              extent);
3956       gfc_add_expr_to_block (&se->pre, tmp);
3957
3958       se->expr = tmpdecl;
3959     }
3960 }
3961
3962
3963 /* Generate code for the ALLOCATED intrinsic.
3964    Generate inline code that directly check the address of the argument.  */
3965
3966 static void
3967 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3968 {
3969   gfc_actual_arglist *arg1;
3970   gfc_se arg1se;
3971   gfc_ss *ss1;
3972   tree tmp;
3973
3974   gfc_init_se (&arg1se, NULL);
3975   arg1 = expr->value.function.actual;
3976   ss1 = gfc_walk_expr (arg1->expr);
3977   arg1se.descriptor_only = 1;
3978   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3979
3980   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3981   tmp = fold_build2 (NE_EXPR, boolean_type_node,
3982                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
3983   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3984 }
3985
3986
3987 /* Generate code for the ASSOCIATED intrinsic.
3988    If both POINTER and TARGET are arrays, generate a call to library function
3989    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3990    In other cases, generate inline code that directly compare the address of
3991    POINTER with the address of TARGET.  */
3992
3993 static void
3994 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3995 {
3996   gfc_actual_arglist *arg1;
3997   gfc_actual_arglist *arg2;
3998   gfc_se arg1se;
3999   gfc_se arg2se;
4000   tree tmp2;
4001   tree tmp;
4002   tree nonzero_charlen;
4003   tree nonzero_arraylen;
4004   gfc_ss *ss1, *ss2;
4005
4006   gfc_init_se (&arg1se, NULL);
4007   gfc_init_se (&arg2se, NULL);
4008   arg1 = expr->value.function.actual;
4009   arg2 = arg1->next;
4010   ss1 = gfc_walk_expr (arg1->expr);
4011
4012   if (!arg2->expr)
4013     {
4014       /* No optional target.  */
4015       if (ss1 == gfc_ss_terminator)
4016         {
4017           /* A pointer to a scalar.  */
4018           arg1se.want_pointer = 1;
4019           gfc_conv_expr (&arg1se, arg1->expr);
4020           tmp2 = arg1se.expr;
4021         }
4022       else
4023         {
4024           /* A pointer to an array.  */
4025           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4026           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4027         }
4028       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4029       gfc_add_block_to_block (&se->post, &arg1se.post);
4030       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4031                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4032       se->expr = tmp;
4033     }
4034   else
4035     {
4036       /* An optional target.  */
4037       ss2 = gfc_walk_expr (arg2->expr);
4038
4039       nonzero_charlen = NULL_TREE;
4040       if (arg1->expr->ts.type == BT_CHARACTER)
4041         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4042                                        arg1->expr->ts.cl->backend_decl,
4043                                        integer_zero_node);
4044
4045       if (ss1 == gfc_ss_terminator)
4046         {
4047           /* A pointer to a scalar.  */
4048           gcc_assert (ss2 == gfc_ss_terminator);
4049           arg1se.want_pointer = 1;
4050           gfc_conv_expr (&arg1se, arg1->expr);
4051           arg2se.want_pointer = 1;
4052           gfc_conv_expr (&arg2se, arg2->expr);
4053           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4054           gfc_add_block_to_block (&se->post, &arg1se.post);
4055           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4056                              arg1se.expr, arg2se.expr);
4057           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4058                               arg1se.expr, null_pointer_node);
4059           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4060                                   tmp, tmp2);
4061         }
4062       else
4063         {
4064           /* An array pointer of zero length is not associated if target is
4065              present.  */
4066           arg1se.descriptor_only = 1;
4067           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4068           tmp = gfc_conv_descriptor_stride (arg1se.expr,
4069                                             gfc_rank_cst[arg1->expr->rank - 1]);
4070           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4071                                           build_int_cst (TREE_TYPE (tmp), 0));
4072
4073           /* A pointer to an array, call library function _gfor_associated.  */
4074           gcc_assert (ss2 != gfc_ss_terminator);
4075           arg1se.want_pointer = 1;
4076           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4077
4078           arg2se.want_pointer = 1;
4079           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4080           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4081           gfc_add_block_to_block (&se->post, &arg2se.post);
4082           se->expr = build_call_expr (gfor_fndecl_associated, 2,
4083                                       arg1se.expr, arg2se.expr);
4084           se->expr = convert (boolean_type_node, se->expr);
4085           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4086                                   se->expr, nonzero_arraylen);
4087         }
4088
4089       /* If target is present zero character length pointers cannot
4090          be associated.  */
4091       if (nonzero_charlen != NULL_TREE)
4092         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4093                                 se->expr, nonzero_charlen);
4094     }
4095
4096   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4097 }
4098
4099
4100 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4101
4102 static void
4103 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4104 {
4105   tree args[2];
4106
4107   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4108   se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
4109   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4110 }
4111
4112
4113 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4114
4115 static void
4116 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4117 {
4118   tree arg, type;
4119
4120   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4121
4122   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4123   type = gfc_get_int_type (4);
4124   arg = build_fold_addr_expr (fold_convert (type, arg));
4125
4126   /* Convert it to the required type.  */
4127   type = gfc_typenode_for_spec (&expr->ts);
4128   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
4129   se->expr = fold_convert (type, se->expr);
4130 }
4131
4132
4133 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4134
4135 static void
4136 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4137 {
4138   gfc_actual_arglist *actual;
4139   tree args, type;
4140   gfc_se argse;
4141
4142   args = NULL_TREE;
4143   for (actual = expr->value.function.actual; actual; actual = actual->next)
4144     {
4145       gfc_init_se (&argse, se);
4146
4147       /* Pass a NULL pointer for an absent arg.  */
4148       if (actual->expr == NULL)
4149         argse.expr = null_pointer_node;
4150       else
4151         {
4152           gfc_typespec ts;
4153           gfc_clear_ts (&ts);
4154
4155           if (actual->expr->ts.kind != gfc_c_int_kind)
4156             {
4157               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4158               ts.type = BT_INTEGER;
4159               ts.kind = gfc_c_int_kind;
4160               gfc_convert_type (actual->expr, &ts, 2);
4161             }
4162           gfc_conv_expr_reference (&argse, actual->expr);
4163         }
4164
4165       gfc_add_block_to_block (&se->pre, &argse.pre);
4166       gfc_add_block_to_block (&se->post, &argse.post);
4167       args = gfc_chainon_list (args, argse.expr);
4168     }
4169
4170   /* Convert it to the required type.  */
4171   type = gfc_typenode_for_spec (&expr->ts);
4172   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
4173   se->expr = fold_convert (type, se->expr);
4174 }
4175
4176
4177 /* Generate code for TRIM (A) intrinsic function.  */
4178
4179 static void
4180 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4181 {
4182   tree var;
4183   tree len;
4184   tree addr;
4185   tree tmp;
4186   tree cond;
4187   tree fndecl;
4188   tree function;
4189   tree *args;
4190   unsigned int num_args;
4191
4192   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4193   args = (tree *) alloca (sizeof (tree) * num_args);
4194
4195   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4196   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4197   len = gfc_create_var (gfc_get_int_type (4), "len");
4198
4199   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4200   args[0] = build_fold_addr_expr (len);
4201   args[1] = addr;
4202
4203   if (expr->ts.kind == 1)
4204     function = gfor_fndecl_string_trim;
4205   else if (expr->ts.kind == 4)
4206     function = gfor_fndecl_string_trim_char4;
4207   else
4208     gcc_unreachable ();
4209
4210   fndecl = build_addr (function, current_function_decl);
4211   tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
4212                           num_args, args);
4213   gfc_add_expr_to_block (&se->pre, tmp);
4214
4215   /* Free the temporary afterwards, if necessary.  */
4216   cond = fold_build2 (GT_EXPR, boolean_type_node,
4217                       len, build_int_cst (TREE_TYPE (len), 0));
4218   tmp = gfc_call_free (var);
4219   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
4220   gfc_add_expr_to_block (&se->post, tmp);
4221
4222   se->expr = var;
4223   se->string_length = len;
4224 }
4225
4226
4227 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4228
4229 static void
4230 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4231 {
4232   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4233   tree type, cond, tmp, count, exit_label, n, max, largest;
4234   tree size;
4235   stmtblock_t block, body;
4236   int i;
4237
4238   /* We store in charsize the size of a character.  */
4239   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4240   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4241
4242   /* Get the arguments.  */
4243   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4244   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4245   src = args[1];
4246   ncopies = gfc_evaluate_now (args[2], &se->pre);
4247   ncopies_type = TREE_TYPE (ncopies);
4248
4249   /* Check that NCOPIES is not negative.  */
4250   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4251                       build_int_cst (ncopies_type, 0));
4252   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4253                            "Argument NCOPIES of REPEAT intrinsic is negative "
4254                            "(its value is %lld)",
4255                            fold_convert (long_integer_type_node, ncopies));
4256
4257   /* If the source length is zero, any non negative value of NCOPIES
4258      is valid, and nothing happens.  */
4259   n = gfc_create_var (ncopies_type, "ncopies");
4260   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4261                       build_int_cst (size_type_node, 0));
4262   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4263                      build_int_cst (ncopies_type, 0), ncopies);
4264   gfc_add_modify (&se->pre, n, tmp);
4265   ncopies = n;
4266
4267   /* Check that ncopies is not too large: ncopies should be less than
4268      (or equal to) MAX / slen, where MAX is the maximal integer of
4269      the gfc_charlen_type_node type.  If slen == 0, we need a special
4270      case to avoid the division by zero.  */
4271   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4272   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4273   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4274                      fold_convert (size_type_node, max), slen);
4275   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4276               ? size_type_node : ncopies_type;
4277   cond = fold_build2 (GT_EXPR, boolean_type_node,
4278                       fold_convert (largest, ncopies),
4279                       fold_convert (largest, max));
4280   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4281                      build_int_cst (size_type_node, 0));
4282   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4283                       cond);
4284   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4285                            "Argument NCOPIES of REPEAT intrinsic is too large");
4286
4287   /* Compute the destination length.  */
4288   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4289                       fold_convert (gfc_charlen_type_node, slen),
4290                       fold_convert (gfc_charlen_type_node, ncopies));
4291   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
4292   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4293
4294   /* Generate the code to do the repeat operation:
4295        for (i = 0; i < ncopies; i++)
4296          memmove (dest + (i * slen * size), src, slen*size);  */
4297   gfc_start_block (&block);
4298   count = gfc_create_var (ncopies_type, "count");
4299   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4300   exit_label = gfc_build_label_decl (NULL_TREE);
4301
4302   /* Start the loop body.  */
4303   gfc_start_block (&body);
4304
4305   /* Exit the loop if count >= ncopies.  */
4306   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4307   tmp = build1_v (GOTO_EXPR, exit_label);
4308   TREE_USED (exit_label) = 1;
4309   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4310                      build_empty_stmt ());
4311   gfc_add_expr_to_block (&body, tmp);
4312
4313   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4314   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4315                      fold_convert (gfc_charlen_type_node, slen),
4316                      fold_convert (gfc_charlen_type_node, count));
4317   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4318                      tmp, fold_convert (gfc_charlen_type_node, size));
4319   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4320                      fold_convert (pvoid_type_node, dest),
4321                      fold_convert (sizetype, tmp));
4322   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4323                          fold_build2 (MULT_EXPR, size_type_node, slen,
4324                                       fold_convert (size_type_node, size)));
4325   gfc_add_expr_to_block (&body, tmp);
4326
4327   /* Increment count.  */
4328   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4329                      count, build_int_cst (TREE_TYPE (count), 1));
4330   gfc_add_modify (&body, count, tmp);
4331
4332   /* Build the loop.  */
4333   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4334   gfc_add_expr_to_block (&block, tmp);
4335
4336   /* Add the exit label.  */
4337   tmp = build1_v (LABEL_EXPR, exit_label);
4338   gfc_add_expr_to_block (&block, tmp);
4339
4340   /* Finish the block.  */
4341   tmp = gfc_finish_block (&block);
4342   gfc_add_expr_to_block (&se->pre, tmp);
4343
4344   /* Set the result value.  */
4345   se->expr = dest;
4346   se->string_length = dlen;
4347 }
4348
4349
4350 /* Generate code for the IARGC intrinsic.  */
4351
4352 static void
4353 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4354 {
4355   tree tmp;
4356   tree fndecl;
4357   tree type;
4358
4359   /* Call the library function.  This always returns an INTEGER(4).  */
4360   fndecl = gfor_fndecl_iargc;
4361   tmp = build_call_expr (fndecl, 0);
4362
4363   /* Convert it to the required type.  */
4364   type = gfc_typenode_for_spec (&expr->ts);
4365   tmp = fold_convert (type, tmp);
4366
4367   se->expr = tmp;
4368 }
4369
4370
4371 /* The loc intrinsic returns the address of its argument as
4372    gfc_index_integer_kind integer.  */
4373
4374 static void
4375 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4376 {
4377   tree temp_var;
4378   gfc_expr *arg_expr;
4379   gfc_ss *ss;
4380
4381   gcc_assert (!se->ss);
4382
4383   arg_expr = expr->value.function.actual->expr;
4384   ss = gfc_walk_expr (arg_expr);
4385   if (ss == gfc_ss_terminator)
4386     gfc_conv_expr_reference (se, arg_expr);
4387   else
4388     gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
4389   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4390
4391   /* Create a temporary variable for loc return value.  Without this,
4392      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4393   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4394   gfc_add_modify (&se->pre, temp_var, se->expr);
4395   se->expr = temp_var;
4396 }
4397
4398 /* Generate code for an intrinsic function.  Some map directly to library
4399    calls, others get special handling.  In some cases the name of the function
4400    used depends on the type specifiers.  */
4401
4402 void
4403 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4404 {
4405   gfc_intrinsic_sym *isym;
4406   const char *name;
4407   int lib, kind;
4408   tree fndecl;
4409
4410   isym = expr->value.function.isym;
4411
4412   name = &expr->value.function.name[2];
4413
4414   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4415     {
4416       lib = gfc_is_intrinsic_libcall (expr);
4417       if (lib != 0)
4418         {
4419           if (lib == 1)
4420             se->ignore_optional = 1;
4421
4422           switch (expr->value.function.isym->id)
4423             {
4424             case GFC_ISYM_EOSHIFT:
4425             case GFC_ISYM_PACK:
4426             case GFC_ISYM_RESHAPE:
4427               /* For all of those the first argument specifies the type and the
4428                  third is optional.  */
4429               conv_generic_with_optional_char_arg (se, expr, 1, 3);
4430               break;
4431
4432             default:
4433               gfc_conv_intrinsic_funcall (se, expr);
4434               break;
4435             }
4436
4437           return;
4438         }
4439     }
4440
4441   switch (expr->value.function.isym->id)
4442     {
4443     case GFC_ISYM_NONE:
4444       gcc_unreachable ();
4445
4446     case GFC_ISYM_REPEAT:
4447       gfc_conv_intrinsic_repeat (se, expr);
4448       break;
4449
4450     case GFC_ISYM_TRIM:
4451       gfc_conv_intrinsic_trim (se, expr);
4452       break;
4453
4454     case GFC_ISYM_SC_KIND:
4455       gfc_conv_intrinsic_sc_kind (se, expr);
4456       break;
4457
4458     case GFC_ISYM_SI_KIND:
4459       gfc_conv_intrinsic_si_kind (se, expr);
4460       break;
4461
4462     case GFC_ISYM_SR_KIND:
4463       gfc_conv_intrinsic_sr_kind (se, expr);
4464       break;
4465
4466     case GFC_ISYM_EXPONENT:
4467       gfc_conv_intrinsic_exponent (se, expr);
4468       break;
4469
4470     case GFC_ISYM_SCAN:
4471       kind = expr->value.function.actual->expr->ts.kind;
4472       if (kind == 1)
4473        fndecl = gfor_fndecl_string_scan;
4474       else if (kind == 4)
4475        fndecl = gfor_fndecl_string_scan_char4;
4476       else
4477        gcc_unreachable ();
4478
4479       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4480       break;
4481
4482     case GFC_ISYM_VERIFY:
4483       kind = expr->value.function.actual->expr->ts.kind;
4484       if (kind == 1)
4485        fndecl = gfor_fndecl_string_verify;
4486       else if (kind == 4)
4487        fndecl = gfor_fndecl_string_verify_char4;
4488       else
4489        gcc_unreachable ();
4490
4491       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4492       break;
4493
4494     case GFC_ISYM_ALLOCATED:
4495       gfc_conv_allocated (se, expr);
4496       break;
4497
4498     case GFC_ISYM_ASSOCIATED:
4499       gfc_conv_associated(se, expr);
4500       break;
4501
4502     case GFC_ISYM_ABS:
4503       gfc_conv_intrinsic_abs (se, expr);
4504       break;
4505
4506     case GFC_ISYM_ADJUSTL:
4507       if (expr->ts.kind == 1)
4508        fndecl = gfor_fndecl_adjustl;
4509       else if (expr->ts.kind == 4)
4510        fndecl = gfor_fndecl_adjustl_char4;
4511       else
4512        gcc_unreachable ();
4513
4514       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4515       break;
4516
4517     case GFC_ISYM_ADJUSTR:
4518       if (expr->ts.kind == 1)
4519        fndecl = gfor_fndecl_adjustr;
4520       else if (expr->ts.kind == 4)
4521        fndecl = gfor_fndecl_adjustr_char4;
4522       else
4523        gcc_unreachable ();
4524
4525       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4526       break;
4527
4528     case GFC_ISYM_AIMAG:
4529       gfc_conv_intrinsic_imagpart (se, expr);
4530       break;
4531
4532     case GFC_ISYM_AINT:
4533       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4534       break;
4535
4536     case GFC_ISYM_ALL:
4537       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4538       break;
4539
4540     case GFC_ISYM_ANINT:
4541       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4542       break;
4543
4544     case GFC_ISYM_AND:
4545       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4546       break;
4547
4548     case GFC_ISYM_ANY:
4549       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4550       break;
4551
4552     case GFC_ISYM_BTEST:
4553       gfc_conv_intrinsic_btest (se, expr);
4554       break;
4555
4556     case GFC_ISYM_ACHAR:
4557     case GFC_ISYM_CHAR:
4558       gfc_conv_intrinsic_char (se, expr);
4559       break;
4560
4561     case GFC_ISYM_CONVERSION:
4562     case GFC_ISYM_REAL:
4563     case GFC_ISYM_LOGICAL:
4564     case GFC_ISYM_DBLE:
4565       gfc_conv_intrinsic_conversion (se, expr);
4566       break;
4567
4568       /* Integer conversions are handled separately to make sure we get the
4569          correct rounding mode.  */
4570     case GFC_ISYM_INT:
4571     case GFC_ISYM_INT2:
4572     case GFC_ISYM_INT8:
4573     case GFC_ISYM_LONG:
4574       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4575       break;
4576
4577     case GFC_ISYM_NINT:
4578       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4579       break;
4580
4581     case GFC_ISYM_CEILING:
4582       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4583       break;
4584
4585     case GFC_ISYM_FLOOR:
4586       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4587       break;
4588
4589     case GFC_ISYM_MOD:
4590       gfc_conv_intrinsic_mod (se, expr, 0);
4591       break;
4592
4593     case GFC_ISYM_MODULO:
4594       gfc_conv_intrinsic_mod (se, expr, 1);
4595       break;
4596
4597     case GFC_ISYM_CMPLX:
4598       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4599       break;
4600
4601     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4602       gfc_conv_intrinsic_iargc (se, expr);
4603       break;
4604
4605     case GFC_ISYM_COMPLEX:
4606       gfc_conv_intrinsic_cmplx (se, expr, 1);
4607       break;
4608
4609     case GFC_ISYM_CONJG:
4610       gfc_conv_intrinsic_conjg (se, expr);
4611       break;
4612
4613     case GFC_ISYM_COUNT:
4614       gfc_conv_intrinsic_count (se, expr);
4615       break;
4616
4617     case GFC_ISYM_CTIME:
4618       gfc_conv_intrinsic_ctime (se, expr);
4619       break;
4620
4621     case GFC_ISYM_DIM:
4622       gfc_conv_intrinsic_dim (se, expr);
4623       break;
4624
4625     case GFC_ISYM_DOT_PRODUCT:
4626       gfc_conv_intrinsic_dot_product (se, expr);
4627       break;
4628
4629     case GFC_ISYM_DPROD:
4630       gfc_conv_intrinsic_dprod (se, expr);
4631       break;
4632
4633     case GFC_ISYM_FDATE:
4634       gfc_conv_intrinsic_fdate (se, expr);
4635       break;
4636
4637     case GFC_ISYM_FRACTION:
4638       gfc_conv_intrinsic_fraction (se, expr);
4639       break;
4640
4641     case GFC_ISYM_IAND:
4642       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4643       break;
4644
4645     case GFC_ISYM_IBCLR:
4646       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4647       break;
4648
4649     case GFC_ISYM_IBITS:
4650       gfc_conv_intrinsic_ibits (se, expr);
4651       break;
4652
4653     case GFC_ISYM_IBSET:
4654       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4655       break;
4656
4657     case GFC_ISYM_IACHAR:
4658     case GFC_ISYM_ICHAR:
4659       /* We assume ASCII character sequence.  */
4660       gfc_conv_intrinsic_ichar (se, expr);
4661       break;
4662
4663     case GFC_ISYM_IARGC:
4664       gfc_conv_intrinsic_iargc (se, expr);
4665       break;
4666
4667     case GFC_ISYM_IEOR:
4668       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4669       break;
4670
4671     case GFC_ISYM_INDEX:
4672       kind = expr->value.function.actual->expr->ts.kind;
4673       if (kind == 1)
4674        fndecl = gfor_fndecl_string_index;
4675       else if (kind == 4)
4676        fndecl = gfor_fndecl_string_index_char4;
4677       else
4678        gcc_unreachable ();
4679
4680       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4681       break;
4682
4683     case GFC_ISYM_IOR:
4684       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4685       break;
4686
4687     case GFC_ISYM_IS_IOSTAT_END:
4688       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4689       break;
4690
4691     case GFC_ISYM_IS_IOSTAT_EOR:
4692       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4693       break;
4694
4695     case GFC_ISYM_ISNAN:
4696       gfc_conv_intrinsic_isnan (se, expr);
4697       break;
4698
4699     case GFC_ISYM_LSHIFT:
4700       gfc_conv_intrinsic_rlshift (se, expr, 0);
4701       break;
4702
4703     case GFC_ISYM_RSHIFT:
4704       gfc_conv_intrinsic_rlshift (se, expr, 1);
4705       break;
4706
4707     case GFC_ISYM_ISHFT:
4708       gfc_conv_intrinsic_ishft (se, expr);
4709       break;
4710
4711     case GFC_ISYM_ISHFTC:
4712       gfc_conv_intrinsic_ishftc (se, expr);
4713       break;
4714
4715     case GFC_ISYM_LEADZ:
4716       gfc_conv_intrinsic_leadz (se, expr);
4717       break;
4718
4719     case GFC_ISYM_TRAILZ:
4720       gfc_conv_intrinsic_trailz (se, expr);
4721       break;
4722
4723     case GFC_ISYM_LBOUND:
4724       gfc_conv_intrinsic_bound (se, expr, 0);
4725       break;
4726
4727     case GFC_ISYM_TRANSPOSE:
4728       if (se->ss && se->ss->useflags)
4729         {
4730           gfc_conv_tmp_array_ref (se);
4731           gfc_advance_se_ss_chain (se);
4732         }
4733       else
4734         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4735       break;
4736
4737     case GFC_ISYM_LEN:
4738       gfc_conv_intrinsic_len (se, expr);
4739       break;
4740
4741     case GFC_ISYM_LEN_TRIM:
4742       gfc_conv_intrinsic_len_trim (se, expr);
4743       break;
4744
4745     case GFC_ISYM_LGE:
4746       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4747       break;
4748
4749     case GFC_ISYM_LGT:
4750       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4751       break;
4752
4753     case GFC_ISYM_LLE:
4754       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4755       break;
4756
4757     case GFC_ISYM_LLT:
4758       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4759       break;
4760
4761     case GFC_ISYM_MAX:
4762       if (expr->ts.type == BT_CHARACTER)
4763         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4764       else
4765         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4766       break;
4767
4768     case GFC_ISYM_MAXLOC:
4769       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4770       break;
4771
4772     case GFC_ISYM_MAXVAL:
4773       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4774       break;
4775
4776     case GFC_ISYM_MERGE:
4777       gfc_conv_intrinsic_merge (se, expr);
4778       break;
4779
4780     case GFC_ISYM_MIN:
4781       if (expr->ts.type == BT_CHARACTER)
4782         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4783       else
4784         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4785       break;
4786
4787     case GFC_ISYM_MINLOC:
4788       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4789       break;
4790
4791     case GFC_ISYM_MINVAL:
4792       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4793       break;
4794
4795     case GFC_ISYM_NEAREST:
4796       gfc_conv_intrinsic_nearest (se, expr);
4797       break;
4798
4799     case GFC_ISYM_NOT:
4800       gfc_conv_intrinsic_not (se, expr);
4801       break;
4802
4803     case GFC_ISYM_OR:
4804       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4805       break;
4806
4807     case GFC_ISYM_PRESENT:
4808       gfc_conv_intrinsic_present (se, expr);
4809       break;
4810
4811     case GFC_ISYM_PRODUCT:
4812       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4813       break;
4814
4815     case GFC_ISYM_RRSPACING:
4816       gfc_conv_intrinsic_rrspacing (se, expr);
4817       break;
4818
4819     case GFC_ISYM_SET_EXPONENT:
4820       gfc_conv_intrinsic_set_exponent (se, expr);
4821       break;
4822
4823     case GFC_ISYM_SCALE:
4824       gfc_conv_intrinsic_scale (se, expr);
4825       break;
4826
4827     case GFC_ISYM_SIGN:
4828       gfc_conv_intrinsic_sign (se, expr);
4829       break;
4830
4831     case GFC_ISYM_SIZE:
4832       gfc_conv_intrinsic_size (se, expr);
4833       break;
4834
4835     case GFC_ISYM_SIZEOF:
4836       gfc_conv_intrinsic_sizeof (se, expr);
4837       break;
4838
4839     case GFC_ISYM_SPACING:
4840       gfc_conv_intrinsic_spacing (se, expr);
4841       break;
4842
4843     case GFC_ISYM_SUM:
4844       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4845       break;
4846
4847     case GFC_ISYM_TRANSFER:
4848       if (se->ss && se->ss->useflags)
4849         {
4850           /* Access the previously obtained result.  */
4851           gfc_conv_tmp_array_ref (se);
4852           gfc_advance_se_ss_chain (se);
4853         }
4854       else
4855         gfc_conv_intrinsic_transfer (se, expr);
4856       break;
4857
4858     case GFC_ISYM_TTYNAM:
4859       gfc_conv_intrinsic_ttynam (se, expr);
4860       break;
4861
4862     case GFC_ISYM_UBOUND:
4863       gfc_conv_intrinsic_bound (se, expr, 1);
4864       break;
4865
4866     case GFC_ISYM_XOR:
4867       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4868       break;
4869
4870     case GFC_ISYM_LOC:
4871       gfc_conv_intrinsic_loc (se, expr);
4872       break;
4873
4874     case GFC_ISYM_ACCESS:
4875     case GFC_ISYM_CHDIR:
4876     case GFC_ISYM_CHMOD:
4877     case GFC_ISYM_DTIME:
4878     case GFC_ISYM_ETIME:
4879     case GFC_ISYM_FGET:
4880     case GFC_ISYM_FGETC:
4881     case GFC_ISYM_FNUM:
4882     case GFC_ISYM_FPUT:
4883     case GFC_ISYM_FPUTC:
4884     case GFC_ISYM_FSTAT:
4885     case GFC_ISYM_FTELL:
4886     case GFC_ISYM_GETCWD:
4887     case GFC_ISYM_GETGID:
4888     case GFC_ISYM_GETPID:
4889     case GFC_ISYM_GETUID:
4890     case GFC_ISYM_HOSTNM:
4891     case GFC_ISYM_KILL:
4892     case GFC_ISYM_IERRNO:
4893     case GFC_ISYM_IRAND:
4894     case GFC_ISYM_ISATTY:
4895     case GFC_ISYM_LINK:
4896     case GFC_ISYM_LSTAT:
4897     case GFC_ISYM_MALLOC:
4898     case GFC_ISYM_MATMUL:
4899     case GFC_ISYM_MCLOCK:
4900     case GFC_ISYM_MCLOCK8:
4901     case GFC_ISYM_RAND:
4902     case GFC_ISYM_RENAME:
4903     case GFC_ISYM_SECOND:
4904     case GFC_ISYM_SECNDS:
4905     case GFC_ISYM_SIGNAL:
4906     case GFC_ISYM_STAT:
4907     case GFC_ISYM_SYMLNK:
4908     case GFC_ISYM_SYSTEM:
4909     case GFC_ISYM_TIME:
4910     case GFC_ISYM_TIME8:
4911     case GFC_ISYM_UMASK:
4912     case GFC_ISYM_UNLINK:
4913       gfc_conv_intrinsic_funcall (se, expr);
4914       break;
4915
4916     case GFC_ISYM_EOSHIFT:
4917     case GFC_ISYM_PACK:
4918     case GFC_ISYM_RESHAPE:
4919       /* For those, expr->rank should always be >0 and thus the if above the
4920          switch should have matched.  */
4921       gcc_unreachable ();
4922       break;
4923
4924     default:
4925       gfc_conv_intrinsic_lib_function (se, expr);
4926       break;
4927     }
4928 }
4929
4930
4931 /* This generates code to execute before entering the scalarization loop.
4932    Currently does nothing.  */
4933
4934 void
4935 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4936 {
4937   switch (ss->expr->value.function.isym->id)
4938     {
4939     case GFC_ISYM_UBOUND:
4940     case GFC_ISYM_LBOUND:
4941       break;
4942
4943     default:
4944       gcc_unreachable ();
4945     }
4946 }
4947
4948
4949 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4950    inside the scalarization loop.  */
4951
4952 static gfc_ss *
4953 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4954 {
4955   gfc_ss *newss;
4956
4957   /* The two argument version returns a scalar.  */
4958   if (expr->value.function.actual->next->expr)
4959     return ss;
4960
4961   newss = gfc_get_ss ();
4962   newss->type = GFC_SS_INTRINSIC;
4963   newss->expr = expr;
4964   newss->next = ss;
4965   newss->data.info.dimen = 1;
4966
4967   return newss;
4968 }
4969
4970
4971 /* Walk an intrinsic array libcall.  */
4972
4973 static gfc_ss *
4974 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4975 {
4976   gfc_ss *newss;
4977
4978   gcc_assert (expr->rank > 0);
4979
4980   newss = gfc_get_ss ();
4981   newss->type = GFC_SS_FUNCTION;
4982   newss->expr = expr;
4983   newss->next = ss;
4984   newss->data.info.dimen = expr->rank;
4985
4986   return newss;
4987 }
4988
4989
4990 /* Returns nonzero if the specified intrinsic function call maps directly to
4991    an external library call.  Should only be used for functions that return
4992    arrays.  */
4993
4994 int
4995 gfc_is_intrinsic_libcall (gfc_expr * expr)
4996 {
4997   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4998   gcc_assert (expr->rank > 0);
4999
5000   switch (expr->value.function.isym->id)
5001     {
5002     case GFC_ISYM_ALL:
5003     case GFC_ISYM_ANY:
5004     case GFC_ISYM_COUNT:
5005     case GFC_ISYM_MATMUL:
5006     case GFC_ISYM_MAXLOC:
5007     case GFC_ISYM_MAXVAL:
5008     case GFC_ISYM_MINLOC:
5009     case GFC_ISYM_MINVAL:
5010     case GFC_ISYM_PRODUCT:
5011     case GFC_ISYM_SUM:
5012     case GFC_ISYM_SHAPE:
5013     case GFC_ISYM_SPREAD:
5014     case GFC_ISYM_TRANSPOSE:
5015       /* Ignore absent optional parameters.  */
5016       return 1;
5017
5018     case GFC_ISYM_RESHAPE:
5019     case GFC_ISYM_CSHIFT:
5020     case GFC_ISYM_EOSHIFT:
5021     case GFC_ISYM_PACK:
5022     case GFC_ISYM_UNPACK:
5023       /* Pass absent optional parameters.  */
5024       return 2;
5025
5026     default:
5027       return 0;
5028     }
5029 }
5030
5031 /* Walk an intrinsic function.  */
5032 gfc_ss *
5033 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5034                              gfc_intrinsic_sym * isym)
5035 {
5036   gcc_assert (isym);
5037
5038   if (isym->elemental)
5039     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5040
5041   if (expr->rank == 0)
5042     return ss;
5043
5044   if (gfc_is_intrinsic_libcall (expr))
5045     return gfc_walk_intrinsic_libfunc (ss, expr);
5046
5047   /* Special cases.  */
5048   switch (isym->id)
5049     {
5050     case GFC_ISYM_LBOUND:
5051     case GFC_ISYM_UBOUND:
5052       return gfc_walk_intrinsic_bound (ss, expr);
5053
5054     case GFC_ISYM_TRANSFER:
5055       return gfc_walk_intrinsic_libfunc (ss, expr);
5056
5057     default:
5058       /* This probably meant someone forgot to add an intrinsic to the above
5059          list(s) when they implemented it, or something's gone horribly
5060          wrong.  */
5061       gcc_unreachable ();
5062     }
5063 }
5064
5065 #include "gt-fortran-trans-intrinsic.h"