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