gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct 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, 0);
 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, 0);
 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
 750 /* If bounds-checking is enabled, create code to verify at runtime that the
 751    string lengths for both expressions are the same (needed for e.g. MERGE).
 752    If bounds-checking is not enabled, does nothing.  */
 753
 754 void
 755 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
 756                              tree a, tree b, stmtblock_t* target)
 757 {
 758   tree cond;
 759   tree name;
 760
 761   /* If bounds-checking is disabled, do nothing.  */
 762   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
 763     return;
 764
 765   /* Compare the two string lengths.  */
 766   cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
 767
 768   /* Output the runtime-check.  */
 769   name = gfc_build_cstring_const (intr_name);
 770   name = gfc_build_addr_expr (pchar_type_node, name);
 771   gfc_trans_runtime_check (true, false, cond, target, where,
 772                            "Unequal character lengths (%ld/%ld) in %s",
 773                            fold_convert (long_integer_type_node, a),
 774                            fold_convert (long_integer_type_node, b), name);
 775 }
 776
 777
 778 /* The EXPONENT(s) intrinsic function is translated into
 779        int ret;
 780        frexp (s, &ret);
 781        return ret;
 782  */
 783
 784 static void
 785 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 786 {
 787   tree arg, type, res, tmp;
 788   int frexp;
 789
 790   switch (expr->value.function.actual->expr->ts.kind)
 791     {
 792     case 4:
 793       frexp = BUILT_IN_FREXPF;
 794       break;
 795     case 8:
 796       frexp = BUILT_IN_FREXP;
 797       break;
 798     case 10:
 799     case 16:
 800       frexp = BUILT_IN_FREXPL;
 801       break;
 802     default:
 803       gcc_unreachable ();
 804     }
 805
 806   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 807
 808   res = gfc_create_var (integer_type_node, NULL);
 809   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
 810                          gfc_build_addr_expr (NULL_TREE, res));
 811   gfc_add_expr_to_block (&se->pre, tmp);
 812
 813   type = gfc_typenode_for_spec (&expr->ts);
 814   se->expr = fold_convert (type, res);
 815 }
 816
 817 /* Evaluate a single upper or lower bound.  */
 818 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 819
 820 static void
 821 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 822 {
 823   gfc_actual_arglist *arg;
 824   gfc_actual_arglist *arg2;
 825   tree desc;
 826   tree type;
 827   tree bound;
 828   tree tmp;
 829   tree cond, cond1, cond2, cond3, cond4, size;
 830   tree ubound;
 831   tree lbound;
 832   gfc_se argse;
 833   gfc_ss *ss;
 834   gfc_array_spec * as;
 835   gfc_ref *ref;
 836
 837   arg = expr->value.function.actual;
 838   arg2 = arg->next;
 839
 840   if (se->ss)
 841     {
 842       /* Create an implicit second parameter from the loop variable.  */
 843       gcc_assert (!arg2->expr);
 844       gcc_assert (se->loop->dimen == 1);
 845       gcc_assert (se->ss->expr == expr);
 846       gfc_advance_se_ss_chain (se);
 847       bound = se->loop->loopvar[0];
 848       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 849                            se->loop->from[0]);
 850     }
 851   else
 852     {
 853       /* use the passed argument.  */
 854       gcc_assert (arg->next->expr);
 855       gfc_init_se (&argse, NULL);
 856       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 857       gfc_add_block_to_block (&se->pre, &argse.pre);
 858       bound = argse.expr;
 859       /* Convert from one based to zero based.  */
 860       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 861                            gfc_index_one_node);
 862     }
 863
 864   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 865   /* Get a descriptor for the first parameter.  */
 866   ss = gfc_walk_expr (arg->expr);
 867   gcc_assert (ss != gfc_ss_terminator);
 868   gfc_init_se (&argse, NULL);
 869   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 870   gfc_add_block_to_block (&se->pre, &argse.pre);
 871   gfc_add_block_to_block (&se->post, &argse.post);
 872
 873   desc = argse.expr;
 874
 875   if (INTEGER_CST_P (bound))
 876     {
 877       int hi, low;
 878
 879       hi = TREE_INT_CST_HIGH (bound);
 880       low = TREE_INT_CST_LOW (bound);
 881       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 882         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 883                    "dimension index", upper ? "UBOUND" : "LBOUND",
 884                    &expr->where);
 885     }
 886   else
 887     {
 888       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 889         {
 890           bound = gfc_evaluate_now (bound, &se->pre);
 891           cond = fold_build2 (LT_EXPR, boolean_type_node,
 892                               bound, build_int_cst (TREE_TYPE (bound), 0));
 893           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 894           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 895           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 896           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
 897                                    gfc_msg_fault);
 898         }
 899     }
 900
 901   ubound = gfc_conv_descriptor_ubound (desc, bound);
 902   lbound = gfc_conv_descriptor_lbound (desc, bound);
 903
 904   /* Follow any component references.  */
 905   if (arg->expr->expr_type == EXPR_VARIABLE
 906       || arg->expr->expr_type == EXPR_CONSTANT)
 907     {
 908       as = arg->expr->symtree->n.sym->as;
 909       for (ref = arg->expr->ref; ref; ref = ref->next)
 910         {
 911           switch (ref->type)
 912             {
 913             case REF_COMPONENT:
 914               as = ref->u.c.component->as;
 915               continue;
 916
 917             case REF_SUBSTRING:
 918               continue;
 919
 920             case REF_ARRAY:
 921               {
 922                 switch (ref->u.ar.type)
 923                   {
 924                   case AR_ELEMENT:
 925                   case AR_SECTION:
 926                   case AR_UNKNOWN:
 927                     as = NULL;
 928                     continue;
 929
 930                   case AR_FULL:
 931                     break;
 932                   }
 933                 break;
 934               }
 935             }
 936         }
 937     }
 938   else
 939     as = NULL;
 940
 941   /* 13.14.53: Result value for LBOUND
 942
 943      Case (i): For an array section or for an array expression other than a
 944                whole array or array structure component, LBOUND(ARRAY, DIM)
 945                has the value 1.  For a whole array or array structure
 946                component, LBOUND(ARRAY, DIM) has the value:
 947                  (a) equal to the lower bound for subscript DIM of ARRAY if
 948                      dimension DIM of ARRAY does not have extent zero
 949                      or if ARRAY is an assumed-size array of rank DIM,
 950               or (b) 1 otherwise.
 951
 952      13.14.113: Result value for UBOUND
 953
 954      Case (i): For an array section or for an array expression other than a
 955                whole array or array structure component, UBOUND(ARRAY, DIM)
 956                has the value equal to the number of elements in the given
 957                dimension; otherwise, it has a value equal to the upper bound
 958                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 959                not have size zero and has value zero if dimension DIM has
 960                size zero.  */
 961
 962   if (as)
 963     {
 964       tree stride = gfc_conv_descriptor_stride (desc, bound);
 965
 966       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 967       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 968
 969       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 970                            gfc_index_zero_node);
 971       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 972
 973       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 974                            gfc_index_zero_node);
 975
 976       if (upper)
 977         {
 978           tree cond5;
 979           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 980
 981           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
 982           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
 983
 984           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
 985
 986           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 987                                   ubound, gfc_index_zero_node);
 988         }
 989       else
 990         {
 991           if (as->type == AS_ASSUMED_SIZE)
 992             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 993                                 build_int_cst (TREE_TYPE (bound),
 994                                                arg->expr->rank - 1));
 995           else
 996             cond = boolean_false_node;
 997
 998           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 999           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1000
