gcc/fortran/trans-intrinsic.c

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