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