1001           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1002                                   lbound, gfc_index_one_node);
1003         }
1004     }
1005   else
1006     {
1007       if (upper)
1008         {
1009           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1010           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1011                                   gfc_index_one_node);
1012           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1013                                   gfc_index_zero_node);
1014         }
1015       else
1016         se->expr = gfc_index_one_node;
1017     }
1018
1019   type = gfc_typenode_for_spec (&expr->ts);
1020   se->expr = convert (type, se->expr);
1021 }
1022
1023
1024 static void
1025 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1026 {
1027   tree arg;
1028   int n;
1029
1030   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1031
1032   switch (expr->value.function.actual->expr->ts.type)
1033     {
1034     case BT_INTEGER:
1035     case BT_REAL:
1036       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1037       break;
1038
1039     case BT_COMPLEX:
1040       switch (expr->ts.kind)
1041         {
1042         case 4:
1043           n = BUILT_IN_CABSF;
1044           break;
1045         case 8:
1046           n = BUILT_IN_CABS;
1047           break;
1048         case 10:
1049         case 16:
1050           n = BUILT_IN_CABSL;
1051           break;
1052         default:
1053           gcc_unreachable ();
1054         }
1055       se->expr = build_call_expr (built_in_decls[n], 1, arg);
1056       break;
1057
1058     default:
1059       gcc_unreachable ();
1060     }
1061 }
1062
1063
1064 /* Create a complex value from one or two real components.  */
1065
1066 static void
1067 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1068 {
1069   tree real;
1070   tree imag;
1071   tree type;
1072   tree *args;
1073   unsigned int num_args;
1074
1075   num_args = gfc_intrinsic_argument_list_length (expr);
1076   args = (tree *) alloca (sizeof (tree) * num_args);
1077
1078   type = gfc_typenode_for_spec (&expr->ts);
1079   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1080   real = convert (TREE_TYPE (type), args[0]);
1081   if (both)
1082     imag = convert (TREE_TYPE (type), args[1]);
1083   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1084     {
1085       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1086                           args[0]);
1087       imag = convert (TREE_TYPE (type), imag);
1088     }
1089   else
1090     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1091
1092   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1093 }
1094
1095 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1096                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1097 /* TODO: MOD(x, 0)  */
1098
1099 static void
1100 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1101 {
1102   tree type;
1103   tree itype;
1104   tree tmp;
1105   tree test;
1106   tree test2;
1107   mpfr_t huge;
1108   int n, ikind;
1109   tree args[2];
1110
1111   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1112
1113   switch (expr->ts.type)
1114     {
1115     case BT_INTEGER:
1116       /* Integer case is easy, we've got a builtin op.  */
1117       type = TREE_TYPE (args[0]);
1118
1119       if (modulo)
1120        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1121       else
1122        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1123       break;
1124
1125     case BT_REAL:
1126       n = END_BUILTINS;
1127       /* Check if we have a builtin fmod.  */
1128       switch (expr->ts.kind)
1129         {
1130         case 4:
1131           n = BUILT_IN_FMODF;
1132           break;
1133
1134         case 8:
1135           n = BUILT_IN_FMOD;
1136           break;
1137
1138         case 10:
1139         case 16:
1140           n = BUILT_IN_FMODL;
1141           break;
1142
1143         default:
1144           break;
1145         }
1146
1147       /* Use it if it exists.  */
1148       if (n != END_BUILTINS)
1149         {
1150           tmp = build_addr (built_in_decls[n], current_function_decl);
1151           se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1152                                        tmp, 2, args);
1153           if (modulo == 0)
1154             return;
1155         }
1156
1157       type = TREE_TYPE (args[0]);
1158
1159       args[0] = gfc_evaluate_now (args[0], &se->pre);
1160       args[1] = gfc_evaluate_now (args[1], &se->pre);
1161
1162       /* Definition:
1163          modulo = arg - floor (arg/arg2) * arg2, so
1164                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1165          where
1166           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1167          thereby avoiding another division and retaining the accuracy
1168          of the builtin function.  */
1169       if (n != END_BUILTINS && modulo)
1170         {
1171           tree zero = gfc_build_const (type, integer_zero_node);
1172           tmp = gfc_evaluate_now (se->expr, &se->pre);
1173           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1174           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1175           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1176           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1177           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1178           test = gfc_evaluate_now (test, &se->pre);
1179           se->expr = fold_build3 (COND_EXPR, type, test,
1180                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1181                                   tmp);
1182           return;
1183         }
1184
1185       /* If we do not have a built_in fmod, the calculation is going to
1186          have to be done longhand.  */
1187       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1188
1189       /* Test if the value is too large to handle sensibly.  */
1190       gfc_set_model_kind (expr->ts.kind);
1191       mpfr_init (huge);
1192       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1193       ikind = expr->ts.kind;
1194       if (n < 0)
1195         {
1196           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1197           ikind = gfc_max_integer_kind;
1198         }
1199       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1200       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1201       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1202
1203       mpfr_neg (huge, huge, GFC_RND_MODE);
1204       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1205       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1206       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1207
1208       itype = gfc_get_int_type (ikind);
1209       if (modulo)
1210        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1211       else
1212        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1213       tmp = convert (type, tmp);
1214       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1215       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1216       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1217       mpfr_clear (huge);
1218       break;
1219
1220     default:
1221       gcc_unreachable ();
1222     }
1223 }
1224
1225 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1226
1227 static void
1228 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1229 {
1230   tree val;
1231   tree tmp;
1232   tree type;
1233   tree zero;
1234   tree args[2];
1235
1236   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1237   type = TREE_TYPE (args[0]);
1238
1239   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1240   val = gfc_evaluate_now (val, &se->pre);
1241
1242   zero = gfc_build_const (type, integer_zero_node);
1243   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1244   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1245 }
1246
1247
1248 /* SIGN(A, B) is absolute value of A times sign of B.
1249    The real value versions use library functions to ensure the correct
1250    handling of negative zero.  Integer case implemented as:
1251    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1252   */
1253
1254 static void
1255 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1256 {
1257   tree tmp;
1258   tree type;
1259   tree args[2];
1260
1261   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1262   if (expr->ts.type == BT_REAL)
1263     {
1264       switch (expr->ts.kind)
1265         {
1266         case 4:
1267           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1268           break;
1269         case 8:
1270           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1271           break;
1272         case 10:
1273         case 16:
1274           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1275           break;
1276         default:
1277           gcc_unreachable ();
1278         }
1279       se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1280       return;
1281     }
1282
1283   /* Having excluded floating point types, we know we are now dealing
1284      with signed integer types.  */
1285   type = TREE_TYPE (args[0]);
1286
1287   /* Args[0] is used multiple times below.  */
1288   args[0] = gfc_evaluate_now (args[0], &se->pre);
1289
1290   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1291      the signs of A and B are the same, and of all ones if they differ.  */
1292   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1293   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1294                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1295   tmp = gfc_evaluate_now (tmp, &se->pre);
1296
1297   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1298      is all ones (i.e. -1).  */
1299   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1300                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1301                           tmp);
1302 }
1303
1304
1305 /* Test for the presence of an optional argument.  */
1306
1307 static void
1308 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1309 {
1310   gfc_expr *arg;
1311
1312   arg = expr->value.function.actual->expr;
1313   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1314   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1315   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1316 }
1317
1318
1319 /* Calculate the double precision product of two single precision values.  */
1320
1321 static void
1322 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1323 {
1324   tree type;
1325   tree args[2];
1326
1327   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1328
1329   /* Convert the args to double precision before multiplying.  */
1330   type = gfc_typenode_for_spec (&expr->ts);
1331   args[0] = convert (type, args[0]);
1332   args[1] = convert (type, args[1]);
1333   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1334 }
1335
1336
1337 /* Return a length one character string containing an ascii character.  */
1338
1339 static void
1340 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1341 {
1342   tree arg[2];
1343   tree var;
1344   tree type;
1345   unsigned int num_args;
1346
1347   num_args = gfc_intrinsic_argument_list_length (expr);
1348   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1349
1350   type = gfc_get_char_type (expr->ts.kind);
1351   var = gfc_create_var (type, "char");
1352
1353   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1354   gfc_add_modify (&se->pre, var, arg[0]);
1355   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1356   se->string_length = integer_one_node;
1357 }
1358
1359
1360 static void
1361 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1362 {
1363   tree var;
1364   tree len;
1365   tree tmp;
1366   tree cond;
1367   tree fndecl;
1368   tree *args;
1369   unsigned int num_args;
1370
1371   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1372   args = (tree *) alloca (sizeof (tree) * num_args);
1373
1374   var = gfc_create_var (pchar_type_node, "pstr");
1375   len = gfc_create_var (gfc_get_int_type (8), "len");
1376
1377   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1378   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1379   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1380
1381   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1382   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1383                           fndecl, num_args, args);
1384   gfc_add_expr_to_block (&se->pre, tmp);
1385
1386   /* Free the temporary afterwards, if necessary.  */
1387   cond = fold_build2 (GT_EXPR, boolean_type_node,
1388                       len, build_int_cst (TREE_TYPE (len), 0));
1389   tmp = gfc_call_free (var);
1390   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1391   gfc_add_expr_to_block (&se->post, tmp);
1392
1393   se->expr = var;
1394   se->string_length = len;
1395 }
1396
1397
1398 static void
1399 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1400 {
1401   tree var;
1402   tree len;
1403   tree tmp;
1404   tree cond;
1405   tree fndecl;
1406   tree *args;
1407   unsigned int num_args;
1408
1409   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1410   args = (tree *) alloca (sizeof (tree) * num_args);
1411
1412   var = gfc_create_var (pchar_type_node, "pstr");
1413   len = gfc_create_var (gfc_get_int_type (4), "len");
1414
1415   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1417   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1418
1419   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1420   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1421                           fndecl, num_args, args);
1422   gfc_add_expr_to_block (&se->pre, tmp);
1423
1424   /* Free the temporary afterwards, if necessary.  */
1425   cond = fold_build2 (GT_EXPR, boolean_type_node,
1426                       len, build_int_cst (TREE_TYPE (len), 0));
1427   tmp = gfc_call_free (var);
1428   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429   gfc_add_expr_to_block (&se->post, tmp);
1430
1431   se->expr = var;
1432   se->string_length = len;
1433 }
1434
1435
1436 /* Return a character string containing the tty name.  */
1437
1438 static void
1439 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1440 {
1441   tree var;
1442   tree len;
1443   tree tmp;
1444   tree cond;
1445   tree fndecl;
1446   tree *args;
1447   unsigned int num_args;
1448
1449   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1450   args = (tree *) alloca (sizeof (tree) * num_args);
1451
1452   var = gfc_create_var (pchar_type_node, "pstr");
1453   len = gfc_create_var (gfc_get_int_type (4), "len");
1454
1455   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1456   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1457   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1458
1459   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1460   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1461                           fndecl, num_args, args);
1462   gfc_add_expr_to_block (&se->pre, tmp);
1463
1464   /* Free the temporary afterwards, if necessary.  */
1465   cond = fold_build2 (GT_EXPR, boolean_type_node,
1466                       len, build_int_cst (TREE_TYPE (len), 0));
1467   tmp = gfc_call_free (var);
1468   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1469   gfc_add_expr_to_block (&se->post, tmp);
1470
1471   se->expr = var;
1472   se->string_length = len;
1473 }
1474
1475
1476 /* Get the minimum/maximum value of all the parameters.
1477     minmax (a1, a2, a3, ...)
1478     {
1479       mvar = a1;
1480       if (a2 .op. mvar || isnan(mvar))
1481         mvar = a2;
1482       if (a3 .op. mvar || isnan(mvar))
1483         mvar = a3;
1484       ...
1485       return mvar
1486     }
1487  */
1488
1489 /* TODO: Mismatching types can occur when specific names are used.
1490    These should be handled during resolution.  */
1491 static void
1492 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
1493 {
1494   tree tmp;
1495   tree mvar;
1496   tree val;
1497   tree thencase;
1498   tree *args;
1499   tree type;
1500   gfc_actual_arglist *argexpr;
1501   unsigned int i, nargs;
1502
1503   nargs = gfc_intrinsic_argument_list_length (expr);
1504   args = (tree *) alloca (sizeof (tree) * nargs);
1505
1506   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1507   type = gfc_typenode_for_spec (&expr->ts);
1508
1509   argexpr = expr->value.function.actual;
1510   if (TREE_TYPE (args[0]) != type)
1511     args[0] = convert (type, args[0]);
1512   /* Only evaluate the argument once.  */
1513   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1514     args[0] = gfc_evaluate_now (args[0], &se->pre);
1515
1516   mvar = gfc_create_var (type, "M");
1517   gfc_add_modify (&se->pre, mvar, args[0]);
1518   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1519     {
1520       tree cond, isnan;
1521
1522       val = args[i];
1523
1524       /* Handle absent optional arguments by ignoring the comparison.  */
1525       if (argexpr->expr->expr_type == EXPR_VARIABLE
1526           && argexpr->expr->symtree->n.sym->attr.optional
1527           && TREE_CODE (val) == INDIRECT_REF)
1528         cond = fold_build2
1529                  (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1530                   build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1531       else
1532       {
1533         cond = NULL_TREE;
1534
1535         /* Only evaluate the argument once.  */
1536         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1537           val = gfc_evaluate_now (val, &se->pre);
1538       }
1539
1540       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1541
1542       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1543
1544       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1545          __builtin_isnan might be made dependent on that module being loaded,
1546          to help performance of programs that don't rely on IEEE semantics.  */
1547       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1548         {
1549           isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1550           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1551                              fold_convert (boolean_type_node, isnan));
1552         }
1553       tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
1554
1555       if (cond != NULL_TREE)
1556         tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1557
1558       gfc_add_expr_to_block (&se->pre, tmp);
1559       argexpr = argexpr->next;
1560     }
1561   se->expr = mvar;
1562 }
1563
1564
1565 /* Generate library calls for MIN and MAX intrinsics for character
1566    variables.  */
1567 static void
1568 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1569 {
1570   tree *args;
1571   tree var, len, fndecl, tmp, cond, function;
1572   unsigned int nargs;
1573
1574   nargs = gfc_intrinsic_argument_list_length (expr);
1575   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1576   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1577
1578   /* Create the result variables.  */
1579   len = gfc_create_var (gfc_charlen_type_node, "len");
1580   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1581   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1582   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1583   args[2] = build_int_cst (NULL_TREE, op);
1584   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1585
1586   if (expr->ts.kind == 1)
1587     function = gfor_fndecl_string_minmax;
1588   else if (expr->ts.kind == 4)
1589     function = gfor_fndecl_string_minmax_char4;
1590   else
1591     gcc_unreachable ();
1592
1593   /* Make the function call.  */
1594   fndecl = build_addr (function, current_function_decl);
1595   tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
1596                           nargs + 4, args);
1597   gfc_add_expr_to_block (&se->pre, tmp);
1598
1599   /* Free the temporary afterwards, if necessary.  */
1600   cond = fold_build2 (GT_EXPR, boolean_type_node,
1601                       len, build_int_cst (TREE_TYPE (len), 0));
1602   tmp = gfc_call_free (var);
1603   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1604   gfc_add_expr_to_block (&se->post, tmp);
1605
1606   se->expr = var;
1607   se->string_length = len;
1608 }
1609
1610
1611 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1612    has the generic name.  */
1613
1614 static gfc_symbol *
1615 gfc_get_symbol_for_expr (gfc_expr * expr)
1616 {
1617   gfc_symbol *sym;
1618
1619   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1620   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1621   sym = gfc_new_symbol (expr->value.function.name, NULL);
1622
1623   sym->ts = expr->ts;
1624   sym->attr.external = 1;
1625   sym->attr.function = 1;
1626   sym->attr.always_explicit = 1;
1627   sym->attr.proc = PROC_INTRINSIC;
1628   sym->attr.flavor = FL_PROCEDURE;
1629   sym->result = sym;
1630   if (expr->rank > 0)
1631     {
1632       sym->attr.dimension = 1;
1633       sym->as = gfc_get_array_spec ();
1634       sym->as->type = AS_ASSUMED_SHAPE;
1635       sym->as->rank = expr->rank;
1636     }
1637
1638   /* TODO: proper argument lists for external intrinsics.  */
1639   return sym;
1640 }
1641
1642 /* Generate a call to an external intrinsic function.  */
1643 static void
1644 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1645 {
1646   gfc_symbol *sym;
1647   tree append_args;
1648
1649   gcc_assert (!se->ss || se->ss->expr == expr);
1650
1651   if (se->ss)
1652     gcc_assert (expr->rank > 0);
1653   else
1654     gcc_assert (expr->rank == 0);
1655
1656   sym = gfc_get_symbol_for_expr (expr);
1657
1658   /* Calls to libgfortran_matmul need to be appended special arguments,
1659      to be able to call the BLAS ?gemm functions if required and possible.  */
1660   append_args = NULL_TREE;
1661   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1662       && sym->ts.type != BT_LOGICAL)
1663     {
1664       tree cint = gfc_get_int_type (gfc_c_int_kind);
1665
1666       if (gfc_option.flag_external_blas
1667           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1668           && (sym->ts.kind == gfc_default_real_kind
1669               || sym->ts.kind == gfc_default_double_kind))
1670         {
1671           tree gemm_fndecl;
1672
1673           if (sym->ts.type == BT_REAL)
1674             {
1675               if (sym->ts.kind == gfc_default_real_kind)
1676                 gemm_fndecl = gfor_fndecl_sgemm;
1677               else
1678                 gemm_fndecl = gfor_fndecl_dgemm;
1679             }
1680           else
1681             {
1682               if (sym->ts.kind == gfc_default_real_kind)
1683                 gemm_fndecl = gfor_fndecl_cgemm;
1684               else
1685                 gemm_fndecl = gfor_fndecl_zgemm;
1686             }
1687
1688           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1689           append_args = gfc_chainon_list
1690                           (append_args, build_int_cst
1691                                           (cint, gfc_option.blas_matmul_limit));
1692           append_args = gfc_chainon_list (append_args,
1693                                           gfc_build_addr_expr (NULL_TREE,
1694                                                                gemm_fndecl));
1695         }
1696       else
1697         {
1698           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1699           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1700           append_args = gfc_chainon_list (append_args, null_pointer_node);
1701         }
1702     }
1703
1704   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1705   gfc_free (sym);
1706 }
1707
1708 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1709    Implemented as
1710     any(a)
1711     {
1712       forall (i=...)
1713         if (a[i] != 0)
1714           return 1
1715       end forall
1716       return 0
1717     }
1718     all(a)
1719     {
1720       forall (i=...)
1721         if (a[i] == 0)
1722           return 0
1723       end forall
1724       return 1
1725     }
1726  */
1727 static void
1728 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
1729 {
1730   tree resvar;
1731   stmtblock_t block;
1732   stmtblock_t body;
1733   tree type;
1734   tree tmp;
1735   tree found;
1736   gfc_loopinfo loop;
1737   gfc_actual_arglist *actual;
1738   gfc_ss *arrayss;
1739   gfc_se arrayse;
1740   tree exit_label;
1741
1742   if (se->ss)
1743     {
1744       gfc_conv_intrinsic_funcall (se, expr);
1745       return;
1746     }
1747
1748   actual = expr->value.function.actual;
1749   type = gfc_typenode_for_spec (&expr->ts);
1750   /* Initialize the result.  */
1751   resvar = gfc_create_var (type, "test");
1752   if (op == EQ_EXPR)
1753     tmp = convert (type, boolean_true_node);
1754   else
1755     tmp = convert (type, boolean_false_node);
1756   gfc_add_modify (&se->pre, resvar, tmp);
1757
1758   /* Walk the arguments.  */
1759   arrayss = gfc_walk_expr (actual->expr);
1760   gcc_assert (arrayss != gfc_ss_terminator);
1761
1762   /* Initialize the scalarizer.  */
1763   gfc_init_loopinfo (&loop);
1764   exit_label = gfc_build_label_decl (NULL_TREE);
1765   TREE_USED (exit_label) = 1;
1766   gfc_add_ss_to_loop (&loop, arrayss);
1767
1768   /* Initialize the loop.  */
1769   gfc_conv_ss_startstride (&loop);
1770   gfc_conv_loop_setup (&loop, &expr->where);
1771
1772   gfc_mark_ss_chain_used (arrayss, 1);
1773   /* Generate the loop body.  */
1774   gfc_start_scalarized_body (&loop, &body);
1775
1776   /* If the condition matches then set the return value.  */
1777   gfc_start_block (&block);
1778   if (op == EQ_EXPR)
1779     tmp = convert (type, boolean_false_node);
1780   else
1781     tmp = convert (type, boolean_true_node);
1782   gfc_add_modify (&block, resvar, tmp);
1783
1784   /* And break out of the loop.  */
1785   tmp = build1_v (GOTO_EXPR, exit_label);
1786   gfc_add_expr_to_block (&block, tmp);
1787
1788   found = gfc_finish_block (&block);
1789
1790   /* Check this element.  */
1791   gfc_init_se (&arrayse, NULL);
1792   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1793   arrayse.ss = arrayss;
1794   gfc_conv_expr_val (&arrayse, actual->expr);
1795
1796   gfc_add_block_to_block (&body, &arrayse.pre);
1797   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1798                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1799   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1800   gfc_add_expr_to_block (&body, tmp);
1801   gfc_add_block_to_block (&body, &arrayse.post);
1802
1803   gfc_trans_scalarizing_loops (&loop, &body);
1804
1805   /* Add the exit label.  */
1806   tmp = build1_v (LABEL_EXPR, exit_label);
1807   gfc_add_expr_to_block (&loop.pre, tmp);
1808
1809   gfc_add_block_to_block (&se->pre, &loop.pre);
1810   gfc_add_block_to_block (&se->pre, &loop.post);
1811   gfc_cleanup_loop (&loop);
1812
1813   se->expr = resvar;
1814 }
1815
1816 /* COUNT(A) = Number of true elements in A.  */
1817 static void
1818 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1819 {
1820   tree resvar;
1821   tree type;
1822   stmtblock_t body;
1823   tree tmp;
1824   gfc_loopinfo loop;
1825   gfc_actual_arglist *actual;
1826   gfc_ss *arrayss;
1827   gfc_se arrayse;
1828
1829   if (se->ss)
1830     {
1831       gfc_conv_intrinsic_funcall (se, expr);
1832       return;
1833     }
1834
1835   actual = expr->value.function.actual;
1836
1837   type = gfc_typenode_for_spec (&expr->ts);
1838   /* Initialize the result.  */
1839   resvar = gfc_create_var (type, "count");
1840   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1841
1842   /* Walk the arguments.  */
1843   arrayss = gfc_walk_expr (actual->expr);
1844   gcc_assert (arrayss != gfc_ss_terminator);
1845
1846   /* Initialize the scalarizer.  */
1847   gfc_init_loopinfo (&loop);
1848   gfc_add_ss_to_loop (&loop, arrayss);
1849
1850   /* Initialize the loop.  */
1851   gfc_conv_ss_startstride (&loop);
1852   gfc_conv_loop_setup (&loop, &expr->where);
1853
1854   gfc_mark_ss_chain_used (arrayss, 1);
1855   /* Generate the loop body.  */
1856   gfc_start_scalarized_body (&loop, &body);
1857
1858   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1859                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1860   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1861
1862   gfc_init_se (&arrayse, NULL);
1863   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1864   arrayse.ss = arrayss;
1865   gfc_conv_expr_val (&arrayse, actual->expr);
1866   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1867
1868   gfc_add_block_to_block (&body, &arrayse.pre);
1869   gfc_add_expr_to_block (&body, tmp);
1870   gfc_add_block_to_block (&body, &arrayse.post);
1871
1872   gfc_trans_scalarizing_loops (&loop, &body);
1873
1874   gfc_add_block_to_block (&se->pre, &loop.pre);
1875   gfc_add_block_to_block (&se->pre, &loop.post);
1876   gfc_cleanup_loop (&loop);
1877
1878   se->expr = resvar;
1879 }
1880
1881 /* Inline implementation of the sum and product intrinsics.  */
1882 static void
1883 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op)
1884 {
1885   tree resvar;
1886   tree type;
1887   stmtblock_t body;
1888   stmtblock_t block;
1889   tree tmp;
1890   gfc_loopinfo loop;
1891   gfc_actual_arglist *actual;
1892   gfc_ss *arrayss;
1893   gfc_ss *maskss;
1894   gfc_se arrayse;
1895   gfc_se maskse;
1896   gfc_expr *arrayexpr;
1897   gfc_expr *maskexpr;
1898
1899   if (se->ss)
1900     {
1901       gfc_conv_intrinsic_funcall (se, expr);
1902       return;
1903     }
1904
1905   type = gfc_typenode_for_spec (&expr->ts);
1906   /* Initialize the result.  */
1907   resvar = gfc_create_var (type, "val");
1908   if (op == PLUS_EXPR)
1909     tmp = gfc_build_const (type, integer_zero_node);
1910   else
1911     tmp = gfc_build_const (type, integer_one_node);
1912
1913   gfc_add_modify (&se->pre, resvar, tmp);
1914
1915   /* Walk the arguments.  */
1916   actual = expr->value.function.actual;
1917   arrayexpr = actual->expr;
1918   arrayss = gfc_walk_expr (arrayexpr);
1919   gcc_assert (arrayss != gfc_ss_terminator);
1920
1921   actual = actual->next->next;
1922   gcc_assert (actual);
1923   maskexpr = actual->expr;
1924   if (maskexpr && maskexpr->rank != 0)
1925     {
1926       maskss = gfc_walk_expr (maskexpr);
1927       gcc_assert (maskss != gfc_ss_terminator);
1928     }
1929   else
1930     maskss = NULL;
1931
1932   /* Initialize the scalarizer.  */
1933   gfc_init_loopinfo (&loop);
1934   gfc_add_ss_to_loop (&loop, arrayss);
1935   if (maskss)
1936     gfc_add_ss_to_loop (&loop, maskss);
1937
1938   /* Initialize the loop.  */
1939   gfc_conv_ss_startstride (&loop);
1940   gfc_conv_loop_setup (&loop, &expr->where);
1941
1942   gfc_mark_ss_chain_used (arrayss, 1);
1943   if (maskss)
1944     gfc_mark_ss_chain_used (maskss, 1);
1945   /* Generate the loop body.  */
1946   gfc_start_scalarized_body (&loop, &body);
1947
1948   /* If we have a mask, only add this element if the mask is set.  */
1949   if (maskss)
1950     {
1951       gfc_init_se (&maskse, NULL);
1952       gfc_copy_loopinfo_to_se (&maskse, &loop);
1953       maskse.ss = maskss;
1954       gfc_conv_expr_val (&maskse, maskexpr);
1955       gfc_add_block_to_block (&body, &maskse.pre);
1956
1957       gfc_start_block (&block);
1958     }
1959   else
1960     gfc_init_block (&block);
1961
1962   /* Do the actual summation/product.  */
1963   gfc_init_se (&arrayse, NULL);
1964   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1965   arrayse.ss = arrayss;
1966   gfc_conv_expr_val (&arrayse, arrayexpr);
1967   gfc_add_block_to_block (&block, &arrayse.pre);
1968
1969   tmp = fold_build2 (op, type, resvar, arrayse.expr);
1970   gfc_add_modify (&block, resvar, tmp);
1971   gfc_add_block_to_block (&block, &arrayse.post);
1972
1973   if (maskss)
1974     {
1975       /* We enclose the above in if (mask) {...} .  */
1976       tmp = gfc_finish_block (&block);
1977
1978       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1979     }
1980   else
1981     tmp = gfc_finish_block (&block);
1982   gfc_add_expr_to_block (&body, tmp);
1983
1984   gfc_trans_scalarizing_loops (&loop, &body);
1985
1986   /* For a scalar mask, enclose the loop in an if statement.  */
1987   if (maskexpr && maskss == NULL)
1988     {
1989       gfc_init_se (&maskse, NULL);
1990       gfc_conv_expr_val (&maskse, maskexpr);
1991       gfc_init_block (&block);
1992       gfc_add_block_to_block (&block, &loop.pre);
1993       gfc_add_block_to_block (&block, &loop.post);
1994       tmp = gfc_finish_block (&block);
1995
1996       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1997       gfc_add_expr_to_block (&block, tmp);
1998       gfc_add_block_to_block (&se->pre, &block);
1999     }
2000   else
2001     {
2002       gfc_add_block_to_block (&se->pre, &loop.pre);
2003       gfc_add_block_to_block (&se->pre, &loop.post);
2004     }
2005
2006   gfc_cleanup_loop (&loop);
2007
2008   se->expr = resvar;
2009 }
2010
2011
2012 /* Inline implementation of the dot_product intrinsic. This function
2013    is based on gfc_conv_intrinsic_arith (the previous function).  */
2014 static void
2015 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2016 {
2017   tree resvar;
2018   tree type;
2019   stmtblock_t body;
2020   stmtblock_t block;
2021   tree tmp;
2022   gfc_loopinfo loop;
2023   gfc_actual_arglist *actual;
2024   gfc_ss *arrayss1, *arrayss2;
2025   gfc_se arrayse1, arrayse2;
2026   gfc_expr *arrayexpr1, *arrayexpr2;
2027
2028   type = gfc_typenode_for_spec (&expr->ts);
2029
2030   /* Initialize the result.  */
2031   resvar = gfc_create_var (type, "val");
2032   if (expr->ts.type == BT_LOGICAL)
2033     tmp = build_int_cst (type, 0);
2034   else
2035     tmp = gfc_build_const (type, integer_zero_node);
2036
2037   gfc_add_modify (&se->pre, resvar, tmp);
2038
2039   /* Walk argument #1.  */
2040   actual = expr->value.function.actual;
2041   arrayexpr1 = actual->expr;
2042   arrayss1 = gfc_walk_expr (arrayexpr1);
2043   gcc_assert (arrayss1 != gfc_ss_terminator);
2044
2045   /* Walk argument #2.  */
2046   actual = actual->next;
2047   arrayexpr2 = actual->expr;
2048   arrayss2 = gfc_walk_expr (arrayexpr2);
2049   gcc_assert (arrayss2 != gfc_ss_terminator);
2050
2051   /* Initialize the scalarizer.  */
2052   gfc_init_loopinfo (&loop);
2053   gfc_add_ss_to_loop (&loop, arrayss1);
2054   gfc_add_ss_to_loop (&loop, arrayss2);
2055
2056   /* Initialize the loop.  */
2057   gfc_conv_ss_startstride (&loop);
2058   gfc_conv_loop_setup (&loop, &expr->where);
2059
2060   gfc_mark_ss_chain_used (arrayss1, 1);
2061   gfc_mark_ss_chain_used (arrayss2, 1);
2062
2063   /* Generate the loop body.  */
2064   gfc_start_scalarized_body (&loop, &body);
2065   gfc_init_block (&block);
2066
2067   /* Make the tree expression for [conjg(]array1[)].  */
2068   gfc_init_se (&arrayse1, NULL);
2069   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2070   arrayse1.ss = arrayss1;
2071   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2072   if (expr->ts.type == BT_COMPLEX)
2073     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2074   gfc_add_block_to_block (&block, &arrayse1.pre);
2075
2076   /* Make the tree expression for array2.  */
2077   gfc_init_se (&arrayse2, NULL);
2078   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2079   arrayse2.ss = arrayss2;
2080   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2081   gfc_add_block_to_block (&block, &arrayse2.pre);
2082
2083   /* Do the actual product and sum.  */
2084   if (expr->ts.type == BT_LOGICAL)
2085     {
2086       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2087       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2088     }
2089   else
2090     {
2091       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2092       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2093     }
2094   gfc_add_modify (&block, resvar, tmp);
2095
2096   /* Finish up the loop block and the loop.  */
2097   tmp = gfc_finish_block (&block);
2098   gfc_add_expr_to_block (&body, tmp);
2099
2100   gfc_trans_scalarizing_loops (&loop, &body);
2101   gfc_add_block_to_block (&se->pre, &loop.pre);
2102   gfc_add_block_to_block (&se->pre, &loop.post);
2103   gfc_cleanup_loop (&loop);
2104
2105   se->expr = resvar;
2106 }
2107
2108
2109 static void
2110 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2111 {
2112   stmtblock_t body;
2113   stmtblock_t block;
2114   stmtblock_t ifblock;
2115   stmtblock_t elseblock;
2116   tree limit;
2117   tree type;
2118   tree tmp;
2119   tree elsetmp;
2120   tree ifbody;
2121   tree offset;
2122   gfc_loopinfo loop;
2123   gfc_actual_arglist *actual;
2124   gfc_ss *arrayss;
2125   gfc_ss *maskss;
2126   gfc_se arrayse;
2127   gfc_se maskse;
2128   gfc_expr *arrayexpr;
2129   gfc_expr *maskexpr;
2130   tree pos;
2131   int n;
2132
2133   if (se->ss)
2134     {
2135       gfc_conv_intrinsic_funcall (se, expr);
2136       return;
2137     }
2138
2139   /* Initialize the result.  */
2140   pos = gfc_create_var (gfc_array_index_type, "pos");
2141   offset = gfc_create_var (gfc_array_index_type, "offset");
2142   type = gfc_typenode_for_spec (&expr->ts);
2143
2144   /* Walk the arguments.  */
2145   actual = expr->value.function.actual;
2146   arrayexpr = actual->expr;
2147   arrayss = gfc_walk_expr (arrayexpr);
2148   gcc_assert (arrayss != gfc_ss_terminator);
2149
2150   actual = actual->next->next;
2151   gcc_assert (actual);
2152   maskexpr = actual->expr;
2153   if (maskexpr && maskexpr->rank != 0)
2154     {
2155       maskss = gfc_walk_expr (maskexpr);
2156       gcc_assert (maskss != gfc_ss_terminator);
2157     }
2158   else
2159     maskss = NULL;
2160
2161   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2162   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2163   switch (arrayexpr->ts.type)
2164     {
2165     case BT_REAL:
2166       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2167                                    arrayexpr->ts.kind, 0);
2168       break;
2169
2170     case BT_INTEGER:
2171       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2172                                   arrayexpr->ts.kind);
2173       break;
2174
2175     default:
2176       gcc_unreachable ();
2177     }
2178
2179   /* We start with the most negative possible value for MAXLOC, and the most
2180      positive possible value for MINLOC. The most negative possible value is
2181      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2182      possible value is HUGE in both cases.  */
2183   if (op == GT_EXPR)
2184     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2185   gfc_add_modify (&se->pre, limit, tmp);
2186
2187   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2188     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2189                        build_int_cst (type, 1));
2190
2191   /* Initialize the scalarizer.  */
2192   gfc_init_loopinfo (&loop);
2193   gfc_add_ss_to_loop (&loop, arrayss);
2194   if (maskss)
2195     gfc_add_ss_to_loop (&loop, maskss);
2196
2197   /* Initialize the loop.  */
2198   gfc_conv_ss_startstride (&loop);
2199   gfc_conv_loop_setup (&loop, &expr->where);
2200
2201   gcc_assert (loop.dimen == 1);
2202
2203   /* Initialize the position to zero, following Fortran 2003.  We are free
2204      to do this because Fortran 95 allows the result of an entirely false
2205      mask to be processor dependent.  */
2206   gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2207
2208   gfc_mark_ss_chain_used (arrayss, 1);
2209   if (maskss)
2210     gfc_mark_ss_chain_used (maskss, 1);
2211   /* Generate the loop body.  */
2212   gfc_start_scalarized_body (&loop, &body);
2213
2214   /* If we have a mask, only check this element if the mask is set.  */
2215   if (maskss)
2216     {
2217       gfc_init_se (&maskse, NULL);
2218       gfc_copy_loopinfo_to_se (&maskse, &loop);
2219       maskse.ss = maskss;
2220       gfc_conv_expr_val (&maskse, maskexpr);
2221       gfc_add_block_to_block (&body, &maskse.pre);
2222
2223       gfc_start_block (&block);
2224     }
2225   else
2226     gfc_init_block (&block);
2227
2228   /* Compare with the current limit.  */
2229   gfc_init_se (&arrayse, NULL);
2230   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2231   arrayse.ss = arrayss;
2232   gfc_conv_expr_val (&arrayse, arrayexpr);
2233   gfc_add_block_to_block (&block, &arrayse.pre);
2234
2235   /* We do the following if this is a more extreme value.  */
2236   gfc_start_block (&ifblock);
2237
2238   /* Assign the value to the limit...  */
2239   gfc_add_modify (&ifblock, limit, arrayse.expr);
2240
2241   /* Remember where we are.  An offset must be added to the loop
2242      counter to obtain the required position.  */
2243   if (loop.from[0])
2244     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2245                        gfc_index_one_node, loop.from[0]);
2246   else
2247     tmp = gfc_index_one_node;
2248
2249   gfc_add_modify (&block, offset, tmp);
2250
2251   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2252                      loop.loopvar[0], offset);
2253   gfc_add_modify (&ifblock, pos, tmp);
2254
2255   ifbody = gfc_finish_block (&ifblock);
2256
2257   /* If it is a more extreme value or pos is still zero and the value
2258      equal to the limit.  */
2259   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2260                      fold_build2 (EQ_EXPR, boolean_type_node,
2261                                   pos, gfc_index_zero_node),
2262                      fold_build2 (EQ_EXPR, boolean_type_node,
2263                                   arrayse.expr, limit));
2264   tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2265                      fold_build2 (op, boolean_type_node,
2266                                   arrayse.expr, limit), tmp);
2267   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2268   gfc_add_expr_to_block (&block, tmp);
2269
2270   if (maskss)
2271     {
2272       /* We enclose the above in if (mask) {...}.  */
2273       tmp = gfc_finish_block (&block);
2274
2275       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2276     }
2277   else
2278     tmp = gfc_finish_block (&block);
2279   gfc_add_expr_to_block (&body, tmp);
2280
2281   gfc_trans_scalarizing_loops (&loop, &body);
2282
2283   /* For a scalar mask, enclose the loop in an if statement.  */
2284   if (maskexpr && maskss == NULL)
2285     {
2286       gfc_init_se (&maskse, NULL);
2287       gfc_conv_expr_val (&maskse, maskexpr);
2288       gfc_init_block (&block);
2289       gfc_add_block_to_block (&block, &loop.pre);
2290       gfc_add_block_to_block (&block, &loop.post);
2291       tmp = gfc_finish_block (&block);
2292
2293       /* For the else part of the scalar mask, just initialize
2294          the pos variable the same way as above.  */
2295
2296       gfc_init_block (&elseblock);
2297       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2298       elsetmp = gfc_finish_block (&elseblock);
2299
2300       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2301       gfc_add_expr_to_block (&block, tmp);
2302       gfc_add_block_to_block (&se->pre, &block);
2303     }
2304   else
2305     {
2306       gfc_add_block_to_block (&se->pre, &loop.pre);
2307       gfc_add_block_to_block (&se->pre, &loop.post);
2308     }
2309   gfc_cleanup_loop (&loop);
2310
2311   se->expr = convert (type, pos);
2312 }
2313
2314 static void
2315 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
2316 {
2317   tree limit;
2318   tree type;
2319   tree tmp;
2320   tree ifbody;
2321   stmtblock_t body;
2322   stmtblock_t block;
2323   gfc_loopinfo loop;
2324   gfc_actual_arglist *actual;
2325   gfc_ss *arrayss;
2326   gfc_ss *maskss;
2327   gfc_se arrayse;
2328   gfc_se maskse;
2329   gfc_expr *arrayexpr;
2330   gfc_expr *maskexpr;
2331   int n;
2332
2333   if (se->ss)
2334     {
2335       gfc_conv_intrinsic_funcall (se, expr);
2336       return;
2337     }
2338
2339   type = gfc_typenode_for_spec (&expr->ts);
2340   /* Initialize the result.  */
2341   limit = gfc_create_var (type, "limit");
2342   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2343   switch (expr->ts.type)
2344     {
2345     case BT_REAL:
2346       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
2347       break;
2348
2349     case BT_INTEGER:
2350       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2351       break;
2352
2353     default:
2354       gcc_unreachable ();
2355     }
2356
2357   /* We start with the most negative possible value for MAXVAL, and the most
2358      positive possible value for MINVAL. The most negative possible value is
2359      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2360      possible value is HUGE in both cases.  */
2361   if (op == GT_EXPR)
2362     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2363
2364   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2365     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2366                        tmp, build_int_cst (type, 1));
2367
2368   gfc_add_modify (&se->pre, limit, tmp);
2369
2370   /* Walk the arguments.  */
2371   actual = expr->value.function.actual;
2372   arrayexpr = actual->expr;
2373   arrayss = gfc_walk_expr (arrayexpr);
2374   gcc_assert (arrayss != gfc_ss_terminator);
2375
2376   actual = actual->next->next;
2377   gcc_assert (actual);
2378   maskexpr = actual->expr;
2379   if (maskexpr && maskexpr->rank != 0)
2380     {
2381       maskss = gfc_walk_expr (maskexpr);
2382       gcc_assert (maskss != gfc_ss_terminator);
2383     }
2384   else
2385     maskss = NULL;
2386
2387   /* Initialize the scalarizer.  */
2388   gfc_init_loopinfo (&loop);
2389   gfc_add_ss_to_loop (&loop, arrayss);
2390   if (maskss)
2391     gfc_add_ss_to_loop (&loop, maskss);
2392
2393   /* Initialize the loop.  */
2394   gfc_conv_ss_startstride (&loop);
2395   gfc_conv_loop_setup (&loop, &expr->where);
2396
2397   gfc_mark_ss_chain_used (arrayss, 1);
2398   if (maskss)
2399     gfc_mark_ss_chain_used (maskss, 1);
2400   /* Generate the loop body.  */
2401   gfc_start_scalarized_body (&loop, &body);
2402
2403   /* If we have a mask, only add this element if the mask is set.  */
2404   if (maskss)
2405     {
2406       gfc_init_se (&maskse, NULL);
2407       gfc_copy_loopinfo_to_se (&maskse, &loop);
2408       maskse.ss = maskss;
2409       gfc_conv_expr_val (&maskse, maskexpr);
2410       gfc_add_block_to_block (&body, &maskse.pre);
2411
2412       gfc_start_block (&block);
2413     }
2414   else
2415     gfc_init_block (&block);
2416
2417   /* Compare with the current limit.  */
2418   gfc_init_se (&arrayse, NULL);
2419   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2420   arrayse.ss = arrayss;
2421   gfc_conv_expr_val (&arrayse, arrayexpr);
2422   gfc_add_block_to_block (&block, &arrayse.pre);
2423
2424   /* Assign the value to the limit...  */
2425   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2426
2427   /* If it is a more extreme value.  */
2428   tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2429   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2430   gfc_add_expr_to_block (&block, tmp);
2431   gfc_add_block_to_block (&block, &arrayse.post);
2432
2433   tmp = gfc_finish_block (&block);
2434   if (maskss)
2435     /* We enclose the above in if (mask) {...}.  */
2436     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2437   gfc_add_expr_to_block (&body, tmp);
2438
2439   gfc_trans_scalarizing_loops (&loop, &body);
2440
2441   /* For a scalar mask, enclose the loop in an if statement.  */
2442   if (maskexpr && maskss == NULL)
2443     {
2444       gfc_init_se (&maskse, NULL);
2445       gfc_conv_expr_val (&maskse, maskexpr);
2446       gfc_init_block (&block);
2447       gfc_add_block_to_block (&block, &loop.pre);
2448       gfc_add_block_to_block (&block, &loop.post);
2449       tmp = gfc_finish_block (&block);
2450
2451       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2452       gfc_add_expr_to_block (&block, tmp);
2453       gfc_add_block_to_block (&se->pre, &block);
2454     }
2455   else
2456     {
2457       gfc_add_block_to_block (&se->pre, &loop.pre);
2458       gfc_add_block_to_block (&se->pre, &loop.post);
2459     }
2460
2461   gfc_cleanup_loop (&loop);
2462
2463   se->expr = limit;
2464 }
2465
2466 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2467 static void
2468 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2469 {
2470   tree args[2];
2471   tree type;
2472   tree tmp;
2473
2474   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2475   type = TREE_TYPE (args[0]);
2476
2477   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2478   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2479   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2480                      build_int_cst (type, 0));
2481   type = gfc_typenode_for_spec (&expr->ts);
2482   se->expr = convert (type, tmp);
2483 }
2484
2485 /* Generate code to perform the specified operation.  */
2486 static void
2487 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
2488 {
2489   tree args[2];
2490
2491   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2492   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2493 }
2494
2495 /* Bitwise not.  */
2496 static void
2497 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2498 {
2499   tree arg;
2500
2501   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2502   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2503 }
2504
2505 /* Set or clear a single bit.  */
2506 static void
2507 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2508 {
2509   tree args[2];
2510   tree type;
2511   tree tmp;
2512   enum tree_code op;
2513
2514   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2515   type = TREE_TYPE (args[0]);
2516
2517   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2518   if (set)
2519     op = BIT_IOR_EXPR;
2520   else
2521     {
2522       op = BIT_AND_EXPR;
2523       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2524     }
2525   se->expr = fold_build2 (op, type, args[0], tmp);
2526 }
2527
2528 /* Extract a sequence of bits.
2529     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2530 static void
2531 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2532 {
2533   tree args[3];
2534   tree type;
2535   tree tmp;
2536   tree mask;
2537
2538   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2539   type = TREE_TYPE (args[0]);
2540
2541   mask = build_int_cst (type, -1);
2542   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2543   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2544
2545   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2546
2547   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2548 }
2549
2550 /* RSHIFT (I, SHIFT) = I >> SHIFT
2551    LSHIFT (I, SHIFT) = I << SHIFT  */
2552 static void
2553 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2554 {
2555   tree args[2];
2556
2557   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2558
2559   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2560                           TREE_TYPE (args[0]), args[0], args[1]);
2561 }
2562
2563 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2564                         ? 0
2565                         : ((shift >= 0) ? i << shift : i >> -shift)
2566    where all shifts are logical shifts.  */
2567 static void
2568 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2569 {
2570   tree args[2];
2571   tree type;
2572   tree utype;
2573   tree tmp;
2574   tree width;
2575   tree num_bits;
2576   tree cond;
2577   tree lshift;
2578   tree rshift;
2579
2580   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2581   type = TREE_TYPE (args[0]);
2582   utype = unsigned_type_for (type);
2583
2584   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2585
2586   /* Left shift if positive.  */
2587   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2588
2589   /* Right shift if negative.
2590      We convert to an unsigned type because we want a logical shift.
2591      The standard doesn't define the case of shifting negative
2592      numbers, and we try to be compatible with other compilers, most
2593      notably g77, here.  */
2594   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
2595                                             convert (utype, args[0]), width));
2596
2597   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2598                      build_int_cst (TREE_TYPE (args[1]), 0));
2599   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2600
2601   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2602      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2603      special case.  */
2604   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
2605   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2606
2607   se->expr = fold_build3 (COND_EXPR, type, cond,
2608                           build_int_cst (type, 0), tmp);
2609 }
2610
2611
2612 /* Circular shift.  AKA rotate or barrel shift.  */
2613
2614 static void
2615 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2616 {
2617   tree *args;
2618   tree type;
2619   tree tmp;
2620   tree lrot;
2621   tree rrot;
2622   tree zero;
2623   unsigned int num_args;
2624
2625   num_args = gfc_intrinsic_argument_list_length (expr);
2626   args = (tree *) alloca (sizeof (tree) * num_args);
2627
2628   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2629
2630   if (num_args == 3)
2631     {
2632       /* Use a library function for the 3 parameter version.  */
2633       tree int4type = gfc_get_int_type (4);
2634
2635       type = TREE_TYPE (args[0]);
2636       /* We convert the first argument to at least 4 bytes, and
2637          convert back afterwards.  This removes the need for library
2638          functions for all argument sizes, and function will be
2639          aligned to at least 32 bits, so there's no loss.  */
2640       if (expr->ts.kind < 4)
2641         args[0] = convert (int4type, args[0]);
2642
2643       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2644          need loads of library  functions.  They cannot have values >
2645          BIT_SIZE (I) so the conversion is safe.  */
2646       args[1] = convert (int4type, args[1]);
2647       args[2] = convert (int4type, args[2]);
2648
2649       switch (expr->ts.kind)
2650         {
2651         case 1:
2652         case 2:
2653         case 4:
2654           tmp = gfor_fndecl_math_ishftc4;
2655           break;
2656         case 8:
2657           tmp = gfor_fndecl_math_ishftc8;
2658           break;
2659         case 16:
2660           tmp = gfor_fndecl_math_ishftc16;
2661           break;
2662         default:
2663           gcc_unreachable ();
2664         }
2665       se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2666       /* Convert the result back to the original type, if we extended
2667          the first argument's width above.  */
2668       if (expr->ts.kind < 4)
2669         se->expr = convert (type, se->expr);
2670
2671       return;
2672     }
2673   type = TREE_TYPE (args[0]);
2674
2675   /* Rotate left if positive.  */
2676   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2677
2678   /* Rotate right if negative.  */
2679   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2680   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2681
2682   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2683   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2684   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2685
2686   /* Do nothing if shift == 0.  */
2687   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2688   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2689 }
2690
2691 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2692                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2693
2694    The conditional expression is necessary because the result of LEADZ(0)
2695    is defined, but the result of __builtin_clz(0) is undefined for most
2696    targets.
2697
2698    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2699    difference in bit size between the argument of LEADZ and the C int.  */
2700
2701 static void
2702 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
2703 {
2704   tree arg;
2705   tree arg_type;
2706   tree cond;
2707   tree result_type;
2708   tree leadz;
2709   tree bit_size;
2710   tree tmp;
2711   int arg_kind;
2712   int i, n, s;
2713
2714   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2715
2716   /* Which variant of __builtin_clz* should we call?  */
2717   arg_kind = expr->value.function.actual->expr->ts.kind;
2718   i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2719   switch (arg_kind)
2720     {
2721       case 1:
2722       case 2:
2723       case 4:
2724         arg_type = unsigned_type_node;
2725         n = BUILT_IN_CLZ;
2726         break;
2727
2728       case 8:
2729         arg_type = long_unsigned_type_node;
2730         n = BUILT_IN_CLZL;
2731         break;
2732
2733       case 16:
2734         arg_type = long_long_unsigned_type_node;
2735         n = BUILT_IN_CLZLL;
2736         break;
2737
2738       default:
2739         gcc_unreachable ();
2740     }
2741
2742   /* Convert the actual argument to the proper argument type for the built-in
2743      function.  But the return type is of the default INTEGER kind.  */
2744   arg = fold_convert (arg_type, arg);
2745   result_type = gfc_get_int_type (gfc_default_integer_kind);
2746
2747   /* Compute LEADZ for the case i .ne. 0.  */
2748   s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
2749   tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2750   leadz = fold_build2 (MINUS_EXPR, result_type,
2751                        tmp, build_int_cst (result_type, s));
2752
2753   /* Build BIT_SIZE.  */
2754   bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2755
2756   /* ??? For some combinations of targets and integer kinds, the condition
2757          can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
2758   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2759                       arg, build_int_cst (arg_type, 0));
2760   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
2761 }
2762
2763 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2764
2765    The conditional expression is necessary because the result of TRAILZ(0)
2766    is defined, but the result of __builtin_ctz(0) is undefined for most
2767    targets.  */
2768
2769 static void
2770 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
2771 {
2772   tree arg;
2773   tree arg_type;
2774   tree cond;
2775   tree result_type;
2776   tree trailz;
2777   tree bit_size;
2778   int arg_kind;
2779   int i, n;
2780
2781   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2782
2783   /* Which variant of __builtin_clz* should we call?  */
2784   arg_kind = expr->value.function.actual->expr->ts.kind;
2785   i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2786   switch (expr->ts.kind)
2787     {
2788       case 1:
2789       case 2:
2790       case 4:
2791         arg_type = unsigned_type_node;
2792         n = BUILT_IN_CTZ;
2793         break;
2794
2795       case 8:
2796         arg_type = long_unsigned_type_node;
2797         n = BUILT_IN_CTZL;
2798         break;
2799
2800       case 16:
2801         arg_type = long_long_unsigned_type_node;
2802         n = BUILT_IN_CTZLL;
2803         break;
2804
2805       default:
2806         gcc_unreachable ();
2807     }
2808
2809   /* Convert the actual argument to the proper argument type for the built-in
2810      function.  But the return type is of the default INTEGER kind.  */
2811   arg = fold_convert (arg_type, arg);
2812   result_type = gfc_get_int_type (gfc_default_integer_kind);
2813
2814   /* Compute TRAILZ for the case i .ne. 0.  */
2815   trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2816
2817   /* Build BIT_SIZE.  */
2818   bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2819
2820   /* ??? For some combinations of targets and integer kinds, the condition
2821          can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
2822   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2823                       arg, build_int_cst (arg_type, 0));
2824   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
2825 }
2826
2827 /* Process an intrinsic with unspecified argument-types that has an optional
2828    argument (which could be of type character), e.g. EOSHIFT.  For those, we
2829    need to append the string length of the optional argument if it is not
2830    present and the type is really character.
2831    primary specifies the position (starting at 1) of the non-optional argument
2832    specifying the type and optional gives the position of the optional
2833    argument in the arglist.  */
2834
2835 static void
2836 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
2837                                      unsigned primary, unsigned optional)
2838 {
2839   gfc_actual_arglist* prim_arg;
2840   gfc_actual_arglist* opt_arg;
2841   unsigned cur_pos;
2842   gfc_actual_arglist* arg;
2843   gfc_symbol* sym;
2844   tree append_args;
2845
2846   /* Find the two arguments given as position.  */
2847   cur_pos = 0;
2848   prim_arg = NULL;
2849   opt_arg = NULL;
2850   for (arg = expr->value.function.actual; arg; arg = arg->next)
2851     {
2852       ++cur_pos;
2853
2854       if (cur_pos == primary)
2855         prim_arg = arg;
2856       if (cur_pos == optional)
2857         opt_arg = arg;
2858
2859       if (cur_pos >= primary && cur_pos >= optional)
2860         break;
2861     }
2862   gcc_assert (prim_arg);
2863   gcc_assert (prim_arg->expr);
2864   gcc_assert (opt_arg);
2865
2866   /* If we do have type CHARACTER and the optional argument is really absent,
2867      append a dummy 0 as string length.  */
2868   append_args = NULL_TREE;
2869   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
2870     {
2871       tree dummy;
2872
2873       dummy = build_int_cst (gfc_charlen_type_node, 0);
2874       append_args = gfc_chainon_list (append_args, dummy);
2875     }
2876
2877   /* Build the call itself.  */
2878   sym = gfc_get_symbol_for_expr (expr);
2879   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
2880   gfc_free (sym);
2881 }
2882
2883
2884 /* The length of a character string.  */
2885 static void
2886 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2887 {
2888   tree len;
2889   tree type;
2890   tree decl;
2891   gfc_symbol *sym;
2892   gfc_se argse;
2893   gfc_expr *arg;
2894   gfc_ss *ss;
2895
2896   gcc_assert (!se->ss);
2897
2898   arg = expr->value.function.actual->expr;
2899
2900   type = gfc_typenode_for_spec (&expr->ts);
2901   switch (arg->expr_type)
2902     {
2903     case EXPR_CONSTANT:
2904       len = build_int_cst (NULL_TREE, arg->value.character.length);
2905       break;
2906
2907     case EXPR_ARRAY:
2908       /* Obtain the string length from the function used by
2909          trans-array.c(gfc_trans_array_constructor).  */
2910       len = NULL_TREE;
2911       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2912       break;
2913
2914     case EXPR_VARIABLE:
2915       if (arg->ref == NULL
2916             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2917         {
2918           /* This doesn't catch all cases.
2919              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2920              and the surrounding thread.  */
2921           sym = arg->symtree->n.sym;
2922           decl = gfc_get_symbol_decl (sym);
2923           if (decl == current_function_decl && sym->attr.function
2924                 && (sym->result == sym))
2925             decl = gfc_get_fake_result_decl (sym, 0);
2926
2927           len = sym->ts.cl->backend_decl;
2928           gcc_assert (len);
2929           break;
2930         }
2931
2932       /* Otherwise fall through.  */
2933
2934     default:
2935       /* Anybody stupid enough to do this deserves inefficient code.  */
2936       ss = gfc_walk_expr (arg);
2937       gfc_init_se (&argse, se);
2938       if (ss == gfc_ss_terminator)
2939         gfc_conv_expr (&argse, arg);
2940       else
2941         gfc_conv_expr_descriptor (&argse, arg, ss);
2942       gfc_add_block_to_block (&se->pre, &argse.pre);
2943       gfc_add_block_to_block (&se->post, &argse.post);
2944       len = argse.string_length;
2945       break;
2946     }
2947   se->expr = convert (type, len);
2948 }
2949
2950 /* The length of a character string not including trailing blanks.  */
2951 static void
2952 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2953 {
2954   int kind = expr->value.function.actual->expr->ts.kind;
2955   tree args[2], type, fndecl;
2956
2957   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2958   type = gfc_typenode_for_spec (&expr->ts);
2959
2960   if (kind == 1)
2961     fndecl = gfor_fndecl_string_len_trim;
2962   else if (kind == 4)
2963     fndecl = gfor_fndecl_string_len_trim_char4;
2964   else
2965     gcc_unreachable ();
2966
2967   se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
2968   se->expr = convert (type, se->expr);
2969 }
2970
2971
2972 /* Returns the starting position of a substring within a string.  */
2973
2974 static void
2975 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2976                                       tree function)
2977 {
2978   tree logical4_type_node = gfc_get_logical_type (4);
2979   tree type;
2980   tree fndecl;
2981   tree *args;
2982   unsigned int num_args;
2983
2984   args = (tree *) alloca (sizeof (tree) * 5);
2985
2986   /* Get number of arguments; characters count double due to the
2987      string length argument. Kind= is not passed to the library
2988      and thus ignored.  */
2989   if (expr->value.function.actual->next->next->expr == NULL)
2990     num_args = 4;
2991   else
2992     num_args = 5;
2993
2994   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2995   type = gfc_typenode_for_spec (&expr->ts);
2996
2997   if (num_args == 4)
2998     args[4] = build_int_cst (logical4_type_node, 0);
2999   else
3000     args[4] = convert (logical4_type_node, args[4]);
3001
3002   fndecl = build_addr (function, current_function_decl);
3003   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
3004                                5, args);
3005   se->expr = convert (type, se->expr);
3006
3007 }
3008
3009 /* The ascii value for a single character.  */
3010 static void
3011 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3012 {
3013   tree args[2], type, pchartype;
3014
3015   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3016   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3017   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3018   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3019   type = gfc_typenode_for_spec (&expr->ts);
3020
3021   se->expr = build_fold_indirect_ref (args[1]);
3022   se->expr = convert (type, se->expr);
3023 }
3024
3025
3026 /* Intrinsic ISNAN calls __builtin_isnan.  */
3027
3028 static void
3029 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3030 {
3031   tree arg;
3032
3033   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3034   se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
3035   STRIP_TYPE_NOPS (se->expr);
3036   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3037 }
3038
3039
3040 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3041    their argument against a constant integer value.  */
3042
3043 static void
3044 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3045 {
3046   tree arg;
3047
3048   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3049   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3050                           arg, build_int_cst (TREE_TYPE (arg), value));
3051 }
3052
3053
3054
3055 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3056
3057 static void
3058 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3059 {
3060   tree tsource;
3061   tree fsource;
3062   tree mask;
3063   tree type;
3064   tree len, len2;
3065   tree *args;
3066   unsigned int num_args;
3067
3068   num_args = gfc_intrinsic_argument_list_length (expr);
3069   args = (tree *) alloca (sizeof (tree) * num_args);
3070
3071   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3072   if (expr->ts.type != BT_CHARACTER)
3073     {
3074       tsource = args[0];
3075       fsource = args[1];
3076       mask = args[2];
3077     }
3078   else
3079     {
3080       /* We do the same as in the non-character case, but the argument
3081          list is different because of the string length arguments. We
3082          also have to set the string length for the result.  */
3083       len = args[0];
3084       tsource = args[1];
3085       len2 = args[2];
3086       fsource = args[3];
3087       mask = args[4];
3088
3089       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3090                                    &se->pre);
3091       se->string_length = len;
3092     }
3093   type = TREE_TYPE (tsource);
3094   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3095                           fold_convert (type, fsource));
3096 }
3097
3098
3099 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3100 static void
3101 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3102 {
3103   tree arg, type, tmp;
3104   int frexp;
3105
3106   switch (expr->ts.kind)
3107     {
3108       case 4:
3109         frexp = BUILT_IN_FREXPF;
3110         break;
3111       case 8:
3112         frexp = BUILT_IN_FREXP;
3113         break;
3114       case 10:
3115       case 16:
3116         frexp = BUILT_IN_FREXPL;
3117         break;
3118       default:
3119         gcc_unreachable ();
3120     }
3121
3122   type = gfc_typenode_for_spec (&expr->ts);
3123   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3124   tmp = gfc_create_var (integer_type_node, NULL);
3125   se->expr = build_call_expr (built_in_decls[frexp], 2,
3126                               fold_convert (type, arg),
3127                               gfc_build_addr_expr (NULL_TREE, tmp));
3128   se->expr = fold_convert (type, se->expr);
3129 }
3130
3131
3132 /* NEAREST (s, dir) is translated into
3133      tmp = copysign (HUGE_VAL, dir);
3134      return nextafter (s, tmp);
3135  */
3136 static void
3137 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3138 {
3139   tree args[2], type, tmp;
3140   int nextafter, copysign, huge_val;
3141
3142   switch (expr->ts.kind)
3143     {
3144       case 4:
3145         nextafter = BUILT_IN_NEXTAFTERF;
3146         copysign = BUILT_IN_COPYSIGNF;
3147         huge_val = BUILT_IN_HUGE_VALF;
3148         break;
3149       case 8:
3150         nextafter = BUILT_IN_NEXTAFTER;
3151         copysign = BUILT_IN_COPYSIGN;
3152         huge_val = BUILT_IN_HUGE_VAL;
3153         break;
3154       case 10:
3155       case 16:
3156         nextafter = BUILT_IN_NEXTAFTERL;
3157         copysign = BUILT_IN_COPYSIGNL;
3158         huge_val = BUILT_IN_HUGE_VALL;
3159         break;
3160       default:
3161         gcc_unreachable ();
3162     }
3163
3164   type = gfc_typenode_for_spec (&expr->ts);
3165   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3166   tmp = build_call_expr (built_in_decls[copysign], 2,
3167                          build_call_expr (built_in_decls[huge_val], 0),
3168                          fold_convert (type, args[1]));
3169   se->expr = build_call_expr (built_in_decls[nextafter], 2,
3170                               fold_convert (type, args[0]), tmp);
3171   se->expr = fold_convert (type, se->expr);
3172 }
3173
3174
3175 /* SPACING (s) is translated into
3176     int e;
3177     if (s == 0)
3178       res = tiny;
3179     else
3180     {
3181       frexp (s, &e);
3182       e = e - prec;
3183       e = MAX_EXPR (e, emin);
3184       res = scalbn (1., e);
3185     }
3186     return res;
3187
3188  where prec is the precision of s, gfc_real_kinds[k].digits,
3189        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3190    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3191
3192 static void
3193 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3194 {
3195   tree arg, type, prec, emin, tiny, res, e;
3196   tree cond, tmp;
3197   int frexp, scalbn, k;
3198   stmtblock_t block;
3199
3200   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3201   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3202   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3203   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3204
3205   switch (expr->ts.kind)
3206     {
3207       case 4:
3208         frexp = BUILT_IN_FREXPF;
3209         scalbn = BUILT_IN_SCALBNF;
3210         break;
3211       case 8:
3212         frexp = BUILT_IN_FREXP;
3213         scalbn = BUILT_IN_SCALBN;
3214         break;
3215       case 10:
3216       case 16:
3217         frexp = BUILT_IN_FREXPL;
3218         scalbn = BUILT_IN_SCALBNL;
3219         break;
3220       default:
3221         gcc_unreachable ();
3222     }
3223
3224   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3225   arg = gfc_evaluate_now (arg, &se->pre);
3226
3227   type = gfc_typenode_for_spec (&expr->ts);
3228   e = gfc_create_var (integer_type_node, NULL);
3229   res = gfc_create_var (type, NULL);
3230
3231
3232   /* Build the block for s /= 0.  */
3233   gfc_start_block (&block);
3234   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3235                          gfc_build_addr_expr (NULL_TREE, e));
3236   gfc_add_expr_to_block (&block, tmp);
3237
3238   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3239   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3240                                                tmp, emin));
3241
3242   tmp = build_call_expr (built_in_decls[scalbn], 2,
3243                          build_real_from_int_cst (type, integer_one_node), e);
3244   gfc_add_modify (&block, res, tmp);
3245
3246   /* Finish by building the IF statement.  */
3247   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3248                       build_real_from_int_cst (type, integer_zero_node));
3249   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3250                   gfc_finish_block (&block));
3251
3252   gfc_add_expr_to_block (&se->pre, tmp);
3253   se->expr = res;
3254 }
3255
3256
3257 /* RRSPACING (s) is translated into
3258       int e;
3259       real x;
3260       x = fabs (s);
3261       if (x != 0)
3262       {
3263         frexp (s, &e);
3264         x = scalbn (x, precision - e);
3265       }
3266       return x;
3267
3268  where precision is gfc_real_kinds[k].digits.  */
3269
3270 static void
3271 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3272 {
3273   tree arg, type, e, x, cond, stmt, tmp;
3274   int frexp, scalbn, fabs, prec, k;
3275   stmtblock_t block;
3276
3277   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3278   prec = gfc_real_kinds[k].digits;
3279   switch (expr->ts.kind)
3280     {
3281       case 4:
3282         frexp = BUILT_IN_FREXPF;
3283         scalbn = BUILT_IN_SCALBNF;
3284         fabs = BUILT_IN_FABSF;
3285         break;
3286       case 8:
3287         frexp = BUILT_IN_FREXP;
3288         scalbn = BUILT_IN_SCALBN;
3289         fabs = BUILT_IN_FABS;
3290         break;
3291       case 10:
3292       case 16:
3293         frexp = BUILT_IN_FREXPL;
3294         scalbn = BUILT_IN_SCALBNL;
3295         fabs = BUILT_IN_FABSL;
3296         break;
3297       default:
3298         gcc_unreachable ();
3299     }
3300
3301   type = gfc_typenode_for_spec (&expr->ts);
3302   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3303   arg = gfc_evaluate_now (arg, &se->pre);
3304
3305   e = gfc_create_var (integer_type_node, NULL);
3306   x = gfc_create_var (type, NULL);
3307   gfc_add_modify (&se->pre, x,
3308                        build_call_expr (built_in_decls[fabs], 1, arg));
3309
3310
3311   gfc_start_block (&block);
3312   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3313                          gfc_build_addr_expr (NULL_TREE, e));
3314   gfc_add_expr_to_block (&block, tmp);
3315
3316   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3317                      build_int_cst (NULL_TREE, prec), e);
3318   tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
3319   gfc_add_modify (&block, x, tmp);
3320   stmt = gfc_finish_block (&block);
3321
3322   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3323                       build_real_from_int_cst (type, integer_zero_node));
3324   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ());
3325   gfc_add_expr_to_block (&se->pre, tmp);
3326
3327   se->expr = fold_convert (type, x);
3328 }
3329
3330
3331 /* SCALE (s, i) is translated into scalbn (s, i).  */
3332 static void
3333 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3334 {
3335   tree args[2], type;
3336   int scalbn;
3337
3338   switch (expr->ts.kind)
3339     {
3340       case 4:
3341         scalbn = BUILT_IN_SCALBNF;
3342         break;
3343       case 8:
3344         scalbn = BUILT_IN_SCALBN;
3345         break;
3346       case 10:
3347       case 16:
3348         scalbn = BUILT_IN_SCALBNL;
3349         break;
3350       default:
3351         gcc_unreachable ();
3352     }
3353
3354   type = gfc_typenode_for_spec (&expr->ts);
3355   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3356   se->expr = build_call_expr (built_in_decls[scalbn], 2,
3357                               fold_convert (type, args[0]),
3358                               fold_convert (integer_type_node, args[1]));
3359   se->expr = fold_convert (type, se->expr);
3360 }
3361
3362
3363 /* SET_EXPONENT (s, i) is translated into
3364    scalbn (frexp (s, &dummy_int), i).  */
3365 static void
3366 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3367 {
3368   tree args[2], type, tmp;
3369   int frexp, scalbn;
3370
3371   switch (expr->ts.kind)
3372     {
3373       case 4:
3374         frexp = BUILT_IN_FREXPF;
3375         scalbn = BUILT_IN_SCALBNF;
3376         break;
3377       case 8:
3378         frexp = BUILT_IN_FREXP;
3379         scalbn = BUILT_IN_SCALBN;
3380         break;
3381       case 10:
3382       case 16:
3383         frexp = BUILT_IN_FREXPL;
3384         scalbn = BUILT_IN_SCALBNL;
3385         break;
3386       default:
3387         gcc_unreachable ();
3388     }
3389
3390   type = gfc_typenode_for_spec (&expr->ts);
3391   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3392
3393   tmp = gfc_create_var (integer_type_node, NULL);
3394   tmp = build_call_expr (built_in_decls[frexp], 2,
3395                          fold_convert (type, args[0]),
3396                          gfc_build_addr_expr (NULL_TREE, tmp));
3397   se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
3398                               fold_convert (integer_type_node, args[1]));
3399   se->expr = fold_convert (type, se->expr);
3400 }
3401
3402
3403 static void
3404 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3405 {
3406   gfc_actual_arglist *actual;
3407   tree arg1;
3408   tree type;
3409   tree fncall0;
3410   tree fncall1;
3411   gfc_se argse;
3412   gfc_ss *ss;
3413
3414   gfc_init_se (&argse, NULL);
3415   actual = expr->value.function.actual;
3416
3417   ss = gfc_walk_expr (actual->expr);
3418   gcc_assert (ss != gfc_ss_terminator);
3419   argse.want_pointer = 1;
3420   argse.data_not_needed = 1;
3421   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3422   gfc_add_block_to_block (&se->pre, &argse.pre);
3423   gfc_add_block_to_block (&se->post, &argse.post);
3424   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3425
3426   /* Build the call to size0.  */
3427   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
3428
3429   actual = actual->next;
3430
3431   if (actual->expr)
3432     {
3433       gfc_init_se (&argse, NULL);
3434       gfc_conv_expr_type (&argse, actual->expr,
3435                           gfc_array_index_type);
3436       gfc_add_block_to_block (&se->pre, &argse.pre);
3437
3438       /* Unusually, for an intrinsic, size does not exclude
3439          an optional arg2, so we must test for it.  */
3440       if (actual->expr->expr_type == EXPR_VARIABLE
3441             && actual->expr->symtree->n.sym->attr.dummy
3442             && actual->expr->symtree->n.sym->attr.optional)
3443         {
3444           tree tmp;
3445           /* Build the call to size1.  */
3446           fncall1 = build_call_expr (gfor_fndecl_size1, 2,
3447                                      arg1, argse.expr);
3448
3449           gfc_init_se (&argse, NULL);
3450           argse.want_pointer = 1;
3451           argse.data_not_needed = 1;
3452           gfc_conv_expr (&argse, actual->expr);
3453           gfc_add_block_to_block (&se->pre, &argse.pre);
3454           tmp = fold_build2 (NE_EXPR, boolean_type_node,
3455                              argse.expr, null_pointer_node);
3456           tmp = gfc_evaluate_now (tmp, &se->pre);
3457           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3458                                   tmp, fncall1, fncall0);
3459         }
3460       else
3461         {
3462           se->expr = NULL_TREE;
3463           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3464                                     argse.expr, gfc_index_one_node);
3465         }
3466     }
3467   else if (expr->value.function.actual->expr->rank == 1)
3468     {
3469       argse.expr = gfc_index_zero_node;
3470       se->expr = NULL_TREE;
3471     }
3472   else
3473     se->expr = fncall0;
3474
3475   if (se->expr == NULL_TREE)
3476     {
3477       tree ubound, lbound;
3478
3479       arg1 = build_fold_indirect_ref (arg1);
3480       ubound = gfc_conv_descriptor_ubound (arg1, argse.expr);
3481       lbound = gfc_conv_descriptor_lbound (arg1, argse.expr);
3482       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3483                               ubound, lbound);
3484       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
3485                               gfc_index_one_node);
3486       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
3487                               gfc_index_zero_node);
3488     }
3489
3490   type = gfc_typenode_for_spec (&expr->ts);
3491   se->expr = convert (type, se->expr);
3492 }
3493
3494
3495 /* Helper function to compute the size of a character variable,
3496    excluding the terminating null characters.  The result has
3497    gfc_array_index_type type.  */
3498
3499 static tree
3500 size_of_string_in_bytes (int kind, tree string_length)
3501 {
3502   tree bytesize;
3503   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
3504
3505   bytesize = build_int_cst (gfc_array_index_type,
3506                             gfc_character_kinds[i].bit_size / 8);
3507
3508   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
3509                       fold_convert (gfc_array_index_type, string_length));
3510 }
3511
3512
3513 static void
3514 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3515 {
3516   gfc_expr *arg;
3517   gfc_ss *ss;
3518   gfc_se argse;
3519   tree source;
3520   tree source_bytes;
3521   tree type;
3522   tree tmp;
3523   tree lower;