gcc/fortran/trans-intrinsic.c

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