gcc/fortran/trans-intrinsic.c

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