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   if (ss == gfc_ss_terminator)
3269     {
3270       gfc_conv_expr_reference (&argse, arg);
3271       source = argse.expr;
3272
3273       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3274
3275       /* Obtain the source word length.  */
3276       if (arg->ts.type == BT_CHARACTER)
3277         se->expr = size_of_string_in_bytes (arg->ts.kind,
3278                                             argse.string_length);
3279       else
3280         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3281     }
3282   else
3283     {
3284       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3285       argse.want_pointer = 0;
3286       gfc_conv_expr_descriptor (&argse, arg, ss);
3287       source = gfc_conv_descriptor_data_get (argse.expr);
3288       type = gfc_get_element_type (TREE_TYPE (argse.expr));
3289
3290       /* Obtain the argument's word length.  */
3291       if (arg->ts.type == BT_CHARACTER)
3292         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3293       else
3294         tmp = fold_convert (gfc_array_index_type,
3295                             size_in_bytes (type));
3296       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3297
3298       /* Obtain the size of the array in bytes.  */
3299       for (n = 0; n < arg->rank; n++)
3300         {
3301           tree idx;
3302           idx = gfc_rank_cst[n];
3303           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3304           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3305           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3306                              upper, lower);
3307           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3308                              tmp, gfc_index_one_node);
3309           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3310                              tmp, source_bytes);
3311           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3312         }
3313       se->expr = source_bytes;
3314     }
3315
3316   gfc_add_block_to_block (&se->pre, &argse.pre);
3317 }
3318
3319
3320 /* Intrinsic string comparison functions.  */
3321
3322 static void
3323 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3324 {
3325   tree args[4];
3326
3327   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3328
3329   se->expr
3330     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3331                                 expr->value.function.actual->expr->ts.kind);
3332   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3333                           build_int_cst (TREE_TYPE (se->expr), 0));
3334 }
3335
3336 /* Generate a call to the adjustl/adjustr library function.  */
3337 static void
3338 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3339 {
3340   tree args[3];
3341   tree len;
3342   tree type;
3343   tree var;
3344   tree tmp;
3345
3346   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3347   len = args[1];
3348
3349   type = TREE_TYPE (args[2]);
3350   var = gfc_conv_string_tmp (se, type, len);
3351   args[0] = var;
3352
3353   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3354   gfc_add_expr_to_block (&se->pre, tmp);
3355   se->expr = var;
3356   se->string_length = len;
3357 }
3358
3359
3360 /* Array transfer statement.
3361      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3362    where:
3363      typeof<DEST> = typeof<MOLD>
3364    and:
3365      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3366               sizeof (DEST(0) * SIZE).  */
3367
3368 static void
3369 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3370 {
3371   tree tmp;
3372   tree extent;
3373   tree source;
3374   tree source_type;
3375   tree source_bytes;
3376   tree mold_type;
3377   tree dest_word_len;
3378   tree size_words;
3379   tree size_bytes;
3380   tree upper;
3381   tree lower;
3382   tree stride;
3383   tree stmt;
3384   gfc_actual_arglist *arg;
3385   gfc_se argse;
3386   gfc_ss *ss;
3387   gfc_ss_info *info;
3388   stmtblock_t block;
3389   int n;
3390
3391   gcc_assert (se->loop);
3392   info = &se->ss->data.info;
3393
3394   /* Convert SOURCE.  The output from this stage is:-
3395         source_bytes = length of the source in bytes
3396         source = pointer to the source data.  */
3397   arg = expr->value.function.actual;
3398   gfc_init_se (&argse, NULL);
3399   ss = gfc_walk_expr (arg->expr);
3400
3401   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3402
3403   /* Obtain the pointer to source and the length of source in bytes.  */
3404   if (ss == gfc_ss_terminator)
3405     {
3406       gfc_conv_expr_reference (&argse, arg->expr);
3407       source = argse.expr;
3408
3409       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3410
3411       /* Obtain the source word length.  */
3412       if (arg->expr->ts.type == BT_CHARACTER)
3413         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3414                                        argse.string_length);
3415       else
3416         tmp = fold_convert (gfc_array_index_type,
3417                             size_in_bytes (source_type));
3418     }
3419   else
3420     {
3421       argse.want_pointer = 0;
3422       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3423       source = gfc_conv_descriptor_data_get (argse.expr);
3424       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3425
3426       /* Repack the source if not a full variable array.  */
3427       if (!(arg->expr->expr_type == EXPR_VARIABLE
3428               && arg->expr->ref->u.ar.type == AR_FULL))
3429         {
3430           tmp = build_fold_addr_expr (argse.expr);
3431           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3432           source = gfc_evaluate_now (source, &argse.pre);
3433
3434           /* Free the temporary.  */
3435           gfc_start_block (&block);
3436           tmp = gfc_call_free (convert (pvoid_type_node, source));
3437           gfc_add_expr_to_block (&block, tmp);
3438           stmt = gfc_finish_block (&block);
3439
3440           /* Clean up if it was repacked.  */
3441           gfc_init_block (&block);
3442           tmp = gfc_conv_array_data (argse.expr);
3443           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3444           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3445           gfc_add_expr_to_block (&block, tmp);
3446           gfc_add_block_to_block (&block, &se->post);
3447           gfc_init_block (&se->post);
3448           gfc_add_block_to_block (&se->post, &block);
3449         }
3450
3451       /* Obtain the source word length.  */
3452       if (arg->expr->ts.type == BT_CHARACTER)
3453         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3454                                        argse.string_length);
3455       else
3456         tmp = fold_convert (gfc_array_index_type,
3457                             size_in_bytes (source_type));
3458
3459       /* Obtain the size of the array in bytes.  */
3460       extent = gfc_create_var (gfc_array_index_type, NULL);
3461       for (n = 0; n < arg->expr->rank; n++)
3462         {
3463           tree idx;
3464           idx = gfc_rank_cst[n];
3465           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3466           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3467           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3468           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3469           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3470                              upper, lower);
3471           gfc_add_modify_expr (&argse.pre, extent, tmp);
3472           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3473                              extent, gfc_index_one_node);
3474           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3475                              tmp, source_bytes);
3476         }
3477     }
3478
3479   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3480   gfc_add_block_to_block (&se->pre, &argse.pre);
3481   gfc_add_block_to_block (&se->post, &argse.post);
3482
3483   /* Now convert MOLD.  The outputs are:
3484         mold_type = the TREE type of MOLD
3485         dest_word_len = destination word length in bytes.  */
3486   arg = arg->next;
3487
3488   gfc_init_se (&argse, NULL);
3489   ss = gfc_walk_expr (arg->expr);
3490
3491   if (ss == gfc_ss_terminator)
3492     {
3493       gfc_conv_expr_reference (&argse, arg->expr);
3494       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3495     }
3496   else
3497     {
3498       gfc_init_se (&argse, NULL);
3499       argse.want_pointer = 0;
3500       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3501       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3502     }
3503
3504   if (arg->expr->ts.type == BT_CHARACTER)
3505     {
3506       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
3507       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3508     }
3509   else
3510     tmp = fold_convert (gfc_array_index_type,
3511                         size_in_bytes (mold_type));
3512
3513   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3514   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3515
3516   /* Finally convert SIZE, if it is present.  */
3517   arg = arg->next;
3518   size_words = gfc_create_var (gfc_array_index_type, NULL);
3519
3520   if (arg->expr)
3521     {
3522       gfc_init_se (&argse, NULL);
3523       gfc_conv_expr_reference (&argse, arg->expr);
3524       tmp = convert (gfc_array_index_type,
3525                          build_fold_indirect_ref (argse.expr));
3526       gfc_add_block_to_block (&se->pre, &argse.pre);
3527       gfc_add_block_to_block (&se->post, &argse.post);
3528     }
3529   else
3530     tmp = NULL_TREE;
3531
3532   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3533   if (tmp != NULL_TREE)
3534     {
3535       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3536                          tmp, dest_word_len);
3537       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3538                          tmp, source_bytes);
3539     }
3540   else
3541     tmp = source_bytes;
3542
3543   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3544   gfc_add_modify_expr (&se->pre, size_words,
3545                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3546                                     size_bytes, dest_word_len));
3547
3548   /* Evaluate the bounds of the result.  If the loop range exists, we have
3549      to check if it is too large.  If so, we modify loop->to be consistent
3550      with min(size, size(source)).  Otherwise, size is made consistent with
3551      the loop range, so that the right number of bytes is transferred.*/
3552   n = se->loop->order[0];
3553   if (se->loop->to[n] != NULL_TREE)
3554     {
3555       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3556                          se->loop->to[n], se->loop->from[n]);
3557       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3558                          tmp, gfc_index_one_node);
3559       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3560                          tmp, size_words);
3561       gfc_add_modify_expr (&se->pre, size_words, tmp);
3562       gfc_add_modify_expr (&se->pre, size_bytes,
3563                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3564                                         size_words, dest_word_len));
3565       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3566                            size_words, se->loop->from[n]);
3567       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3568                            upper, gfc_index_one_node);
3569     }
3570   else
3571     {
3572       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3573                            size_words, gfc_index_one_node);
3574       se->loop->from[n] = gfc_index_zero_node;
3575     }
3576
3577   se->loop->to[n] = upper;
3578
3579   /* Build a destination descriptor, using the pointer, source, as the
3580      data field.  This is already allocated so set callee_alloc.
3581      FIXME callee_alloc is not set!  */
3582
3583   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3584                                info, mold_type, false, true, false);
3585
3586   /* Cast the pointer to the result.  */
3587   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3588   tmp = fold_convert (pvoid_type_node, tmp);
3589
3590   /* Use memcpy to do the transfer.  */
3591   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3592                          3,
3593                          tmp,
3594                          fold_convert (pvoid_type_node, source),
3595                          size_bytes);
3596   gfc_add_expr_to_block (&se->pre, tmp);
3597
3598   se->expr = info->descriptor;
3599   if (expr->ts.type == BT_CHARACTER)
3600     se->string_length = dest_word_len;
3601 }
3602
3603
3604 /* Scalar transfer statement.
3605    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3606
3607 static void
3608 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3609 {
3610   gfc_actual_arglist *arg;
3611   gfc_se argse;
3612   tree type;
3613   tree ptr;
3614   gfc_ss *ss;
3615   tree tmpdecl, tmp;
3616
3617   /* Get a pointer to the source.  */
3618   arg = expr->value.function.actual;
3619   ss = gfc_walk_expr (arg->expr);
3620   gfc_init_se (&argse, NULL);
3621   if (ss == gfc_ss_terminator)
3622     gfc_conv_expr_reference (&argse, arg->expr);
3623   else
3624     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3625   gfc_add_block_to_block (&se->pre, &argse.pre);
3626   gfc_add_block_to_block (&se->post, &argse.post);
3627   ptr = argse.expr;
3628
3629   arg = arg->next;
3630   type = gfc_typenode_for_spec (&expr->ts);
3631
3632   if (expr->ts.type == BT_CHARACTER)
3633     {
3634       ptr = convert (build_pointer_type (type), ptr);
3635       gfc_init_se (&argse, NULL);
3636       gfc_conv_expr (&argse, arg->expr);
3637       gfc_add_block_to_block (&se->pre, &argse.pre);
3638       gfc_add_block_to_block (&se->post, &argse.post);
3639       se->expr = ptr;
3640       se->string_length = argse.string_length;
3641     }
3642   else
3643     {
3644       tree moldsize;
3645       tmpdecl = gfc_create_var (type, "transfer");
3646       moldsize = size_in_bytes (type);
3647
3648       /* Use memcpy to do the transfer.  */
3649       tmp = fold_build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3650       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3651                              fold_convert (pvoid_type_node, tmp),
3652                              fold_convert (pvoid_type_node, ptr),
3653                              moldsize);
3654       gfc_add_expr_to_block (&se->pre, tmp);
3655
3656       se->expr = tmpdecl;
3657     }
3658 }
3659
3660
3661 /* Generate code for the ALLOCATED intrinsic.
3662    Generate inline code that directly check the address of the argument.  */
3663
3664 static void
3665 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3666 {
3667   gfc_actual_arglist *arg1;
3668   gfc_se arg1se;
3669   gfc_ss *ss1;
3670   tree tmp;
3671
3672   gfc_init_se (&arg1se, NULL);
3673   arg1 = expr->value.function.actual;
3674   ss1 = gfc_walk_expr (arg1->expr);
3675   arg1se.descriptor_only = 1;
3676   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3677
3678   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3679   tmp = fold_build2 (NE_EXPR, boolean_type_node,
3680                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
3681   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3682 }
3683
3684
3685 /* Generate code for the ASSOCIATED intrinsic.
3686    If both POINTER and TARGET are arrays, generate a call to library function
3687    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3688    In other cases, generate inline code that directly compare the address of
3689    POINTER with the address of TARGET.  */
3690
3691 static void
3692 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3693 {
3694   gfc_actual_arglist *arg1;
3695   gfc_actual_arglist *arg2;
3696   gfc_se arg1se;
3697   gfc_se arg2se;
3698   tree tmp2;
3699   tree tmp;
3700   tree nonzero_charlen;
3701   tree nonzero_arraylen;
3702   gfc_ss *ss1, *ss2;
3703
3704   gfc_init_se (&arg1se, NULL);
3705   gfc_init_se (&arg2se, NULL);
3706   arg1 = expr->value.function.actual;
3707   arg2 = arg1->next;
3708   ss1 = gfc_walk_expr (arg1->expr);
3709
3710   if (!arg2->expr)
3711     {
3712       /* No optional target.  */
3713       if (ss1 == gfc_ss_terminator)
3714         {
3715           /* A pointer to a scalar.  */
3716           arg1se.want_pointer = 1;
3717           gfc_conv_expr (&arg1se, arg1->expr);
3718           tmp2 = arg1se.expr;
3719         }
3720       else
3721         {
3722           /* A pointer to an array.  */
3723           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3724           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3725         }
3726       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3727       gfc_add_block_to_block (&se->post, &arg1se.post);
3728       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
3729                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3730       se->expr = tmp;
3731     }
3732   else
3733     {
3734       /* An optional target.  */
3735       ss2 = gfc_walk_expr (arg2->expr);
3736
3737       nonzero_charlen = NULL_TREE;
3738       if (arg1->expr->ts.type == BT_CHARACTER)
3739         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
3740                                        arg1->expr->ts.cl->backend_decl,
3741                                        integer_zero_node);
3742
3743       if (ss1 == gfc_ss_terminator)
3744         {
3745           /* A pointer to a scalar.  */
3746           gcc_assert (ss2 == gfc_ss_terminator);
3747           arg1se.want_pointer = 1;
3748           gfc_conv_expr (&arg1se, arg1->expr);
3749           arg2se.want_pointer = 1;
3750           gfc_conv_expr (&arg2se, arg2->expr);
3751           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3752           gfc_add_block_to_block (&se->post, &arg1se.post);
3753           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
3754                              arg1se.expr, arg2se.expr);
3755           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
3756                               arg1se.expr, null_pointer_node);
3757           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3758                                   tmp, tmp2);
3759         }
3760       else
3761         {
3762           /* An array pointer of zero length is not associated if target is
3763              present.  */
3764           arg1se.descriptor_only = 1;
3765           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3766           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3767                                             gfc_rank_cst[arg1->expr->rank - 1]);
3768           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
3769                                           build_int_cst (TREE_TYPE (tmp), 0));
3770
3771           /* A pointer to an array, call library function _gfor_associated.  */
3772           gcc_assert (ss2 != gfc_ss_terminator);
3773           arg1se.want_pointer = 1;
3774           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3775
3776           arg2se.want_pointer = 1;
3777           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3778           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3779           gfc_add_block_to_block (&se->post, &arg2se.post);
3780           se->expr = build_call_expr (gfor_fndecl_associated, 2,
3781                                       arg1se.expr, arg2se.expr);
3782           se->expr = convert (boolean_type_node, se->expr);
3783           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3784                                   se->expr, nonzero_arraylen);
3785         }
3786
3787       /* If target is present zero character length pointers cannot
3788          be associated.  */
3789       if (nonzero_charlen != NULL_TREE)
3790         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3791                                 se->expr, nonzero_charlen);
3792     }
3793
3794   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3795 }
3796
3797
3798 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
3799
3800 static void
3801 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
3802 {
3803   tree args[2];
3804
3805   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3806   se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
3807   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3808 }
3809
3810
3811 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3812
3813 static void
3814 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3815 {
3816   tree arg, type;
3817
3818   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3819
3820   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
3821   type = gfc_get_int_type (4);
3822   arg = build_fold_addr_expr (fold_convert (type, arg));
3823
3824   /* Convert it to the required type.  */
3825   type = gfc_typenode_for_spec (&expr->ts);
3826   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3827   se->expr = fold_convert (type, se->expr);
3828 }
3829
3830
3831 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3832
3833 static void
3834 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3835 {
3836   gfc_actual_arglist *actual;
3837   tree args, type;
3838   gfc_se argse;
3839
3840   args = NULL_TREE;
3841   for (actual = expr->value.function.actual; actual; actual = actual->next)
3842     {
3843       gfc_init_se (&argse, se);
3844
3845       /* Pass a NULL pointer for an absent arg.  */
3846       if (actual->expr == NULL)
3847         argse.expr = null_pointer_node;
3848       else
3849         {
3850           gfc_typespec ts;
3851           gfc_clear_ts (&ts);
3852
3853           if (actual->expr->ts.kind != gfc_c_int_kind)
3854             {
3855               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
3856               ts.type = BT_INTEGER;
3857               ts.kind = gfc_c_int_kind;
3858               gfc_convert_type (actual->expr, &ts, 2);
3859             }
3860           gfc_conv_expr_reference (&argse, actual->expr);
3861         }
3862
3863       gfc_add_block_to_block (&se->pre, &argse.pre);
3864       gfc_add_block_to_block (&se->post, &argse.post);
3865       args = gfc_chainon_list (args, argse.expr);
3866     }
3867
3868   /* Convert it to the required type.  */
3869   type = gfc_typenode_for_spec (&expr->ts);
3870   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3871   se->expr = fold_convert (type, se->expr);
3872 }
3873
3874
3875 /* Generate code for TRIM (A) intrinsic function.  */
3876
3877 static void
3878 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3879 {
3880   tree var;
3881   tree len;
3882   tree addr;
3883   tree tmp;
3884   tree cond;
3885   tree fndecl;
3886   tree function;
3887   tree *args;
3888   unsigned int num_args;
3889
3890   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3891   args = alloca (sizeof (tree) * num_args);
3892
3893   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
3894   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3895   len = gfc_create_var (gfc_get_int_type (4), "len");
3896
3897   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3898   args[0] = build_fold_addr_expr (len);
3899   args[1] = addr;
3900
3901   if (expr->ts.kind == 1)
3902     function = gfor_fndecl_string_trim;
3903   else if (expr->ts.kind == 4)
3904     function = gfor_fndecl_string_trim_char4;
3905   else
3906     gcc_unreachable ();
3907
3908   fndecl = build_addr (function, current_function_decl);
3909   tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
3910                           num_args, args);
3911   gfc_add_expr_to_block (&se->pre, tmp);
3912
3913   /* Free the temporary afterwards, if necessary.  */
3914   cond = fold_build2 (GT_EXPR, boolean_type_node,
3915                       len, build_int_cst (TREE_TYPE (len), 0));
3916   tmp = gfc_call_free (var);
3917   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3918   gfc_add_expr_to_block (&se->post, tmp);
3919
3920   se->expr = var;
3921   se->string_length = len;
3922 }
3923
3924
3925 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3926
3927 static void
3928 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3929 {
3930   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3931   tree type, cond, tmp, count, exit_label, n, max, largest;
3932   tree size;
3933   stmtblock_t block, body;
3934   int i;
3935
3936   /* We store in charsize the size of a character.  */
3937   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
3938   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
3939
3940   /* Get the arguments.  */
3941   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3942   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3943   src = args[1];
3944   ncopies = gfc_evaluate_now (args[2], &se->pre);
3945   ncopies_type = TREE_TYPE (ncopies);
3946
3947   /* Check that NCOPIES is not negative.  */
3948   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3949                       build_int_cst (ncopies_type, 0));
3950   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3951                            "Argument NCOPIES of REPEAT intrinsic is negative "
3952                            "(its value is %lld)",
3953                            fold_convert (long_integer_type_node, ncopies));
3954
3955   /* If the source length is zero, any non negative value of NCOPIES
3956      is valid, and nothing happens.  */
3957   n = gfc_create_var (ncopies_type, "ncopies");
3958   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3959                       build_int_cst (size_type_node, 0));
3960   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3961                      build_int_cst (ncopies_type, 0), ncopies);
3962   gfc_add_modify_expr (&se->pre, n, tmp);
3963   ncopies = n;
3964
3965   /* Check that ncopies is not too large: ncopies should be less than
3966      (or equal to) MAX / slen, where MAX is the maximal integer of
3967      the gfc_charlen_type_node type.  If slen == 0, we need a special
3968      case to avoid the division by zero.  */
3969   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3970   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3971   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3972                      fold_convert (size_type_node, max), slen);
3973   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3974               ? size_type_node : ncopies_type;
3975   cond = fold_build2 (GT_EXPR, boolean_type_node,
3976                       fold_convert (largest, ncopies),
3977                       fold_convert (largest, max));
3978   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3979                      build_int_cst (size_type_node, 0));
3980   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3981                       cond);
3982   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3983                            "Argument NCOPIES of REPEAT intrinsic is too large");
3984
3985   /* Compute the destination length.  */
3986   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3987                       fold_convert (gfc_charlen_type_node, slen),
3988                       fold_convert (gfc_charlen_type_node, ncopies));
3989   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3990   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3991
3992   /* Generate the code to do the repeat operation:
3993        for (i = 0; i < ncopies; i++)
3994          memmove (dest + (i * slen * size), src, slen*size);  */
3995   gfc_start_block (&block);
3996   count = gfc_create_var (ncopies_type, "count");
3997   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3998   exit_label = gfc_build_label_decl (NULL_TREE);
3999
4000   /* Start the loop body.  */
4001   gfc_start_block (&body);
4002
4003   /* Exit the loop if count >= ncopies.  */
4004   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4005   tmp = build1_v (GOTO_EXPR, exit_label);
4006   TREE_USED (exit_label) = 1;
4007   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4008                      build_empty_stmt ());
4009   gfc_add_expr_to_block (&body, tmp);
4010
4011   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4012   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4013                      fold_convert (gfc_charlen_type_node, slen),
4014                      fold_convert (gfc_charlen_type_node, count));
4015   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4016                      tmp, fold_convert (gfc_charlen_type_node, size));
4017   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4018                      fold_convert (pvoid_type_node, dest),
4019                      fold_convert (sizetype, tmp));
4020   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4021                          fold_build2 (MULT_EXPR, size_type_node, slen,
4022                                       fold_convert (size_type_node, size)));
4023   gfc_add_expr_to_block (&body, tmp);
4024
4025   /* Increment count.  */
4026   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4027                      count, build_int_cst (TREE_TYPE (count), 1));
4028   gfc_add_modify_expr (&body, count, tmp);
4029
4030   /* Build the loop.  */
4031   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4032   gfc_add_expr_to_block (&block, tmp);
4033
4034   /* Add the exit label.  */
4035   tmp = build1_v (LABEL_EXPR, exit_label);
4036   gfc_add_expr_to_block (&block, tmp);
4037
4038   /* Finish the block.  */
4039   tmp = gfc_finish_block (&block);
4040   gfc_add_expr_to_block (&se->pre, tmp);
4041
4042   /* Set the result value.  */
4043   se->expr = dest;
4044   se->string_length = dlen;
4045 }
4046
4047
4048 /* Generate code for the IARGC intrinsic.  */
4049
4050 static void
4051 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4052 {
4053   tree tmp;
4054   tree fndecl;
4055   tree type;
4056
4057   /* Call the library function.  This always returns an INTEGER(4).  */
4058   fndecl = gfor_fndecl_iargc;
4059   tmp = build_call_expr (fndecl, 0);
4060
4061   /* Convert it to the required type.  */
4062   type = gfc_typenode_for_spec (&expr->ts);
4063   tmp = fold_convert (type, tmp);
4064
4065   se->expr = tmp;
4066 }
4067
4068
4069 /* The loc intrinsic returns the address of its argument as
4070    gfc_index_integer_kind integer.  */
4071
4072 static void
4073 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4074 {
4075   tree temp_var;
4076   gfc_expr *arg_expr;
4077   gfc_ss *ss;
4078
4079   gcc_assert (!se->ss);
4080
4081   arg_expr = expr->value.function.actual->expr;
4082   ss = gfc_walk_expr (arg_expr);
4083   if (ss == gfc_ss_terminator)
4084     gfc_conv_expr_reference (se, arg_expr);
4085   else
4086     gfc_conv_array_parameter (se, arg_expr, ss, 1);
4087   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4088
4089   /* Create a temporary variable for loc return value.  Without this,
4090      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4091   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4092   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
4093   se->expr = temp_var;
4094 }
4095
4096 /* Generate code for an intrinsic function.  Some map directly to library
4097    calls, others get special handling.  In some cases the name of the function
4098    used depends on the type specifiers.  */
4099
4100 void
4101 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4102 {
4103   gfc_intrinsic_sym *isym;
4104   const char *name;
4105   int lib, kind;
4106   tree fndecl;
4107
4108   isym = expr->value.function.isym;
4109
4110   name = &expr->value.function.name[2];
4111
4112   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4113     {
4114       lib = gfc_is_intrinsic_libcall (expr);
4115       if (lib != 0)
4116         {
4117           if (lib == 1)
4118             se->ignore_optional = 1;
4119           gfc_conv_intrinsic_funcall (se, expr);
4120           return;
4121         }
4122     }
4123
4124   switch (expr->value.function.isym->id)
4125     {
4126     case GFC_ISYM_NONE:
4127       gcc_unreachable ();
4128
4129     case GFC_ISYM_REPEAT:
4130       gfc_conv_intrinsic_repeat (se, expr);
4131       break;
4132
4133     case GFC_ISYM_TRIM:
4134       gfc_conv_intrinsic_trim (se, expr);
4135       break;
4136
4137     case GFC_ISYM_SC_KIND:
4138       gfc_conv_intrinsic_sc_kind (se, expr);
4139       break;
4140
4141     case GFC_ISYM_SI_KIND:
4142       gfc_conv_intrinsic_si_kind (se, expr);
4143       break;
4144
4145     case GFC_ISYM_SR_KIND:
4146       gfc_conv_intrinsic_sr_kind (se, expr);
4147       break;
4148
4149     case GFC_ISYM_EXPONENT:
4150       gfc_conv_intrinsic_exponent (se, expr);
4151       break;
4152
4153     case GFC_ISYM_SCAN:
4154       kind = expr->value.function.actual->expr->ts.kind;
4155       if (kind == 1)
4156        fndecl = gfor_fndecl_string_scan;
4157       else if (kind == 4)
4158        fndecl = gfor_fndecl_string_scan_char4;
4159       else
4160        gcc_unreachable ();
4161
4162       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4163       break;
4164
4165     case GFC_ISYM_VERIFY:
4166       kind = expr->value.function.actual->expr->ts.kind;
4167       if (kind == 1)
4168        fndecl = gfor_fndecl_string_verify;
4169       else if (kind == 4)
4170        fndecl = gfor_fndecl_string_verify_char4;
4171       else
4172        gcc_unreachable ();
4173
4174       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4175       break;
4176
4177     case GFC_ISYM_ALLOCATED:
4178       gfc_conv_allocated (se, expr);
4179       break;
4180
4181     case GFC_ISYM_ASSOCIATED:
4182       gfc_conv_associated(se, expr);
4183       break;
4184
4185     case GFC_ISYM_ABS:
4186       gfc_conv_intrinsic_abs (se, expr);
4187       break;
4188
4189     case GFC_ISYM_ADJUSTL:
4190       if (expr->ts.kind == 1)
4191        fndecl = gfor_fndecl_adjustl;
4192       else if (expr->ts.kind == 4)
4193        fndecl = gfor_fndecl_adjustl_char4;
4194       else
4195        gcc_unreachable ();
4196
4197       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4198       break;
4199
4200     case GFC_ISYM_ADJUSTR:
4201       if (expr->ts.kind == 1)
4202        fndecl = gfor_fndecl_adjustr;
4203       else if (expr->ts.kind == 4)
4204        fndecl = gfor_fndecl_adjustr_char4;
4205       else
4206        gcc_unreachable ();
4207
4208       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4209       break;
4210
4211     case GFC_ISYM_AIMAG:
4212       gfc_conv_intrinsic_imagpart (se, expr);
4213       break;
4214
4215     case GFC_ISYM_AINT:
4216       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4217       break;
4218
4219     case GFC_ISYM_ALL:
4220       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4221       break;
4222
4223     case GFC_ISYM_ANINT:
4224       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4225       break;
4226
4227     case GFC_ISYM_AND:
4228       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4229       break;
4230
4231     case GFC_ISYM_ANY:
4232       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4233       break;
4234
4235     case GFC_ISYM_BTEST:
4236       gfc_conv_intrinsic_btest (se, expr);
4237       break;
4238
4239     case GFC_ISYM_ACHAR:
4240     case GFC_ISYM_CHAR:
4241       gfc_conv_intrinsic_char (se, expr);
4242       break;
4243
4244     case GFC_ISYM_CONVERSION:
4245     case GFC_ISYM_REAL:
4246     case GFC_ISYM_LOGICAL:
4247     case GFC_ISYM_DBLE:
4248       gfc_conv_intrinsic_conversion (se, expr);
4249       break;
4250
4251       /* Integer conversions are handled separately to make sure we get the
4252          correct rounding mode.  */
4253     case GFC_ISYM_INT:
4254     case GFC_ISYM_INT2:
4255     case GFC_ISYM_INT8:
4256     case GFC_ISYM_LONG:
4257       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4258       break;
4259
4260     case GFC_ISYM_NINT:
4261       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4262       break;
4263
4264     case GFC_ISYM_CEILING:
4265       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4266       break;
4267
4268     case GFC_ISYM_FLOOR:
4269       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4270       break;
4271
4272     case GFC_ISYM_MOD:
4273       gfc_conv_intrinsic_mod (se, expr, 0);
4274       break;
4275
4276     case GFC_ISYM_MODULO:
4277       gfc_conv_intrinsic_mod (se, expr, 1);
4278       break;
4279
4280     case GFC_ISYM_CMPLX:
4281       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4282       break;
4283
4284     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4285       gfc_conv_intrinsic_iargc (se, expr);
4286       break;
4287
4288     case GFC_ISYM_COMPLEX:
4289       gfc_conv_intrinsic_cmplx (se, expr, 1);
4290       break;
4291
4292     case GFC_ISYM_CONJG:
4293       gfc_conv_intrinsic_conjg (se, expr);
4294       break;
4295
4296     case GFC_ISYM_COUNT:
4297       gfc_conv_intrinsic_count (se, expr);
4298       break;
4299
4300     case GFC_ISYM_CTIME:
4301       gfc_conv_intrinsic_ctime (se, expr);
4302       break;
4303
4304     case GFC_ISYM_DIM:
4305       gfc_conv_intrinsic_dim (se, expr);
4306       break;
4307
4308     case GFC_ISYM_DOT_PRODUCT:
4309       gfc_conv_intrinsic_dot_product (se, expr);
4310       break;
4311
4312     case GFC_ISYM_DPROD:
4313       gfc_conv_intrinsic_dprod (se, expr);
4314       break;
4315
4316     case GFC_ISYM_FDATE:
4317       gfc_conv_intrinsic_fdate (se, expr);
4318       break;
4319
4320     case GFC_ISYM_FRACTION:
4321       gfc_conv_intrinsic_fraction (se, expr);
4322       break;
4323
4324     case GFC_ISYM_IAND:
4325       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4326       break;
4327
4328     case GFC_ISYM_IBCLR:
4329       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4330       break;
4331
4332     case GFC_ISYM_IBITS:
4333       gfc_conv_intrinsic_ibits (se, expr);
4334       break;
4335
4336     case GFC_ISYM_IBSET:
4337       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4338       break;
4339
4340     case GFC_ISYM_IACHAR:
4341     case GFC_ISYM_ICHAR:
4342       /* We assume ASCII character sequence.  */
4343       gfc_conv_intrinsic_ichar (se, expr);
4344       break;
4345
4346     case GFC_ISYM_IARGC:
4347       gfc_conv_intrinsic_iargc (se, expr);
4348       break;
4349
4350     case GFC_ISYM_IEOR:
4351       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4352       break;
4353
4354     case GFC_ISYM_INDEX:
4355       kind = expr->value.function.actual->expr->ts.kind;
4356       if (kind == 1)
4357        fndecl = gfor_fndecl_string_index;
4358       else if (kind == 4)
4359        fndecl = gfor_fndecl_string_index_char4;
4360       else
4361        gcc_unreachable ();
4362
4363       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4364       break;
4365
4366     case GFC_ISYM_IOR:
4367       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4368       break;
4369
4370     case GFC_ISYM_IS_IOSTAT_END:
4371       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4372       break;
4373
4374     case GFC_ISYM_IS_IOSTAT_EOR:
4375       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4376       break;
4377
4378     case GFC_ISYM_ISNAN:
4379       gfc_conv_intrinsic_isnan (se, expr);
4380       break;
4381
4382     case GFC_ISYM_LSHIFT:
4383       gfc_conv_intrinsic_rlshift (se, expr, 0);
4384       break;
4385
4386     case GFC_ISYM_RSHIFT:
4387       gfc_conv_intrinsic_rlshift (se, expr, 1);
4388       break;
4389
4390     case GFC_ISYM_ISHFT:
4391       gfc_conv_intrinsic_ishft (se, expr);
4392       break;
4393
4394     case GFC_ISYM_ISHFTC:
4395       gfc_conv_intrinsic_ishftc (se, expr);
4396       break;
4397
4398     case GFC_ISYM_LBOUND:
4399       gfc_conv_intrinsic_bound (se, expr, 0);
4400       break;
4401
4402     case GFC_ISYM_TRANSPOSE:
4403       if (se->ss && se->ss->useflags)
4404         {
4405           gfc_conv_tmp_array_ref (se);
4406           gfc_advance_se_ss_chain (se);
4407         }
4408       else
4409         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4410       break;
4411
4412     case GFC_ISYM_LEN:
4413       gfc_conv_intrinsic_len (se, expr);
4414       break;
4415
4416     case GFC_ISYM_LEN_TRIM:
4417       gfc_conv_intrinsic_len_trim (se, expr);
4418       break;
4419
4420     case GFC_ISYM_LGE:
4421       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4422       break;
4423
4424     case GFC_ISYM_LGT:
4425       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4426       break;
4427
4428     case GFC_ISYM_LLE:
4429       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4430       break;
4431
4432     case GFC_ISYM_LLT:
4433       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4434       break;
4435
4436     case GFC_ISYM_MAX:
4437       if (expr->ts.type == BT_CHARACTER)
4438         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4439       else
4440         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4441       break;
4442
4443     case GFC_ISYM_MAXLOC:
4444       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4445       break;
4446
4447     case GFC_ISYM_MAXVAL:
4448       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4449       break;
4450
4451     case GFC_ISYM_MERGE:
4452       gfc_conv_intrinsic_merge (se, expr);
4453       break;
4454
4455     case GFC_ISYM_MIN:
4456       if (expr->ts.type == BT_CHARACTER)
4457         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4458       else
4459         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4460       break;
4461
4462     case GFC_ISYM_MINLOC:
4463       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4464       break;
4465
4466     case GFC_ISYM_MINVAL:
4467       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4468       break;
4469
4470     case GFC_ISYM_NEAREST:
4471       gfc_conv_intrinsic_nearest (se, expr);
4472       break;
4473
4474     case GFC_ISYM_NOT:
4475       gfc_conv_intrinsic_not (se, expr);
4476       break;
4477
4478     case GFC_ISYM_OR:
4479       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4480       break;
4481
4482     case GFC_ISYM_PRESENT:
4483       gfc_conv_intrinsic_present (se, expr);
4484       break;
4485
4486     case GFC_ISYM_PRODUCT:
4487       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4488       break;
4489
4490     case GFC_ISYM_RRSPACING:
4491       gfc_conv_intrinsic_rrspacing (se, expr);
4492       break;
4493
4494     case GFC_ISYM_SET_EXPONENT:
4495       gfc_conv_intrinsic_set_exponent (se, expr);
4496       break;
4497
4498     case GFC_ISYM_SCALE:
4499       gfc_conv_intrinsic_scale (se, expr);
4500       break;
4501
4502     case GFC_ISYM_SIGN:
4503       gfc_conv_intrinsic_sign (se, expr);
4504       break;
4505
4506     case GFC_ISYM_SIZE:
4507       gfc_conv_intrinsic_size (se, expr);
4508       break;
4509
4510     case GFC_ISYM_SIZEOF:
4511       gfc_conv_intrinsic_sizeof (se, expr);
4512       break;
4513
4514     case GFC_ISYM_SPACING:
4515       gfc_conv_intrinsic_spacing (se, expr);
4516       break;
4517
4518     case GFC_ISYM_SUM:
4519       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4520       break;
4521
4522     case GFC_ISYM_TRANSFER:
4523       if (se->ss)
4524         {
4525           if (se->ss->useflags)
4526             {
4527               /* Access the previously obtained result.  */
4528               gfc_conv_tmp_array_ref (se);
4529               gfc_advance_se_ss_chain (se);
4530               break;
4531             }
4532           else
4533             gfc_conv_intrinsic_array_transfer (se, expr);
4534         }
4535       else
4536         gfc_conv_intrinsic_transfer (se, expr);
4537       break;
4538
4539     case GFC_ISYM_TTYNAM:
4540       gfc_conv_intrinsic_ttynam (se, expr);
4541       break;
4542
4543     case GFC_ISYM_UBOUND:
4544       gfc_conv_intrinsic_bound (se, expr, 1);
4545       break;
4546
4547     case GFC_ISYM_XOR:
4548       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4549       break;
4550
4551     case GFC_ISYM_LOC:
4552       gfc_conv_intrinsic_loc (se, expr);
4553       break;
4554
4555     case GFC_ISYM_ACCESS:
4556     case GFC_ISYM_CHDIR:
4557     case GFC_ISYM_CHMOD:
4558     case GFC_ISYM_DTIME:
4559     case GFC_ISYM_ETIME:
4560     case GFC_ISYM_FGET:
4561     case GFC_ISYM_FGETC:
4562     case GFC_ISYM_FNUM:
4563     case GFC_ISYM_FPUT:
4564     case GFC_ISYM_FPUTC:
4565     case GFC_ISYM_FSTAT:
4566     case GFC_ISYM_FTELL:
4567     case GFC_ISYM_GETCWD:
4568     case GFC_ISYM_GETGID:
4569     case GFC_ISYM_GETPID:
4570     case GFC_ISYM_GETUID:
4571     case GFC_ISYM_HOSTNM:
4572     case GFC_ISYM_KILL:
4573     case GFC_ISYM_IERRNO:
4574     case GFC_ISYM_IRAND:
4575     case GFC_ISYM_ISATTY:
4576     case GFC_ISYM_LINK:
4577     case GFC_ISYM_LSTAT:
4578     case GFC_ISYM_MALLOC:
4579     case GFC_ISYM_MATMUL:
4580     case GFC_ISYM_MCLOCK:
4581     case GFC_ISYM_MCLOCK8:
4582     case GFC_ISYM_RAND:
4583     case GFC_ISYM_RENAME:
4584     case GFC_ISYM_SECOND:
4585     case GFC_ISYM_SECNDS:
4586     case GFC_ISYM_SIGNAL:
4587     case GFC_ISYM_STAT:
4588     case GFC_ISYM_SYMLNK:
4589     case GFC_ISYM_SYSTEM:
4590     case GFC_ISYM_TIME:
4591     case GFC_ISYM_TIME8:
4592     case GFC_ISYM_UMASK:
4593     case GFC_ISYM_UNLINK:
4594       gfc_conv_intrinsic_funcall (se, expr);
4595       break;
4596
4597     default:
4598       gfc_conv_intrinsic_lib_function (se, expr);
4599       break;
4600     }
4601 }
4602
4603
4604 /* This generates code to execute before entering the scalarization loop.
4605    Currently does nothing.  */
4606
4607 void
4608 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4609 {
4610   switch (ss->expr->value.function.isym->id)
4611     {
4612     case GFC_ISYM_UBOUND:
4613     case GFC_ISYM_LBOUND:
4614       break;
4615
4616     default:
4617       gcc_unreachable ();
4618     }
4619 }
4620
4621
4622 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4623    inside the scalarization loop.  */
4624
4625 static gfc_ss *
4626 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4627 {
4628   gfc_ss *newss;
4629
4630   /* The two argument version returns a scalar.  */
4631   if (expr->value.function.actual->next->expr)
4632     return ss;
4633
4634   newss = gfc_get_ss ();
4635   newss->type = GFC_SS_INTRINSIC;
4636   newss->expr = expr;
4637   newss->next = ss;
4638   newss->data.info.dimen = 1;
4639
4640   return newss;
4641 }
4642
4643
4644 /* Walk an intrinsic array libcall.  */
4645
4646 static gfc_ss *
4647 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4648 {
4649   gfc_ss *newss;
4650
4651   gcc_assert (expr->rank > 0);
4652
4653   newss = gfc_get_ss ();
4654   newss->type = GFC_SS_FUNCTION;
4655   newss->expr = expr;
4656   newss->next = ss;
4657   newss->data.info.dimen = expr->rank;
4658
4659   return newss;
4660 }
4661
4662
4663 /* Returns nonzero if the specified intrinsic function call maps directly to a
4664    an external library call.  Should only be used for functions that return
4665    arrays.  */
4666
4667 int
4668 gfc_is_intrinsic_libcall (gfc_expr * expr)
4669 {
4670   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4671   gcc_assert (expr->rank > 0);
4672
4673   switch (expr->value.function.isym->id)
4674     {
4675     case GFC_ISYM_ALL:
4676     case GFC_ISYM_ANY:
4677     case GFC_ISYM_COUNT:
4678     case GFC_ISYM_MATMUL:
4679     case GFC_ISYM_MAXLOC:
4680     case GFC_ISYM_MAXVAL:
4681     case GFC_ISYM_MINLOC:
4682     case GFC_ISYM_MINVAL:
4683     case GFC_ISYM_PRODUCT:
4684     case GFC_ISYM_SUM:
4685     case GFC_ISYM_SHAPE:
4686     case GFC_ISYM_SPREAD:
4687     case GFC_ISYM_TRANSPOSE:
4688       /* Ignore absent optional parameters.  */
4689       return 1;
4690
4691     case GFC_ISYM_RESHAPE:
4692     case GFC_ISYM_CSHIFT:
4693     case GFC_ISYM_EOSHIFT:
4694     case GFC_ISYM_PACK:
4695     case GFC_ISYM_UNPACK:
4696       /* Pass absent optional parameters.  */
4697       return 2;
4698
4699     default:
4700       return 0;
4701     }
4702 }
4703
4704 /* Walk an intrinsic function.  */
4705 gfc_ss *
4706 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4707                              gfc_intrinsic_sym * isym)
4708 {
4709   gcc_assert (isym);
4710
4711   if (isym->elemental)
4712     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4713
4714   if (expr->rank == 0)
4715     return ss;
4716
4717   if (gfc_is_intrinsic_libcall (expr))
4718     return gfc_walk_intrinsic_libfunc (ss, expr);
4719
4720   /* Special cases.  */
4721   switch (isym->id)
4722     {
4723     case GFC_ISYM_LBOUND:
4724     case GFC_ISYM_UBOUND:
4725       return gfc_walk_intrinsic_bound (ss, expr);
4726
4727     case GFC_ISYM_TRANSFER:
4728       return gfc_walk_intrinsic_libfunc (ss, expr);
4729
4730     default:
4731       /* This probably meant someone forgot to add an intrinsic to the above
4732          list(s) when they implemented it, or something's gone horribly
4733          wrong.  */
4734       gcc_unreachable ();
4735     }
4736 }
4737
4738 #include "gt-fortran-trans-intrinsic.h"