gcc/fortran/trans-intrinsic.c

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