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