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