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 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2769
2770 static void
2771 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2772 {
2773   tree tsource;
2774   tree fsource;
2775   tree mask;
2776   tree type;
2777   tree len;
2778   tree *args;
2779   unsigned int num_args;
2780
2781   num_args = gfc_intrinsic_argument_list_length (expr);
2782   args = alloca (sizeof (tree) * num_args);
2783
2784   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2785   if (expr->ts.type != BT_CHARACTER)
2786     {
2787       tsource = args[0];
2788       fsource = args[1];
2789       mask = args[2];
2790     }
2791   else
2792     {
2793       /* We do the same as in the non-character case, but the argument
2794          list is different because of the string length arguments. We
2795          also have to set the string length for the result.  */
2796       len = args[0];
2797       tsource = args[1];
2798       fsource = args[3];
2799       mask = args[4];
2800
2801       se->string_length = len;
2802     }
2803   type = TREE_TYPE (tsource);
2804   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2805 }
2806
2807
2808 static void
2809 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2810 {
2811   gfc_actual_arglist *actual;
2812   tree arg1;
2813   tree type;
2814   tree fncall0;
2815   tree fncall1;
2816   gfc_se argse;
2817   gfc_ss *ss;
2818
2819   gfc_init_se (&argse, NULL);
2820   actual = expr->value.function.actual;
2821
2822   ss = gfc_walk_expr (actual->expr);
2823   gcc_assert (ss != gfc_ss_terminator);
2824   argse.want_pointer = 1;
2825   argse.data_not_needed = 1;
2826   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2827   gfc_add_block_to_block (&se->pre, &argse.pre);
2828   gfc_add_block_to_block (&se->post, &argse.post);
2829   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2830
2831   /* Build the call to size0.  */
2832   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2833
2834   actual = actual->next;
2835
2836   if (actual->expr)
2837     {
2838       gfc_init_se (&argse, NULL);
2839       gfc_conv_expr_type (&argse, actual->expr,
2840                           gfc_array_index_type);
2841       gfc_add_block_to_block (&se->pre, &argse.pre);
2842
2843       /* Build the call to size1.  */
2844       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2845                                  arg1, argse.expr);
2846
2847       /* Unusually, for an intrinsic, size does not exclude
2848          an optional arg2, so we must test for it.  */
2849       if (actual->expr->expr_type == EXPR_VARIABLE
2850             && actual->expr->symtree->n.sym->attr.dummy
2851             && actual->expr->symtree->n.sym->attr.optional)
2852         {
2853           tree tmp;
2854           gfc_init_se (&argse, NULL);
2855           argse.want_pointer = 1;
2856           argse.data_not_needed = 1;
2857           gfc_conv_expr (&argse, actual->expr);
2858           gfc_add_block_to_block (&se->pre, &argse.pre);
2859           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2860                         null_pointer_node);
2861           tmp = gfc_evaluate_now (tmp, &se->pre);
2862           se->expr = build3 (COND_EXPR, pvoid_type_node,
2863                              tmp, fncall1, fncall0);
2864         }
2865       else
2866         se->expr = fncall1;
2867     }
2868   else
2869     se->expr = fncall0;
2870
2871   type = gfc_typenode_for_spec (&expr->ts);
2872   se->expr = convert (type, se->expr);
2873 }
2874
2875
2876 static void
2877 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2878 {
2879   gfc_expr *arg;
2880   gfc_ss *ss;
2881   gfc_se argse;
2882   tree source;
2883   tree source_bytes;
2884   tree type;
2885   tree tmp;
2886   tree lower;
2887   tree upper;
2888   /*tree stride;*/
2889   int n;
2890
2891   arg = expr->value.function.actual->expr;
2892
2893   gfc_init_se (&argse, NULL);
2894   ss = gfc_walk_expr (arg);
2895
2896   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2897
2898   if (ss == gfc_ss_terminator)
2899     {
2900       gfc_conv_expr_reference (&argse, arg);
2901       source = argse.expr;
2902
2903       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2904
2905       /* Obtain the source word length.  */
2906       if (arg->ts.type == BT_CHARACTER)
2907         source_bytes = fold_convert (gfc_array_index_type,
2908                                      argse.string_length);
2909       else
2910         source_bytes = fold_convert (gfc_array_index_type,
2911                                      size_in_bytes (type));
2912     }
2913   else
2914     {
2915       argse.want_pointer = 0;
2916       gfc_conv_expr_descriptor (&argse, arg, ss);
2917       source = gfc_conv_descriptor_data_get (argse.expr);
2918       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2919
2920       /* Obtain the argument's word length.  */
2921       if (arg->ts.type == BT_CHARACTER)
2922         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2923       else
2924         tmp = fold_convert (gfc_array_index_type,
2925                             size_in_bytes (type));
2926       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2927
2928       /* Obtain the size of the array in bytes.  */
2929       for (n = 0; n < arg->rank; n++)
2930         {
2931           tree idx;
2932           idx = gfc_rank_cst[n];
2933           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2934           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2935           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2936                              upper, lower);
2937           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2938                              tmp, gfc_index_one_node);
2939           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2940                              tmp, source_bytes);
2941           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2942         }
2943     }
2944
2945   gfc_add_block_to_block (&se->pre, &argse.pre);
2946   se->expr = source_bytes;
2947 }
2948
2949
2950 /* Intrinsic string comparison functions.  */
2951
2952 static void
2953 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2954 {
2955   tree type;
2956   tree args[4];
2957
2958   gfc_conv_intrinsic_function_args (se, expr, args, 4);
2959
2960   se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
2961   type = gfc_typenode_for_spec (&expr->ts);
2962   se->expr = fold_build2 (op, type, se->expr,
2963                      build_int_cst (TREE_TYPE (se->expr), 0));
2964 }
2965
2966 /* Generate a call to the adjustl/adjustr library function.  */
2967 static void
2968 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2969 {
2970   tree args[3];
2971   tree len;
2972   tree type;
2973   tree var;
2974   tree tmp;
2975
2976   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
2977   len = args[1];
2978
2979   type = TREE_TYPE (args[2]);
2980   var = gfc_conv_string_tmp (se, type, len);
2981   args[0] = var;
2982
2983   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
2984   gfc_add_expr_to_block (&se->pre, tmp);
2985   se->expr = var;
2986   se->string_length = len;
2987 }
2988
2989
2990 /* Array transfer statement.
2991      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2992    where:
2993      typeof<DEST> = typeof<MOLD>
2994    and:
2995      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2996               sizeof (DEST(0) * SIZE).  */
2997
2998 static void
2999 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3000 {
3001   tree tmp;
3002   tree extent;
3003   tree source;
3004   tree source_type;
3005   tree source_bytes;
3006   tree mold_type;
3007   tree dest_word_len;
3008   tree size_words;
3009   tree size_bytes;
3010   tree upper;
3011   tree lower;
3012   tree stride;
3013   tree stmt;
3014   gfc_actual_arglist *arg;
3015   gfc_se argse;
3016   gfc_ss *ss;
3017   gfc_ss_info *info;
3018   stmtblock_t block;
3019   int n;
3020
3021   gcc_assert (se->loop);
3022   info = &se->ss->data.info;
3023
3024   /* Convert SOURCE.  The output from this stage is:-
3025         source_bytes = length of the source in bytes
3026         source = pointer to the source data.  */
3027   arg = expr->value.function.actual;
3028   gfc_init_se (&argse, NULL);
3029   ss = gfc_walk_expr (arg->expr);
3030
3031   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3032
3033   /* Obtain the pointer to source and the length of source in bytes.  */
3034   if (ss == gfc_ss_terminator)
3035     {
3036       gfc_conv_expr_reference (&argse, arg->expr);
3037       source = argse.expr;
3038
3039       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3040
3041       /* Obtain the source word length.  */
3042       if (arg->expr->ts.type == BT_CHARACTER)
3043         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3044       else
3045         tmp = fold_convert (gfc_array_index_type,
3046                             size_in_bytes (source_type));
3047     }
3048   else
3049     {
3050       argse.want_pointer = 0;
3051       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3052       source = gfc_conv_descriptor_data_get (argse.expr);
3053       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3054
3055       /* Repack the source if not a full variable array.  */
3056       if (!(arg->expr->expr_type == EXPR_VARIABLE
3057               && arg->expr->ref->u.ar.type == AR_FULL))
3058         {
3059           tmp = build_fold_addr_expr (argse.expr);
3060           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3061           source = gfc_evaluate_now (source, &argse.pre);
3062
3063           /* Free the temporary.  */
3064           gfc_start_block (&block);
3065           tmp = gfc_call_free (convert (pvoid_type_node, source));
3066           gfc_add_expr_to_block (&block, tmp);
3067           stmt = gfc_finish_block (&block);
3068
3069           /* Clean up if it was repacked.  */
3070           gfc_init_block (&block);
3071           tmp = gfc_conv_array_data (argse.expr);
3072           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3073           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3074           gfc_add_expr_to_block (&block, tmp);
3075           gfc_add_block_to_block (&block, &se->post);
3076           gfc_init_block (&se->post);
3077           gfc_add_block_to_block (&se->post, &block);
3078         }
3079
3080       /* Obtain the source word length.  */
3081       if (arg->expr->ts.type == BT_CHARACTER)
3082         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3083       else
3084         tmp = fold_convert (gfc_array_index_type,
3085                             size_in_bytes (source_type));
3086
3087       /* Obtain the size of the array in bytes.  */
3088       extent = gfc_create_var (gfc_array_index_type, NULL);
3089       for (n = 0; n < arg->expr->rank; n++)
3090         {
3091           tree idx;
3092           idx = gfc_rank_cst[n];
3093           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3094           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3095           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3096           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3097           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3098                              upper, lower);
3099           gfc_add_modify_expr (&argse.pre, extent, tmp);
3100           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3101                              extent, gfc_index_one_node);
3102           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3103                              tmp, source_bytes);
3104         }
3105     }
3106
3107   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3108   gfc_add_block_to_block (&se->pre, &argse.pre);
3109   gfc_add_block_to_block (&se->post, &argse.post);
3110
3111   /* Now convert MOLD.  The outputs are:
3112         mold_type = the TREE type of MOLD
3113         dest_word_len = destination word length in bytes.  */
3114   arg = arg->next;
3115
3116   gfc_init_se (&argse, NULL);
3117   ss = gfc_walk_expr (arg->expr);
3118
3119   if (ss == gfc_ss_terminator)
3120     {
3121       gfc_conv_expr_reference (&argse, arg->expr);
3122       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3123     }
3124   else
3125     {
3126       gfc_init_se (&argse, NULL);
3127       argse.want_pointer = 0;
3128       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3129       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3130     }
3131
3132   if (arg->expr->ts.type == BT_CHARACTER)
3133     {
3134       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3135       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3136     }
3137   else
3138     tmp = fold_convert (gfc_array_index_type,
3139                         size_in_bytes (mold_type));
3140
3141   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3142   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3143
3144   /* Finally convert SIZE, if it is present.  */
3145   arg = arg->next;
3146   size_words = gfc_create_var (gfc_array_index_type, NULL);
3147
3148   if (arg->expr)
3149     {
3150       gfc_init_se (&argse, NULL);
3151       gfc_conv_expr_reference (&argse, arg->expr);
3152       tmp = convert (gfc_array_index_type,
3153                          build_fold_indirect_ref (argse.expr));
3154       gfc_add_block_to_block (&se->pre, &argse.pre);
3155       gfc_add_block_to_block (&se->post, &argse.post);
3156     }
3157   else
3158     tmp = NULL_TREE;
3159
3160   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3161   if (tmp != NULL_TREE)
3162     {
3163       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3164                          tmp, dest_word_len);
3165       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3166                          tmp, source_bytes);
3167     }
3168   else
3169     tmp = source_bytes;
3170
3171   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3172   gfc_add_modify_expr (&se->pre, size_words,
3173                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3174                                     size_bytes, dest_word_len));
3175
3176   /* Evaluate the bounds of the result.  If the loop range exists, we have
3177      to check if it is too large.  If so, we modify loop->to be consistent
3178      with min(size, size(source)).  Otherwise, size is made consistent with
3179      the loop range, so that the right number of bytes is transferred.*/
3180   n = se->loop->order[0];
3181   if (se->loop->to[n] != NULL_TREE)
3182     {
3183       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3184                          se->loop->to[n], se->loop->from[n]);
3185       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3186                          tmp, gfc_index_one_node);
3187       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3188                          tmp, size_words);
3189       gfc_add_modify_expr (&se->pre, size_words, tmp);
3190       gfc_add_modify_expr (&se->pre, size_bytes,
3191                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3192                                         size_words, dest_word_len));
3193       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3194                            size_words, se->loop->from[n]);
3195       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3196                            upper, gfc_index_one_node);
3197     }
3198   else
3199     {
3200       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3201                            size_words, gfc_index_one_node);
3202       se->loop->from[n] = gfc_index_zero_node;
3203     }
3204
3205   se->loop->to[n] = upper;
3206
3207   /* Build a destination descriptor, using the pointer, source, as the
3208      data field.  This is already allocated so set callee_alloc.
3209      FIXME callee_alloc is not set!  */
3210
3211   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3212                                info, mold_type, false, true, false);
3213
3214   /* Cast the pointer to the result.  */
3215   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3216   tmp = fold_convert (pvoid_type_node, tmp);
3217
3218   /* Use memcpy to do the transfer.  */
3219   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3220                          3,
3221                          tmp,
3222                          fold_convert (pvoid_type_node, source),
3223                          size_bytes);
3224   gfc_add_expr_to_block (&se->pre, tmp);
3225
3226   se->expr = info->descriptor;
3227   if (expr->ts.type == BT_CHARACTER)
3228     se->string_length = dest_word_len;
3229 }
3230
3231
3232 /* Scalar transfer statement.
3233    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3234
3235 static void
3236 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3237 {
3238   gfc_actual_arglist *arg;
3239   gfc_se argse;
3240   tree type;
3241   tree ptr;
3242   gfc_ss *ss;
3243   tree tmpdecl, tmp;
3244
3245   /* Get a pointer to the source.  */
3246   arg = expr->value.function.actual;
3247   ss = gfc_walk_expr (arg->expr);
3248   gfc_init_se (&argse, NULL);
3249   if (ss == gfc_ss_terminator)
3250     gfc_conv_expr_reference (&argse, arg->expr);
3251   else
3252     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3253   gfc_add_block_to_block (&se->pre, &argse.pre);
3254   gfc_add_block_to_block (&se->post, &argse.post);
3255   ptr = argse.expr;
3256
3257   arg = arg->next;
3258   type = gfc_typenode_for_spec (&expr->ts);
3259
3260   if (expr->ts.type == BT_CHARACTER)
3261     {
3262       ptr = convert (build_pointer_type (type), ptr);
3263       gfc_init_se (&argse, NULL);
3264       gfc_conv_expr (&argse, arg->expr);
3265       gfc_add_block_to_block (&se->pre, &argse.pre);
3266       gfc_add_block_to_block (&se->post, &argse.post);
3267       se->expr = ptr;
3268       se->string_length = argse.string_length;
3269     }
3270   else
3271     {
3272       tree moldsize;
3273       tmpdecl = gfc_create_var (type, "transfer");
3274       moldsize = size_in_bytes (type);
3275
3276       /* Use memcpy to do the transfer.  */
3277       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3278       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3279                              fold_convert (pvoid_type_node, tmp),
3280                              fold_convert (pvoid_type_node, ptr),
3281                              moldsize);
3282       gfc_add_expr_to_block (&se->pre, tmp);
3283
3284       se->expr = tmpdecl;
3285     }
3286 }
3287
3288
3289 /* Generate code for the ALLOCATED intrinsic.
3290    Generate inline code that directly check the address of the argument.  */
3291
3292 static void
3293 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3294 {
3295   gfc_actual_arglist *arg1;
3296   gfc_se arg1se;
3297   gfc_ss *ss1;
3298   tree tmp;
3299
3300   gfc_init_se (&arg1se, NULL);
3301   arg1 = expr->value.function.actual;
3302   ss1 = gfc_walk_expr (arg1->expr);
3303   arg1se.descriptor_only = 1;
3304   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3305
3306   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3307   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3308                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3309   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3310 }
3311
3312
3313 /* Generate code for the ASSOCIATED intrinsic.
3314    If both POINTER and TARGET are arrays, generate a call to library function
3315    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3316    In other cases, generate inline code that directly compare the address of
3317    POINTER with the address of TARGET.  */
3318
3319 static void
3320 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3321 {
3322   gfc_actual_arglist *arg1;
3323   gfc_actual_arglist *arg2;
3324   gfc_se arg1se;
3325   gfc_se arg2se;
3326   tree tmp2;
3327   tree tmp;
3328   tree fndecl;
3329   tree nonzero_charlen;
3330   tree nonzero_arraylen;
3331   gfc_ss *ss1, *ss2;
3332
3333   gfc_init_se (&arg1se, NULL);
3334   gfc_init_se (&arg2se, NULL);
3335   arg1 = expr->value.function.actual;
3336   arg2 = arg1->next;
3337   ss1 = gfc_walk_expr (arg1->expr);
3338
3339   if (!arg2->expr)
3340     {
3341       /* No optional target.  */
3342       if (ss1 == gfc_ss_terminator)
3343         {
3344           /* A pointer to a scalar.  */
3345           arg1se.want_pointer = 1;
3346           gfc_conv_expr (&arg1se, arg1->expr);
3347           tmp2 = arg1se.expr;
3348         }
3349       else
3350         {
3351           /* A pointer to an array.  */
3352           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3353           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3354         }
3355       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3356       gfc_add_block_to_block (&se->post, &arg1se.post);
3357       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3358                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3359       se->expr = tmp;
3360     }
3361   else
3362     {
3363       /* An optional target.  */
3364       ss2 = gfc_walk_expr (arg2->expr);
3365
3366       nonzero_charlen = NULL_TREE;
3367       if (arg1->expr->ts.type == BT_CHARACTER)
3368         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3369                                   arg1->expr->ts.cl->backend_decl,
3370                                   integer_zero_node);
3371
3372       if (ss1 == gfc_ss_terminator)
3373         {
3374           /* A pointer to a scalar.  */
3375           gcc_assert (ss2 == gfc_ss_terminator);
3376           arg1se.want_pointer = 1;
3377           gfc_conv_expr (&arg1se, arg1->expr);
3378           arg2se.want_pointer = 1;
3379           gfc_conv_expr (&arg2se, arg2->expr);
3380           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3381           gfc_add_block_to_block (&se->post, &arg1se.post);
3382           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3383           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3384                          null_pointer_node);
3385           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3386         }
3387       else
3388         {
3389
3390           /* An array pointer of zero length is not associated if target is
3391              present.  */
3392           arg1se.descriptor_only = 1;
3393           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3394           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3395                                             gfc_rank_cst[arg1->expr->rank - 1]);
3396           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3397                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3398
3399           /* A pointer to an array, call library function _gfor_associated.  */
3400           gcc_assert (ss2 != gfc_ss_terminator);
3401           arg1se.want_pointer = 1;
3402           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3403
3404           arg2se.want_pointer = 1;
3405           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3406           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3407           gfc_add_block_to_block (&se->post, &arg2se.post);
3408           fndecl = gfor_fndecl_associated;
3409           se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
3410           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3411                              se->expr, nonzero_arraylen);
3412
3413         }
3414
3415       /* If target is present zero character length pointers cannot
3416          be associated.  */
3417       if (nonzero_charlen != NULL_TREE)
3418         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3419                            se->expr, nonzero_charlen);
3420     }
3421
3422   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3423 }
3424
3425
3426 /* Scan a string for any one of the characters in a set of characters.  */
3427
3428 static void
3429 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3430 {
3431   tree logical4_type_node = gfc_get_logical_type (4);
3432   tree type;
3433   tree fndecl;
3434   tree *args;
3435   unsigned int num_args;
3436
3437   num_args = gfc_intrinsic_argument_list_length (expr);
3438   args = alloca (sizeof (tree) * 5);
3439
3440   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3441   type = gfc_typenode_for_spec (&expr->ts);
3442
3443   if (num_args == 4)
3444     args[4] = build_int_cst (logical4_type_node, 0);
3445   else
3446     {
3447       gcc_assert (num_args == 5);
3448       args[4] = convert (logical4_type_node, args[4]);
3449     }
3450
3451   fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
3452   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
3453                                fndecl, 5, args);
3454   se->expr = convert (type, se->expr);
3455 }
3456
3457
3458 /* Verify that a set of characters contains all the characters in a string
3459    by identifying the position of the first character in a string of
3460    characters that does not appear in a given set of characters.  */
3461
3462 static void
3463 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3464 {
3465   tree logical4_type_node = gfc_get_logical_type (4);
3466   tree type;
3467   tree fndecl;
3468   tree *args;
3469   unsigned int num_args;
3470
3471   num_args = gfc_intrinsic_argument_list_length (expr);
3472   args = alloca (sizeof (tree) * 5);
3473
3474   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3475   type = gfc_typenode_for_spec (&expr->ts);
3476
3477   if (num_args == 4)
3478     args[4] = build_int_cst (logical4_type_node, 0);
3479   else
3480     {
3481       gcc_assert (num_args == 5);
3482       args[4] = convert (logical4_type_node, args[4]);
3483     }
3484
3485   fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
3486   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
3487                                fndecl, 5, args);
3488
3489   se->expr = convert (type, se->expr);
3490 }
3491
3492
3493 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3494
3495 static void
3496 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3497 {
3498   tree arg;
3499
3500   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3501   arg = build_fold_addr_expr (arg);
3502   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3503 }
3504
3505 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3506
3507 static void
3508 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3509 {
3510   gfc_actual_arglist *actual;
3511   tree args;
3512   gfc_se argse;
3513
3514   args = NULL_TREE;
3515   for (actual = expr->value.function.actual; actual; actual = actual->next)
3516     {
3517       gfc_init_se (&argse, se);
3518
3519       /* Pass a NULL pointer for an absent arg.  */
3520       if (actual->expr == NULL)
3521         argse.expr = null_pointer_node;
3522       else
3523         gfc_conv_expr_reference (&argse, actual->expr);
3524
3525       gfc_add_block_to_block (&se->pre, &argse.pre);
3526       gfc_add_block_to_block (&se->post, &argse.post);
3527       args = gfc_chainon_list (args, argse.expr);
3528     }
3529   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3530 }
3531
3532
3533 /* Generate code for TRIM (A) intrinsic function.  */
3534
3535 static void
3536 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3537 {
3538   tree gfc_int4_type_node = gfc_get_int_type (4);
3539   tree var;
3540   tree len;
3541   tree addr;
3542   tree tmp;
3543   tree type;
3544   tree cond;
3545   tree fndecl;
3546   tree *args;
3547   unsigned int num_args;
3548
3549   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3550   args = alloca (sizeof (tree) * num_args);
3551
3552   type = build_pointer_type (gfc_character1_type_node);
3553   var = gfc_create_var (type, "pstr");
3554   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3555   len = gfc_create_var (gfc_int4_type_node, "len");
3556
3557   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3558   args[0] = build_fold_addr_expr (len);
3559   args[1] = addr;
3560
3561   fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3562   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3563                           fndecl, num_args, args);
3564   gfc_add_expr_to_block (&se->pre, tmp);
3565
3566   /* Free the temporary afterwards, if necessary.  */
3567   cond = build2 (GT_EXPR, boolean_type_node, len,
3568                  build_int_cst (TREE_TYPE (len), 0));
3569   tmp = gfc_call_free (var);
3570   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3571   gfc_add_expr_to_block (&se->post, tmp);
3572
3573   se->expr = var;
3574   se->string_length = len;
3575 }
3576
3577
3578 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3579
3580 static void
3581 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3582 {
3583   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3584   tree type, cond, tmp, count, exit_label, n, max, largest;
3585   stmtblock_t block, body;
3586   int i;
3587
3588   /* Get the arguments.  */
3589   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3590   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3591   src = args[1];
3592   ncopies = gfc_evaluate_now (args[2], &se->pre);
3593   ncopies_type = TREE_TYPE (ncopies);
3594
3595   /* Check that NCOPIES is not negative.  */
3596   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3597                       build_int_cst (ncopies_type, 0));
3598   gfc_trans_runtime_check (cond,
3599                            "Argument NCOPIES of REPEAT intrinsic is negative",
3600                            &se->pre, &expr->where);
3601
3602   /* If the source length is zero, any non negative value of NCOPIES
3603      is valid, and nothing happens.  */
3604   n = gfc_create_var (ncopies_type, "ncopies");
3605   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3606                       build_int_cst (size_type_node, 0));
3607   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3608                      build_int_cst (ncopies_type, 0), ncopies);
3609   gfc_add_modify_expr (&se->pre, n, tmp);
3610   ncopies = n;
3611
3612   /* Check that ncopies is not too large: ncopies should be less than
3613      (or equal to) MAX / slen, where MAX is the maximal integer of
3614      the gfc_charlen_type_node type.  If slen == 0, we need a special
3615      case to avoid the division by zero.  */
3616   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3617   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3618   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3619                      fold_convert (size_type_node, max), slen);
3620   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3621               ? size_type_node : ncopies_type;
3622   cond = fold_build2 (GT_EXPR, boolean_type_node,
3623                       fold_convert (largest, ncopies),
3624                       fold_convert (largest, max));
3625   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3626                      build_int_cst (size_type_node, 0));
3627   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3628                       cond);
3629   gfc_trans_runtime_check (cond,
3630                            "Argument NCOPIES of REPEAT intrinsic is too large",
3631                            &se->pre, &expr->where);
3632
3633   /* Compute the destination length.  */
3634   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3635                       fold_convert (gfc_charlen_type_node, slen),
3636                       fold_convert (gfc_charlen_type_node, ncopies));
3637   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3638   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3639
3640   /* Generate the code to do the repeat operation:
3641        for (i = 0; i < ncopies; i++)
3642          memmove (dest + (i * slen), src, slen);  */
3643   gfc_start_block (&block);
3644   count = gfc_create_var (ncopies_type, "count");
3645   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3646   exit_label = gfc_build_label_decl (NULL_TREE);
3647
3648   /* Start the loop body.  */
3649   gfc_start_block (&body);
3650
3651   /* Exit the loop if count >= ncopies.  */
3652   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3653   tmp = build1_v (GOTO_EXPR, exit_label);
3654   TREE_USED (exit_label) = 1;
3655   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3656                      build_empty_stmt ());
3657   gfc_add_expr_to_block (&body, tmp);
3658
3659   /* Call memmove (dest + (i*slen), src, slen).  */
3660   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3661                      fold_convert (gfc_charlen_type_node, slen),
3662                      fold_convert (gfc_charlen_type_node, count));
3663   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3664                      fold_convert (pchar_type_node, dest),
3665                      fold_convert (sizetype, tmp));
3666   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3667                          tmp, src, slen);
3668   gfc_add_expr_to_block (&body, tmp);
3669
3670   /* Increment count.  */
3671   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3672                 build_int_cst (TREE_TYPE (count), 1));
3673   gfc_add_modify_expr (&body, count, tmp);
3674
3675   /* Build the loop.  */
3676   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3677   gfc_add_expr_to_block (&block, tmp);
3678
3679   /* Add the exit label.  */
3680   tmp = build1_v (LABEL_EXPR, exit_label);
3681   gfc_add_expr_to_block (&block, tmp);
3682
3683   /* Finish the block.  */
3684   tmp = gfc_finish_block (&block);
3685   gfc_add_expr_to_block (&se->pre, tmp);
3686
3687   /* Set the result value.  */
3688   se->expr = dest;
3689   se->string_length = dlen;
3690 }
3691
3692
3693 /* Generate code for the IARGC intrinsic.  */
3694
3695 static void
3696 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3697 {
3698   tree tmp;
3699   tree fndecl;
3700   tree type;
3701
3702   /* Call the library function.  This always returns an INTEGER(4).  */
3703   fndecl = gfor_fndecl_iargc;
3704   tmp = build_call_expr (fndecl, 0);
3705
3706   /* Convert it to the required type.  */
3707   type = gfc_typenode_for_spec (&expr->ts);
3708   tmp = fold_convert (type, tmp);
3709
3710   se->expr = tmp;
3711 }
3712
3713
3714 /* The loc intrinsic returns the address of its argument as
3715    gfc_index_integer_kind integer.  */
3716
3717 static void
3718 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3719 {
3720   tree temp_var;
3721   gfc_expr *arg_expr;
3722   gfc_ss *ss;
3723
3724   gcc_assert (!se->ss);
3725
3726   arg_expr = expr->value.function.actual->expr;
3727   ss = gfc_walk_expr (arg_expr);
3728   if (ss == gfc_ss_terminator)
3729     gfc_conv_expr_reference (se, arg_expr);
3730   else
3731     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3732   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3733
3734   /* Create a temporary variable for loc return value.  Without this,
3735      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3736   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3737   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3738   se->expr = temp_var;
3739 }
3740
3741 /* Generate code for an intrinsic function.  Some map directly to library
3742    calls, others get special handling.  In some cases the name of the function
3743    used depends on the type specifiers.  */
3744
3745 void
3746 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3747 {
3748   gfc_intrinsic_sym *isym;
3749   const char *name;
3750   int lib;
3751
3752   isym = expr->value.function.isym;
3753
3754   name = &expr->value.function.name[2];
3755
3756   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3757     {
3758       lib = gfc_is_intrinsic_libcall (expr);
3759       if (lib != 0)
3760         {
3761           if (lib == 1)
3762             se->ignore_optional = 1;
3763           gfc_conv_intrinsic_funcall (se, expr);
3764           return;
3765         }
3766     }
3767
3768   switch (expr->value.function.isym->id)
3769     {
3770     case GFC_ISYM_NONE:
3771       gcc_unreachable ();
3772
3773     case GFC_ISYM_REPEAT:
3774       gfc_conv_intrinsic_repeat (se, expr);
3775       break;
3776
3777     case GFC_ISYM_TRIM:
3778       gfc_conv_intrinsic_trim (se, expr);
3779       break;
3780
3781     case GFC_ISYM_SI_KIND:
3782       gfc_conv_intrinsic_si_kind (se, expr);
3783       break;
3784
3785     case GFC_ISYM_SR_KIND:
3786       gfc_conv_intrinsic_sr_kind (se, expr);
3787       break;
3788
3789     case GFC_ISYM_EXPONENT:
3790       gfc_conv_intrinsic_exponent (se, expr);
3791       break;
3792
3793     case GFC_ISYM_SCAN:
3794       gfc_conv_intrinsic_scan (se, expr);
3795       break;
3796
3797     case GFC_ISYM_VERIFY:
3798       gfc_conv_intrinsic_verify (se, expr);
3799       break;
3800
3801     case GFC_ISYM_ALLOCATED:
3802       gfc_conv_allocated (se, expr);
3803       break;
3804
3805     case GFC_ISYM_ASSOCIATED:
3806       gfc_conv_associated(se, expr);
3807       break;
3808
3809     case GFC_ISYM_ABS:
3810       gfc_conv_intrinsic_abs (se, expr);
3811       break;
3812
3813     case GFC_ISYM_ADJUSTL:
3814       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3815       break;
3816
3817     case GFC_ISYM_ADJUSTR:
3818       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3819       break;
3820
3821     case GFC_ISYM_AIMAG:
3822       gfc_conv_intrinsic_imagpart (se, expr);
3823       break;
3824
3825     case GFC_ISYM_AINT:
3826       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3827       break;
3828
3829     case GFC_ISYM_ALL:
3830       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3831       break;
3832
3833     case GFC_ISYM_ANINT:
3834       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3835       break;
3836
3837     case GFC_ISYM_AND:
3838       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3839       break;
3840
3841     case GFC_ISYM_ANY:
3842       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3843       break;
3844
3845     case GFC_ISYM_BTEST:
3846       gfc_conv_intrinsic_btest (se, expr);
3847       break;
3848
3849     case GFC_ISYM_ACHAR:
3850     case GFC_ISYM_CHAR:
3851       gfc_conv_intrinsic_char (se, expr);
3852       break;
3853
3854     case GFC_ISYM_CONVERSION:
3855     case GFC_ISYM_REAL:
3856     case GFC_ISYM_LOGICAL:
3857     case GFC_ISYM_DBLE:
3858       gfc_conv_intrinsic_conversion (se, expr);
3859       break;
3860
3861       /* Integer conversions are handled separately to make sure we get the
3862          correct rounding mode.  */
3863     case GFC_ISYM_INT:
3864     case GFC_ISYM_INT2:
3865     case GFC_ISYM_INT8:
3866     case GFC_ISYM_LONG:
3867       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3868       break;
3869
3870     case GFC_ISYM_NINT:
3871       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3872       break;
3873
3874     case GFC_ISYM_CEILING:
3875       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3876       break;
3877
3878     case GFC_ISYM_FLOOR:
3879       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3880       break;
3881
3882     case GFC_ISYM_MOD:
3883       gfc_conv_intrinsic_mod (se, expr, 0);
3884       break;
3885
3886     case GFC_ISYM_MODULO:
3887       gfc_conv_intrinsic_mod (se, expr, 1);
3888       break;
3889
3890     case GFC_ISYM_CMPLX:
3891       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3892       break;
3893
3894     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3895       gfc_conv_intrinsic_iargc (se, expr);
3896       break;
3897
3898     case GFC_ISYM_COMPLEX:
3899       gfc_conv_intrinsic_cmplx (se, expr, 1);
3900       break;
3901
3902     case GFC_ISYM_CONJG:
3903       gfc_conv_intrinsic_conjg (se, expr);
3904       break;
3905
3906     case GFC_ISYM_COUNT:
3907       gfc_conv_intrinsic_count (se, expr);
3908       break;
3909
3910     case GFC_ISYM_CTIME:
3911       gfc_conv_intrinsic_ctime (se, expr);
3912       break;
3913
3914     case GFC_ISYM_DIM:
3915       gfc_conv_intrinsic_dim (se, expr);
3916       break;
3917
3918     case GFC_ISYM_DOT_PRODUCT:
3919       gfc_conv_intrinsic_dot_product (se, expr);
3920       break;
3921
3922     case GFC_ISYM_DPROD:
3923       gfc_conv_intrinsic_dprod (se, expr);
3924       break;
3925
3926     case GFC_ISYM_FDATE:
3927       gfc_conv_intrinsic_fdate (se, expr);
3928       break;
3929
3930     case GFC_ISYM_IAND:
3931       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3932       break;
3933
3934     case GFC_ISYM_IBCLR:
3935       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3936       break;
3937
3938     case GFC_ISYM_IBITS:
3939       gfc_conv_intrinsic_ibits (se, expr);
3940       break;
3941
3942     case GFC_ISYM_IBSET:
3943       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3944       break;
3945
3946     case GFC_ISYM_IACHAR:
3947     case GFC_ISYM_ICHAR:
3948       /* We assume ASCII character sequence.  */
3949       gfc_conv_intrinsic_ichar (se, expr);
3950       break;
3951
3952     case GFC_ISYM_IARGC:
3953       gfc_conv_intrinsic_iargc (se, expr);
3954       break;
3955
3956     case GFC_ISYM_IEOR:
3957       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3958       break;
3959
3960     case GFC_ISYM_INDEX:
3961       gfc_conv_intrinsic_index (se, expr);
3962       break;
3963
3964     case GFC_ISYM_IOR:
3965       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3966       break;
3967
3968     case GFC_ISYM_LSHIFT:
3969       gfc_conv_intrinsic_rlshift (se, expr, 0);
3970       break;
3971
3972     case GFC_ISYM_RSHIFT:
3973       gfc_conv_intrinsic_rlshift (se, expr, 1);
3974       break;
3975
3976     case GFC_ISYM_ISHFT:
3977       gfc_conv_intrinsic_ishft (se, expr);
3978       break;
3979
3980     case GFC_ISYM_ISHFTC:
3981       gfc_conv_intrinsic_ishftc (se, expr);
3982       break;
3983
3984     case GFC_ISYM_LBOUND:
3985       gfc_conv_intrinsic_bound (se, expr, 0);
3986       break;
3987
3988     case GFC_ISYM_TRANSPOSE:
3989       if (se->ss && se->ss->useflags)
3990         {
3991           gfc_conv_tmp_array_ref (se);
3992           gfc_advance_se_ss_chain (se);
3993         }
3994       else
3995         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3996       break;
3997
3998     case GFC_ISYM_LEN:
3999       gfc_conv_intrinsic_len (se, expr);
4000       break;
4001
4002     case GFC_ISYM_LEN_TRIM:
4003       gfc_conv_intrinsic_len_trim (se, expr);
4004       break;
4005
4006     case GFC_ISYM_LGE:
4007       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4008       break;
4009
4010     case GFC_ISYM_LGT:
4011       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4012       break;
4013
4014     case GFC_ISYM_LLE:
4015       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4016       break;
4017
4018     case GFC_ISYM_LLT:
4019       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4020       break;
4021
4022     case GFC_ISYM_MAX:
4023       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4024       break;
4025
4026     case GFC_ISYM_MAXLOC:
4027       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4028       break;
4029
4030     case GFC_ISYM_MAXVAL:
4031       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4032       break;
4033
4034     case GFC_ISYM_MERGE:
4035       gfc_conv_intrinsic_merge (se, expr);
4036       break;
4037
4038     case GFC_ISYM_MIN:
4039       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4040       break;
4041
4042     case GFC_ISYM_MINLOC:
4043       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4044       break;
4045
4046     case GFC_ISYM_MINVAL:
4047       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4048       break;
4049
4050     case GFC_ISYM_NOT:
4051       gfc_conv_intrinsic_not (se, expr);
4052       break;
4053
4054     case GFC_ISYM_OR:
4055       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4056       break;
4057
4058     case GFC_ISYM_PRESENT:
4059       gfc_conv_intrinsic_present (se, expr);
4060       break;
4061
4062     case GFC_ISYM_PRODUCT:
4063       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4064       break;
4065
4066     case GFC_ISYM_SIGN:
4067       gfc_conv_intrinsic_sign (se, expr);
4068       break;
4069
4070     case GFC_ISYM_SIZE:
4071       gfc_conv_intrinsic_size (se, expr);
4072       break;
4073
4074     case GFC_ISYM_SIZEOF:
4075       gfc_conv_intrinsic_sizeof (se, expr);
4076       break;
4077
4078     case GFC_ISYM_SUM:
4079       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4080       break;
4081
4082     case GFC_ISYM_TRANSFER:
4083       if (se->ss)
4084         {
4085           if (se->ss->useflags)
4086             {
4087               /* Access the previously obtained result.  */
4088               gfc_conv_tmp_array_ref (se);
4089               gfc_advance_se_ss_chain (se);
4090               break;
4091             }
4092           else
4093             gfc_conv_intrinsic_array_transfer (se, expr);
4094         }
4095       else
4096         gfc_conv_intrinsic_transfer (se, expr);
4097       break;
4098
4099     case GFC_ISYM_TTYNAM:
4100       gfc_conv_intrinsic_ttynam (se, expr);
4101       break;
4102
4103     case GFC_ISYM_UBOUND:
4104       gfc_conv_intrinsic_bound (se, expr, 1);
4105       break;
4106
4107     case GFC_ISYM_XOR:
4108       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4109       break;
4110
4111     case GFC_ISYM_LOC:
4112       gfc_conv_intrinsic_loc (se, expr);
4113       break;
4114
4115     case GFC_ISYM_ACCESS:
4116     case GFC_ISYM_CHDIR:
4117     case GFC_ISYM_CHMOD:
4118     case GFC_ISYM_ETIME:
4119     case GFC_ISYM_FGET:
4120     case GFC_ISYM_FGETC:
4121     case GFC_ISYM_FNUM:
4122     case GFC_ISYM_FPUT:
4123     case GFC_ISYM_FPUTC:
4124     case GFC_ISYM_FSTAT:
4125     case GFC_ISYM_FTELL:
4126     case GFC_ISYM_GETCWD:
4127     case GFC_ISYM_GETGID:
4128     case GFC_ISYM_GETPID:
4129     case GFC_ISYM_GETUID:
4130     case GFC_ISYM_HOSTNM:
4131     case GFC_ISYM_KILL:
4132     case GFC_ISYM_IERRNO:
4133     case GFC_ISYM_IRAND:
4134     case GFC_ISYM_ISATTY:
4135     case GFC_ISYM_LINK:
4136     case GFC_ISYM_LSTAT:
4137     case GFC_ISYM_MALLOC:
4138     case GFC_ISYM_MATMUL:
4139     case GFC_ISYM_MCLOCK:
4140     case GFC_ISYM_MCLOCK8:
4141     case GFC_ISYM_RAND:
4142     case GFC_ISYM_RENAME:
4143     case GFC_ISYM_SECOND:
4144     case GFC_ISYM_SECNDS:
4145     case GFC_ISYM_SIGNAL:
4146     case GFC_ISYM_STAT:
4147     case GFC_ISYM_SYMLNK:
4148     case GFC_ISYM_SYSTEM:
4149     case GFC_ISYM_TIME:
4150     case GFC_ISYM_TIME8:
4151     case GFC_ISYM_UMASK:
4152     case GFC_ISYM_UNLINK:
4153       gfc_conv_intrinsic_funcall (se, expr);
4154       break;
4155
4156     default:
4157       gfc_conv_intrinsic_lib_function (se, expr);
4158       break;
4159     }
4160 }
4161
4162
4163 /* This generates code to execute before entering the scalarization loop.
4164    Currently does nothing.  */
4165
4166 void
4167 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4168 {
4169   switch (ss->expr->value.function.isym->id)
4170     {
4171     case GFC_ISYM_UBOUND:
4172     case GFC_ISYM_LBOUND:
4173       break;
4174
4175     default:
4176       gcc_unreachable ();
4177     }
4178 }
4179
4180
4181 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4182    inside the scalarization loop.  */
4183
4184 static gfc_ss *
4185 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4186 {
4187   gfc_ss *newss;
4188
4189   /* The two argument version returns a scalar.  */
4190   if (expr->value.function.actual->next->expr)
4191     return ss;
4192
4193   newss = gfc_get_ss ();
4194   newss->type = GFC_SS_INTRINSIC;
4195   newss->expr = expr;
4196   newss->next = ss;
4197   newss->data.info.dimen = 1;
4198
4199   return newss;
4200 }
4201
4202
4203 /* Walk an intrinsic array libcall.  */
4204
4205 static gfc_ss *
4206 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4207 {
4208   gfc_ss *newss;
4209
4210   gcc_assert (expr->rank > 0);
4211
4212   newss = gfc_get_ss ();
4213   newss->type = GFC_SS_FUNCTION;
4214   newss->expr = expr;
4215   newss->next = ss;
4216   newss->data.info.dimen = expr->rank;
4217
4218   return newss;
4219 }
4220
4221
4222 /* Returns nonzero if the specified intrinsic function call maps directly to a
4223    an external library call.  Should only be used for functions that return
4224    arrays.  */
4225
4226 int
4227 gfc_is_intrinsic_libcall (gfc_expr * expr)
4228 {
4229   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4230   gcc_assert (expr->rank > 0);
4231
4232   switch (expr->value.function.isym->id)
4233     {
4234     case GFC_ISYM_ALL:
4235     case GFC_ISYM_ANY:
4236     case GFC_ISYM_COUNT:
4237     case GFC_ISYM_MATMUL:
4238     case GFC_ISYM_MAXLOC:
4239     case GFC_ISYM_MAXVAL:
4240     case GFC_ISYM_MINLOC:
4241     case GFC_ISYM_MINVAL:
4242     case GFC_ISYM_PRODUCT:
4243     case GFC_ISYM_SUM:
4244     case GFC_ISYM_SHAPE:
4245     case GFC_ISYM_SPREAD:
4246     case GFC_ISYM_TRANSPOSE:
4247       /* Ignore absent optional parameters.  */
4248       return 1;
4249
4250     case GFC_ISYM_RESHAPE:
4251     case GFC_ISYM_CSHIFT:
4252     case GFC_ISYM_EOSHIFT:
4253     case GFC_ISYM_PACK:
4254     case GFC_ISYM_UNPACK:
4255       /* Pass absent optional parameters.  */
4256       return 2;
4257
4258     default:
4259       return 0;
4260     }
4261 }
4262
4263 /* Walk an intrinsic function.  */
4264 gfc_ss *
4265 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4266                              gfc_intrinsic_sym * isym)
4267 {
4268   gcc_assert (isym);
4269
4270   if (isym->elemental)
4271     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4272
4273   if (expr->rank == 0)
4274     return ss;
4275
4276   if (gfc_is_intrinsic_libcall (expr))
4277     return gfc_walk_intrinsic_libfunc (ss, expr);
4278
4279   /* Special cases.  */
4280   switch (isym->id)
4281     {
4282     case GFC_ISYM_LBOUND:
4283     case GFC_ISYM_UBOUND:
4284       return gfc_walk_intrinsic_bound (ss, expr);
4285
4286     case GFC_ISYM_TRANSFER:
4287       return gfc_walk_intrinsic_libfunc (ss, expr);
4288
4289     default:
4290       /* This probably meant someone forgot to add an intrinsic to the above
4291          list(s) when they implemented it, or something's gone horribly wrong.
4292        */
4293       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4294                       expr->value.function.name);
4295     }
4296 }
4297
4298 #include "gt-fortran-trans-intrinsic.h"