gcc/fortran/trans-intrinsic.c

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