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