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, &se->pre, &expr->where, gfc_msg_fault);
 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, &se->pre, &expr->where, msg);
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, &se->pre, &expr->where, msg);
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,
1549                              fold_convert (boolean_type_node, isnan));
1550         }
1551       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1552
1553       if (cond != NULL_TREE)
1554         tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1555
1556       gfc_add_expr_to_block (&se->pre, tmp);
1557       elsecase = build_empty_stmt ();
1558       limit = mvar;
1559       argexpr = argexpr->next;
1560     }
1561   se->expr = mvar;
1562 }
1563
1564
1565 /* Generate library calls for MIN and MAX intrinsics for character
1566    variables.  */
1567 static void
1568 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1569 {
1570   tree *args;
1571   tree var, len, fndecl, tmp, cond;
1572   unsigned int nargs;
1573
1574   nargs = gfc_intrinsic_argument_list_length (expr);
1575   args = alloca (sizeof (tree) * (nargs + 4));
1576   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1577
1578   /* Create the result variables.  */
1579   len = gfc_create_var (gfc_charlen_type_node, "len");
1580   args[0] = build_fold_addr_expr (len);
1581   var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
1582   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1583   args[2] = build_int_cst (NULL_TREE, op);
1584   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1585
1586   /* Make the function call.  */
1587   fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
1588   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
1589                           fndecl, nargs + 4, args);
1590   gfc_add_expr_to_block (&se->pre, tmp);
1591
1592   /* Free the temporary afterwards, if necessary.  */
1593   cond = build2 (GT_EXPR, boolean_type_node, len,
1594                  build_int_cst (TREE_TYPE (len), 0));
1595   tmp = gfc_call_free (var);
1596   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1597   gfc_add_expr_to_block (&se->post, tmp);
1598
1599   se->expr = var;
1600   se->string_length = len;
1601 }
1602
1603
1604 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1605    has the generic name.  */
1606
1607 static gfc_symbol *
1608 gfc_get_symbol_for_expr (gfc_expr * expr)
1609 {
1610   gfc_symbol *sym;
1611
1612   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1613   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1614   sym = gfc_new_symbol (expr->value.function.name, NULL);
1615
1616   sym->ts = expr->ts;
1617   sym->attr.external = 1;
1618   sym->attr.function = 1;
1619   sym->attr.always_explicit = 1;
1620   sym->attr.proc = PROC_INTRINSIC;
1621   sym->attr.flavor = FL_PROCEDURE;
1622   sym->result = sym;
1623   if (expr->rank > 0)
1624     {
1625       sym->attr.dimension = 1;
1626       sym->as = gfc_get_array_spec ();
1627       sym->as->type = AS_ASSUMED_SHAPE;
1628       sym->as->rank = expr->rank;
1629     }
1630
1631   /* TODO: proper argument lists for external intrinsics.  */
1632   return sym;
1633 }
1634
1635 /* Generate a call to an external intrinsic function.  */
1636 static void
1637 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1638 {
1639   gfc_symbol *sym;
1640   tree append_args;
1641
1642   gcc_assert (!se->ss || se->ss->expr == expr);
1643
1644   if (se->ss)
1645     gcc_assert (expr->rank > 0);
1646   else
1647     gcc_assert (expr->rank == 0);
1648
1649   sym = gfc_get_symbol_for_expr (expr);
1650
1651   /* Calls to libgfortran_matmul need to be appended special arguments,
1652      to be able to call the BLAS ?gemm functions if required and possible.  */
1653   append_args = NULL_TREE;
1654   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1655       && sym->ts.type != BT_LOGICAL)
1656     {
1657       tree cint = gfc_get_int_type (gfc_c_int_kind);
1658
1659       if (gfc_option.flag_external_blas
1660           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1661           && (sym->ts.kind == gfc_default_real_kind
1662               || sym->ts.kind == gfc_default_double_kind))
1663         {
1664           tree gemm_fndecl;
1665
1666           if (sym->ts.type == BT_REAL)
1667             {
1668               if (sym->ts.kind == gfc_default_real_kind)
1669                 gemm_fndecl = gfor_fndecl_sgemm;
1670               else
1671                 gemm_fndecl = gfor_fndecl_dgemm;
1672             }
1673           else
1674             {
1675               if (sym->ts.kind == gfc_default_real_kind)
1676                 gemm_fndecl = gfor_fndecl_cgemm;
1677               else
1678                 gemm_fndecl = gfor_fndecl_zgemm;
1679             }
1680
1681           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1682           append_args = gfc_chainon_list
1683                           (append_args, build_int_cst
1684                                           (cint, gfc_option.blas_matmul_limit));
1685           append_args = gfc_chainon_list (append_args,
1686                                           gfc_build_addr_expr (NULL_TREE,
1687                                                                gemm_fndecl));
1688         }
1689       else
1690         {
1691           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1692           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1693           append_args = gfc_chainon_list (append_args, null_pointer_node);
1694         }
1695     }
1696
1697   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1698   gfc_free (sym);
1699 }
1700
1701 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1702    Implemented as
1703     any(a)
1704     {
1705       forall (i=...)
1706         if (a[i] != 0)
1707           return 1
1708       end forall
1709       return 0
1710     }
1711     all(a)
1712     {
1713       forall (i=...)
1714         if (a[i] == 0)
1715           return 0
1716       end forall
1717       return 1
1718     }
1719  */
1720 static void
1721 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1722 {
1723   tree resvar;
1724   stmtblock_t block;
1725   stmtblock_t body;
1726   tree type;
1727   tree tmp;
1728   tree found;
1729   gfc_loopinfo loop;
1730   gfc_actual_arglist *actual;
1731   gfc_ss *arrayss;
1732   gfc_se arrayse;
1733   tree exit_label;
1734
1735   if (se->ss)
1736     {
1737       gfc_conv_intrinsic_funcall (se, expr);
1738       return;
1739     }
1740
1741   actual = expr->value.function.actual;
1742   type = gfc_typenode_for_spec (&expr->ts);
1743   /* Initialize the result.  */
1744   resvar = gfc_create_var (type, "test");
1745   if (op == EQ_EXPR)
1746     tmp = convert (type, boolean_true_node);
1747   else
1748     tmp = convert (type, boolean_false_node);
1749   gfc_add_modify_expr (&se->pre, resvar, tmp);
1750
1751   /* Walk the arguments.  */
1752   arrayss = gfc_walk_expr (actual->expr);
1753   gcc_assert (arrayss != gfc_ss_terminator);
1754
1755   /* Initialize the scalarizer.  */
1756   gfc_init_loopinfo (&loop);
1757   exit_label = gfc_build_label_decl (NULL_TREE);
1758   TREE_USED (exit_label) = 1;
1759   gfc_add_ss_to_loop (&loop, arrayss);
1760
1761   /* Initialize the loop.  */
1762   gfc_conv_ss_startstride (&loop);
1763   gfc_conv_loop_setup (&loop);
1764
1765   gfc_mark_ss_chain_used (arrayss, 1);
1766   /* Generate the loop body.  */
1767   gfc_start_scalarized_body (&loop, &body);
1768
1769   /* If the condition matches then set the return value.  */
1770   gfc_start_block (&block);
1771   if (op == EQ_EXPR)
1772     tmp = convert (type, boolean_false_node);
1773   else
1774     tmp = convert (type, boolean_true_node);
1775   gfc_add_modify_expr (&block, resvar, tmp);
1776
1777   /* And break out of the loop.  */
1778   tmp = build1_v (GOTO_EXPR, exit_label);
1779   gfc_add_expr_to_block (&block, tmp);
1780
1781   found = gfc_finish_block (&block);
1782
1783   /* Check this element.  */
1784   gfc_init_se (&arrayse, NULL);
1785   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1786   arrayse.ss = arrayss;
1787   gfc_conv_expr_val (&arrayse, actual->expr);
1788
1789   gfc_add_block_to_block (&body, &arrayse.pre);
1790   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1791                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1792   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1793   gfc_add_expr_to_block (&body, tmp);
1794   gfc_add_block_to_block (&body, &arrayse.post);
1795
1796   gfc_trans_scalarizing_loops (&loop, &body);
1797
1798   /* Add the exit label.  */
1799   tmp = build1_v (LABEL_EXPR, exit_label);
1800   gfc_add_expr_to_block (&loop.pre, tmp);
1801
1802   gfc_add_block_to_block (&se->pre, &loop.pre);
1803   gfc_add_block_to_block (&se->pre, &loop.post);
1804   gfc_cleanup_loop (&loop);
1805
1806   se->expr = resvar;
1807 }
1808
1809 /* COUNT(A) = Number of true elements in A.  */
1810 static void
1811 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1812 {
1813   tree resvar;
1814   tree type;
1815   stmtblock_t body;
1816   tree tmp;
1817   gfc_loopinfo loop;
1818   gfc_actual_arglist *actual;
1819   gfc_ss *arrayss;
1820   gfc_se arrayse;
1821
1822   if (se->ss)
1823     {
1824       gfc_conv_intrinsic_funcall (se, expr);
1825       return;
1826     }
1827
1828   actual = expr->value.function.actual;
1829
1830   type = gfc_typenode_for_spec (&expr->ts);
1831   /* Initialize the result.  */
1832   resvar = gfc_create_var (type, "count");
1833   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1834
1835   /* Walk the arguments.  */
1836   arrayss = gfc_walk_expr (actual->expr);
1837   gcc_assert (arrayss != gfc_ss_terminator);
1838
1839   /* Initialize the scalarizer.  */
1840   gfc_init_loopinfo (&loop);
1841   gfc_add_ss_to_loop (&loop, arrayss);
1842
1843   /* Initialize the loop.  */
1844   gfc_conv_ss_startstride (&loop);
1845   gfc_conv_loop_setup (&loop);
1846
1847   gfc_mark_ss_chain_used (arrayss, 1);
1848   /* Generate the loop body.  */
1849   gfc_start_scalarized_body (&loop, &body);
1850
1851   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1852                 build_int_cst (TREE_TYPE (resvar), 1));
1853   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1854
1855   gfc_init_se (&arrayse, NULL);
1856   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1857   arrayse.ss = arrayss;
1858   gfc_conv_expr_val (&arrayse, actual->expr);
1859   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1860
1861   gfc_add_block_to_block (&body, &arrayse.pre);
1862   gfc_add_expr_to_block (&body, tmp);
1863   gfc_add_block_to_block (&body, &arrayse.post);
1864
1865   gfc_trans_scalarizing_loops (&loop, &body);
1866
1867   gfc_add_block_to_block (&se->pre, &loop.pre);
1868   gfc_add_block_to_block (&se->pre, &loop.post);
1869   gfc_cleanup_loop (&loop);
1870
1871   se->expr = resvar;
1872 }
1873
1874 /* Inline implementation of the sum and product intrinsics.  */
1875 static void
1876 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1877 {
1878   tree resvar;
1879   tree type;
1880   stmtblock_t body;
1881   stmtblock_t block;
1882   tree tmp;
1883   gfc_loopinfo loop;
1884   gfc_actual_arglist *actual;
1885   gfc_ss *arrayss;
1886   gfc_ss *maskss;
1887   gfc_se arrayse;
1888   gfc_se maskse;
1889   gfc_expr *arrayexpr;
1890   gfc_expr *maskexpr;
1891
1892   if (se->ss)
1893     {
1894       gfc_conv_intrinsic_funcall (se, expr);
1895       return;
1896     }
1897
1898   type = gfc_typenode_for_spec (&expr->ts);
1899   /* Initialize the result.  */
1900   resvar = gfc_create_var (type, "val");
1901   if (op == PLUS_EXPR)
1902     tmp = gfc_build_const (type, integer_zero_node);
1903   else
1904     tmp = gfc_build_const (type, integer_one_node);
1905
1906   gfc_add_modify_expr (&se->pre, resvar, tmp);
1907
1908   /* Walk the arguments.  */
1909   actual = expr->value.function.actual;
1910   arrayexpr = actual->expr;
1911   arrayss = gfc_walk_expr (arrayexpr);
1912   gcc_assert (arrayss != gfc_ss_terminator);
1913
1914   actual = actual->next->next;
1915   gcc_assert (actual);
1916   maskexpr = actual->expr;
1917   if (maskexpr && maskexpr->rank != 0)
1918     {
1919       maskss = gfc_walk_expr (maskexpr);
1920       gcc_assert (maskss != gfc_ss_terminator);
1921     }
1922   else
1923     maskss = NULL;
1924
1925   /* Initialize the scalarizer.  */
1926   gfc_init_loopinfo (&loop);
1927   gfc_add_ss_to_loop (&loop, arrayss);
1928   if (maskss)
1929     gfc_add_ss_to_loop (&loop, maskss);
1930
1931   /* Initialize the loop.  */
1932   gfc_conv_ss_startstride (&loop);
1933   gfc_conv_loop_setup (&loop);
1934
1935   gfc_mark_ss_chain_used (arrayss, 1);
1936   if (maskss)
1937     gfc_mark_ss_chain_used (maskss, 1);
1938   /* Generate the loop body.  */
1939   gfc_start_scalarized_body (&loop, &body);
1940
1941   /* If we have a mask, only add this element if the mask is set.  */
1942   if (maskss)
1943     {
1944       gfc_init_se (&maskse, NULL);
1945       gfc_copy_loopinfo_to_se (&maskse, &loop);
1946       maskse.ss = maskss;
1947       gfc_conv_expr_val (&maskse, maskexpr);
1948       gfc_add_block_to_block (&body, &maskse.pre);
1949
1950       gfc_start_block (&block);
1951     }
1952   else
1953     gfc_init_block (&block);
1954
1955   /* Do the actual summation/product.  */
1956   gfc_init_se (&arrayse, NULL);
1957   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1958   arrayse.ss = arrayss;
1959   gfc_conv_expr_val (&arrayse, arrayexpr);
1960   gfc_add_block_to_block (&block, &arrayse.pre);
1961
1962   tmp = build2 (op, type, resvar, arrayse.expr);
1963   gfc_add_modify_expr (&block, resvar, tmp);
1964   gfc_add_block_to_block (&block, &arrayse.post);
1965
1966   if (maskss)
1967     {
1968       /* We enclose the above in if (mask) {...} .  */
1969       tmp = gfc_finish_block (&block);
1970
1971       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1972     }
1973   else
1974     tmp = gfc_finish_block (&block);
1975   gfc_add_expr_to_block (&body, tmp);
1976
1977   gfc_trans_scalarizing_loops (&loop, &body);
1978
1979   /* For a scalar mask, enclose the loop in an if statement.  */
1980   if (maskexpr && maskss == NULL)
1981     {
1982       gfc_init_se (&maskse, NULL);
1983       gfc_conv_expr_val (&maskse, maskexpr);
1984       gfc_init_block (&block);
1985       gfc_add_block_to_block (&block, &loop.pre);
1986       gfc_add_block_to_block (&block, &loop.post);
1987       tmp = gfc_finish_block (&block);
1988
1989       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1990       gfc_add_expr_to_block (&block, tmp);
1991       gfc_add_block_to_block (&se->pre, &block);
1992     }
1993   else
1994     {
1995       gfc_add_block_to_block (&se->pre, &loop.pre);
1996       gfc_add_block_to_block (&se->pre, &loop.post);
1997     }
1998
1999   gfc_cleanup_loop (&loop);
2000
2001   se->expr = resvar;
2002 }
2003
2004
2005 /* Inline implementation of the dot_product intrinsic. This function
2006    is based on gfc_conv_intrinsic_arith (the previous function).  */
2007 static void
2008 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2009 {
2010   tree resvar;
2011   tree type;
2012   stmtblock_t body;
2013   stmtblock_t block;
2014   tree tmp;
2015   gfc_loopinfo loop;
2016   gfc_actual_arglist *actual;
2017   gfc_ss *arrayss1, *arrayss2;
2018   gfc_se arrayse1, arrayse2;
2019   gfc_expr *arrayexpr1, *arrayexpr2;
2020
2021   type = gfc_typenode_for_spec (&expr->ts);
2022
2023   /* Initialize the result.  */
2024   resvar = gfc_create_var (type, "val");
2025   if (expr->ts.type == BT_LOGICAL)
2026     tmp = build_int_cst (type, 0);
2027   else
2028     tmp = gfc_build_const (type, integer_zero_node);
2029
2030   gfc_add_modify_expr (&se->pre, resvar, tmp);
2031
2032   /* Walk argument #1.  */
2033   actual = expr->value.function.actual;
2034   arrayexpr1 = actual->expr;
2035   arrayss1 = gfc_walk_expr (arrayexpr1);
2036   gcc_assert (arrayss1 != gfc_ss_terminator);
2037
2038   /* Walk argument #2.  */
2039   actual = actual->next;
2040   arrayexpr2 = actual->expr;
2041   arrayss2 = gfc_walk_expr (arrayexpr2);
2042   gcc_assert (arrayss2 != gfc_ss_terminator);
2043
2044   /* Initialize the scalarizer.  */
2045   gfc_init_loopinfo (&loop);
2046   gfc_add_ss_to_loop (&loop, arrayss1);
2047   gfc_add_ss_to_loop (&loop, arrayss2);
2048
2049   /* Initialize the loop.  */
2050   gfc_conv_ss_startstride (&loop);
2051   gfc_conv_loop_setup (&loop);
2052
2053   gfc_mark_ss_chain_used (arrayss1, 1);
2054   gfc_mark_ss_chain_used (arrayss2, 1);
2055
2056   /* Generate the loop body.  */
2057   gfc_start_scalarized_body (&loop, &body);
2058   gfc_init_block (&block);
2059
2060   /* Make the tree expression for [conjg(]array1[)].  */
2061   gfc_init_se (&arrayse1, NULL);
2062   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2063   arrayse1.ss = arrayss1;
2064   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2065   if (expr->ts.type == BT_COMPLEX)
2066     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
2067   gfc_add_block_to_block (&block, &arrayse1.pre);
2068
2069   /* Make the tree expression for array2.  */
2070   gfc_init_se (&arrayse2, NULL);
2071   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2072   arrayse2.ss = arrayss2;
2073   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2074   gfc_add_block_to_block (&block, &arrayse2.pre);
2075
2076   /* Do the actual product and sum.  */
2077   if (expr->ts.type == BT_LOGICAL)
2078     {
2079       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2080       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2081     }
2082   else
2083     {
2084       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2085       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
2086     }
2087   gfc_add_modify_expr (&block, resvar, tmp);
2088
2089   /* Finish up the loop block and the loop.  */
2090   tmp = gfc_finish_block (&block);
2091   gfc_add_expr_to_block (&body, tmp);
2092
2093   gfc_trans_scalarizing_loops (&loop, &body);
2094   gfc_add_block_to_block (&se->pre, &loop.pre);
2095   gfc_add_block_to_block (&se->pre, &loop.post);
2096   gfc_cleanup_loop (&loop);
2097
2098   se->expr = resvar;
2099 }
2100
2101
2102 static void
2103 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2104 {
2105   stmtblock_t body;
2106   stmtblock_t block;
2107   stmtblock_t ifblock;
2108   stmtblock_t elseblock;
2109   tree limit;
2110   tree type;
2111   tree tmp;
2112   tree elsetmp;
2113   tree ifbody;
2114   tree offset;
2115   gfc_loopinfo loop;
2116   gfc_actual_arglist *actual;
2117   gfc_ss *arrayss;
2118   gfc_ss *maskss;
2119   gfc_se arrayse;
2120   gfc_se maskse;
2121   gfc_expr *arrayexpr;
2122   gfc_expr *maskexpr;
2123   tree pos;
2124   int n;
2125
2126   if (se->ss)
2127     {
2128       gfc_conv_intrinsic_funcall (se, expr);
2129       return;
2130     }
2131
2132   /* Initialize the result.  */
2133   pos = gfc_create_var (gfc_array_index_type, "pos");
2134   offset = gfc_create_var (gfc_array_index_type, "offset");
2135   type = gfc_typenode_for_spec (&expr->ts);
2136
2137   /* Walk the arguments.  */
2138   actual = expr->value.function.actual;
2139   arrayexpr = actual->expr;
2140   arrayss = gfc_walk_expr (arrayexpr);
2141   gcc_assert (arrayss != gfc_ss_terminator);
2142
2143   actual = actual->next->next;
2144   gcc_assert (actual);
2145   maskexpr = actual->expr;
2146   if (maskexpr && maskexpr->rank != 0)
2147     {
2148       maskss = gfc_walk_expr (maskexpr);
2149       gcc_assert (maskss != gfc_ss_terminator);
2150     }
2151   else
2152     maskss = NULL;
2153
2154   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2155   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2156   switch (arrayexpr->ts.type)
2157     {
2158     case BT_REAL:
2159       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2160       break;
2161
2162     case BT_INTEGER:
2163       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2164                                   arrayexpr->ts.kind);
2165       break;
2166
2167     default:
2168       gcc_unreachable ();
2169     }
2170
2171   /* We start with the most negative possible value for MAXLOC, and the most
2172      positive possible value for MINLOC. The most negative possible value is
2173      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2174      possible value is HUGE in both cases.  */
2175   if (op == GT_EXPR)
2176     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2177   gfc_add_modify_expr (&se->pre, limit, tmp);
2178
2179   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2180     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2181                   build_int_cst (type, 1));
2182
2183   /* Initialize the scalarizer.  */
2184   gfc_init_loopinfo (&loop);
2185   gfc_add_ss_to_loop (&loop, arrayss);
2186   if (maskss)
2187     gfc_add_ss_to_loop (&loop, maskss);
2188
2189   /* Initialize the loop.  */
2190   gfc_conv_ss_startstride (&loop);
2191   gfc_conv_loop_setup (&loop);
2192
2193   gcc_assert (loop.dimen == 1);
2194
2195   /* Initialize the position to zero, following Fortran 2003.  We are free
2196      to do this because Fortran 95 allows the result of an entirely false
2197      mask to be processor dependent.  */
2198   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2199
2200   gfc_mark_ss_chain_used (arrayss, 1);
2201   if (maskss)
2202     gfc_mark_ss_chain_used (maskss, 1);
2203   /* Generate the loop body.  */
2204   gfc_start_scalarized_body (&loop, &body);
2205
2206   /* If we have a mask, only check this element if the mask is set.  */
2207   if (maskss)
2208     {
2209       gfc_init_se (&maskse, NULL);
2210       gfc_copy_loopinfo_to_se (&maskse, &loop);
2211       maskse.ss = maskss;
2212       gfc_conv_expr_val (&maskse, maskexpr);
2213       gfc_add_block_to_block (&body, &maskse.pre);
2214
2215       gfc_start_block (&block);
2216     }
2217   else
2218     gfc_init_block (&block);
2219
2220   /* Compare with the current limit.  */
2221   gfc_init_se (&arrayse, NULL);
2222   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2223   arrayse.ss = arrayss;
2224   gfc_conv_expr_val (&arrayse, arrayexpr);
2225   gfc_add_block_to_block (&block, &arrayse.pre);
2226
2227   /* We do the following if this is a more extreme value.  */
2228   gfc_start_block (&ifblock);
2229
2230   /* Assign the value to the limit...  */
2231   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2232
2233   /* Remember where we are.  An offset must be added to the loop
2234      counter to obtain the required position.  */
2235   if (loop.temp_dim)
2236     tmp = build_int_cst (gfc_array_index_type, 1);
2237   else
2238     tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2239                          gfc_index_one_node, loop.from[0]);
2240   gfc_add_modify_expr (&block, offset, tmp);
2241
2242   tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2243                 loop.loopvar[0], offset);
2244   gfc_add_modify_expr (&ifblock, pos, tmp);
2245
2246   ifbody = gfc_finish_block (&ifblock);
2247
2248   /* If it is a more extreme value or pos is still zero and the value
2249      equal to the limit.  */
2250   tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2251                 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2252                 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2253   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2254                 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2255   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2256   gfc_add_expr_to_block (&block, tmp);
2257
2258   if (maskss)
2259     {
2260       /* We enclose the above in if (mask) {...}.  */
2261       tmp = gfc_finish_block (&block);
2262
2263       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2264     }
2265   else
2266     tmp = gfc_finish_block (&block);
2267   gfc_add_expr_to_block (&body, tmp);
2268
2269   gfc_trans_scalarizing_loops (&loop, &body);
2270
2271   /* For a scalar mask, enclose the loop in an if statement.  */
2272   if (maskexpr && maskss == NULL)
2273     {
2274       gfc_init_se (&maskse, NULL);
2275       gfc_conv_expr_val (&maskse, maskexpr);
2276       gfc_init_block (&block);
2277       gfc_add_block_to_block (&block, &loop.pre);
2278       gfc_add_block_to_block (&block, &loop.post);
2279       tmp = gfc_finish_block (&block);
2280
2281       /* For the else part of the scalar mask, just initialize
2282          the pos variable the same way as above.  */
2283
2284       gfc_init_block (&elseblock);
2285       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2286       elsetmp = gfc_finish_block (&elseblock);
2287
2288       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2289       gfc_add_expr_to_block (&block, tmp);
2290       gfc_add_block_to_block (&se->pre, &block);
2291     }
2292   else
2293     {
2294       gfc_add_block_to_block (&se->pre, &loop.pre);
2295       gfc_add_block_to_block (&se->pre, &loop.post);
2296     }
2297   gfc_cleanup_loop (&loop);
2298
2299   se->expr = convert (type, pos);
2300 }
2301
2302 static void
2303 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2304 {
2305   tree limit;
2306   tree type;
2307   tree tmp;
2308   tree ifbody;
2309   stmtblock_t body;
2310   stmtblock_t block;
2311   gfc_loopinfo loop;
2312   gfc_actual_arglist *actual;
2313   gfc_ss *arrayss;
2314   gfc_ss *maskss;
2315   gfc_se arrayse;
2316   gfc_se maskse;
2317   gfc_expr *arrayexpr;
2318   gfc_expr *maskexpr;
2319   int n;
2320
2321   if (se->ss)
2322     {
2323       gfc_conv_intrinsic_funcall (se, expr);
2324       return;
2325     }
2326
2327   type = gfc_typenode_for_spec (&expr->ts);
2328   /* Initialize the result.  */
2329   limit = gfc_create_var (type, "limit");
2330   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2331   switch (expr->ts.type)
2332     {
2333     case BT_REAL:
2334       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2335       break;
2336
2337     case BT_INTEGER:
2338       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2339       break;
2340
2341     default:
2342       gcc_unreachable ();
2343     }
2344
2345   /* We start with the most negative possible value for MAXVAL, and the most
2346      positive possible value for MINVAL. The most negative possible value is
2347      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2348      possible value is HUGE in both cases.  */
2349   if (op == GT_EXPR)
2350     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2351
2352   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2353     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2354                   build_int_cst (type, 1));
2355
2356   gfc_add_modify_expr (&se->pre, limit, tmp);
2357
2358   /* Walk the arguments.  */
2359   actual = expr->value.function.actual;
2360   arrayexpr = actual->expr;
2361   arrayss = gfc_walk_expr (arrayexpr);
2362   gcc_assert (arrayss != gfc_ss_terminator);
2363
2364   actual = actual->next->next;
2365   gcc_assert (actual);
2366   maskexpr = actual->expr;
2367   if (maskexpr && maskexpr->rank != 0)
2368     {
2369       maskss = gfc_walk_expr (maskexpr);
2370       gcc_assert (maskss != gfc_ss_terminator);
2371     }
2372   else
2373     maskss = NULL;
2374
2375   /* Initialize the scalarizer.  */
2376   gfc_init_loopinfo (&loop);
2377   gfc_add_ss_to_loop (&loop, arrayss);
2378   if (maskss)
2379     gfc_add_ss_to_loop (&loop, maskss);
2380
2381   /* Initialize the loop.  */
2382   gfc_conv_ss_startstride (&loop);
2383   gfc_conv_loop_setup (&loop);
2384
2385   gfc_mark_ss_chain_used (arrayss, 1);
2386   if (maskss)
2387     gfc_mark_ss_chain_used (maskss, 1);
2388   /* Generate the loop body.  */
2389   gfc_start_scalarized_body (&loop, &body);
2390
2391   /* If we have a mask, only add this element if the mask is set.  */
2392   if (maskss)
2393     {
2394       gfc_init_se (&maskse, NULL);
2395       gfc_copy_loopinfo_to_se (&maskse, &loop);
2396       maskse.ss = maskss;
2397       gfc_conv_expr_val (&maskse, maskexpr);
2398       gfc_add_block_to_block (&body, &maskse.pre);
2399
2400       gfc_start_block (&block);
2401     }
2402   else
2403     gfc_init_block (&block);
2404
2405   /* Compare with the current limit.  */
2406   gfc_init_se (&arrayse, NULL);
2407   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2408   arrayse.ss = arrayss;
2409   gfc_conv_expr_val (&arrayse, arrayexpr);
2410   gfc_add_block_to_block (&block, &arrayse.pre);
2411
2412   /* Assign the value to the limit...  */
2413   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2414
2415   /* If it is a more extreme value.  */
2416   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2417   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2418   gfc_add_expr_to_block (&block, tmp);
2419   gfc_add_block_to_block (&block, &arrayse.post);
2420
2421   tmp = gfc_finish_block (&block);
2422   if (maskss)
2423     /* We enclose the above in if (mask) {...}.  */
2424     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2425   gfc_add_expr_to_block (&body, tmp);
2426
2427   gfc_trans_scalarizing_loops (&loop, &body);
2428
2429   /* For a scalar mask, enclose the loop in an if statement.  */
2430   if (maskexpr && maskss == NULL)
2431     {
2432       gfc_init_se (&maskse, NULL);
2433       gfc_conv_expr_val (&maskse, maskexpr);
2434       gfc_init_block (&block);
2435       gfc_add_block_to_block (&block, &loop.pre);
2436       gfc_add_block_to_block (&block, &loop.post);
2437       tmp = gfc_finish_block (&block);
2438
2439       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2440       gfc_add_expr_to_block (&block, tmp);
2441       gfc_add_block_to_block (&se->pre, &block);
2442     }
2443   else
2444     {
2445       gfc_add_block_to_block (&se->pre, &loop.pre);
2446       gfc_add_block_to_block (&se->pre, &loop.post);
2447     }
2448
2449   gfc_cleanup_loop (&loop);
2450
2451   se->expr = limit;
2452 }
2453
2454 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2455 static void
2456 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2457 {
2458   tree args[2];
2459   tree type;
2460   tree tmp;
2461
2462   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2463   type = TREE_TYPE (args[0]);
2464
2465   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2466   tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
2467   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2468                      build_int_cst (type, 0));
2469   type = gfc_typenode_for_spec (&expr->ts);
2470   se->expr = convert (type, tmp);
2471 }
2472
2473 /* Generate code to perform the specified operation.  */
2474 static void
2475 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2476 {
2477   tree args[2];
2478
2479   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2480   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2481 }
2482
2483 /* Bitwise not.  */
2484 static void
2485 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2486 {
2487   tree arg;
2488
2489   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2490   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2491 }
2492
2493 /* Set or clear a single bit.  */
2494 static void
2495 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2496 {
2497   tree args[2];
2498   tree type;
2499   tree tmp;
2500   int op;
2501
2502   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2503   type = TREE_TYPE (args[0]);
2504
2505   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2506   if (set)
2507     op = BIT_IOR_EXPR;
2508   else
2509     {
2510       op = BIT_AND_EXPR;
2511       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2512     }
2513   se->expr = fold_build2 (op, type, args[0], tmp);
2514 }
2515
2516 /* Extract a sequence of bits.
2517     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2518 static void
2519 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2520 {
2521   tree args[3];
2522   tree type;
2523   tree tmp;
2524   tree mask;
2525
2526   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2527   type = TREE_TYPE (args[0]);
2528
2529   mask = build_int_cst (type, -1);
2530   mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
2531   mask = build1 (BIT_NOT_EXPR, type, mask);
2532
2533   tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
2534
2535   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2536 }
2537
2538 /* RSHIFT (I, SHIFT) = I >> SHIFT
2539    LSHIFT (I, SHIFT) = I << SHIFT  */
2540 static void
2541 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2542 {
2543   tree args[2];
2544
2545   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2546
2547   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2548                           TREE_TYPE (args[0]), args[0], args[1]);
2549 }
2550
2551 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2552                         ? 0
2553                         : ((shift >= 0) ? i << shift : i >> -shift)
2554    where all shifts are logical shifts.  */
2555 static void
2556 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2557 {
2558   tree args[2];
2559   tree type;
2560   tree utype;
2561   tree tmp;
2562   tree width;
2563   tree num_bits;
2564   tree cond;
2565   tree lshift;
2566   tree rshift;
2567
2568   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2569   type = TREE_TYPE (args[0]);
2570   utype = unsigned_type_for (type);
2571
2572   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2573
2574   /* Left shift if positive.  */
2575   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2576
2577   /* Right shift if negative.
2578      We convert to an unsigned type because we want a logical shift.
2579      The standard doesn't define the case of shifting negative
2580      numbers, and we try to be compatible with other compilers, most
2581      notably g77, here.  */
2582   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2583                                        convert (utype, args[0]), width));
2584
2585   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2586                      build_int_cst (TREE_TYPE (args[1]), 0));
2587   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2588
2589   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2590      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2591      special case.  */
2592   num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
2593   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2594
2595   se->expr = fold_build3 (COND_EXPR, type, cond,
2596                           build_int_cst (type, 0), tmp);
2597 }
2598
2599
2600 /* Circular shift.  AKA rotate or barrel shift.  */
2601
2602 static void
2603 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2604 {
2605   tree *args;
2606   tree type;
2607   tree tmp;
2608   tree lrot;
2609   tree rrot;
2610   tree zero;
2611   unsigned int num_args;
2612
2613   num_args = gfc_intrinsic_argument_list_length (expr);
2614   args = alloca (sizeof (tree) * num_args);
2615
2616   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2617
2618   if (num_args == 3)
2619     {
2620       /* Use a library function for the 3 parameter version.  */
2621       tree int4type = gfc_get_int_type (4);
2622
2623       type = TREE_TYPE (args[0]);
2624       /* We convert the first argument to at least 4 bytes, and
2625          convert back afterwards.  This removes the need for library
2626          functions for all argument sizes, and function will be
2627          aligned to at least 32 bits, so there's no loss.  */
2628       if (expr->ts.kind < 4)
2629         args[0] = convert (int4type, args[0]);
2630
2631       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2632          need loads of library  functions.  They cannot have values >
2633          BIT_SIZE (I) so the conversion is safe.  */
2634       args[1] = convert (int4type, args[1]);
2635       args[2] = convert (int4type, args[2]);
2636
2637       switch (expr->ts.kind)
2638         {
2639         case 1:
2640         case 2:
2641         case 4:
2642           tmp = gfor_fndecl_math_ishftc4;
2643           break;
2644         case 8:
2645           tmp = gfor_fndecl_math_ishftc8;
2646           break;
2647         case 16:
2648           tmp = gfor_fndecl_math_ishftc16;
2649           break;
2650         default:
2651           gcc_unreachable ();
2652         }
2653       se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2654       /* Convert the result back to the original type, if we extended
2655          the first argument's width above.  */
2656       if (expr->ts.kind < 4)
2657         se->expr = convert (type, se->expr);
2658
2659       return;
2660     }
2661   type = TREE_TYPE (args[0]);
2662
2663   /* Rotate left if positive.  */
2664   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2665
2666   /* Rotate right if negative.  */
2667   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2668   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2669
2670   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2671   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2672   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2673
2674   /* Do nothing if shift == 0.  */
2675   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2676   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2677 }
2678
2679 /* The length of a character string.  */
2680 static void
2681 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2682 {
2683   tree len;
2684   tree type;
2685   tree decl;
2686   gfc_symbol *sym;
2687   gfc_se argse;
2688   gfc_expr *arg;
2689   gfc_ss *ss;
2690
2691   gcc_assert (!se->ss);
2692
2693   arg = expr->value.function.actual->expr;
2694
2695   type = gfc_typenode_for_spec (&expr->ts);
2696   switch (arg->expr_type)
2697     {
2698     case EXPR_CONSTANT:
2699       len = build_int_cst (NULL_TREE, arg->value.character.length);
2700       break;
2701
2702     case EXPR_ARRAY:
2703       /* Obtain the string length from the function used by
2704          trans-array.c(gfc_trans_array_constructor).  */
2705       len = NULL_TREE;
2706       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2707       break;
2708
2709     case EXPR_VARIABLE:
2710       if (arg->ref == NULL
2711             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2712         {
2713           /* This doesn't catch all cases.
2714              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2715              and the surrounding thread.  */
2716           sym = arg->symtree->n.sym;
2717           decl = gfc_get_symbol_decl (sym);
2718           if (decl == current_function_decl && sym->attr.function
2719                 && (sym->result == sym))
2720             decl = gfc_get_fake_result_decl (sym, 0);
2721
2722           len = sym->ts.cl->backend_decl;
2723           gcc_assert (len);
2724           break;
2725         }
2726
2727       /* Otherwise fall through.  */
2728
2729     default:
2730       /* Anybody stupid enough to do this deserves inefficient code.  */
2731       ss = gfc_walk_expr (arg);
2732       gfc_init_se (&argse, se);
2733       if (ss == gfc_ss_terminator)
2734         gfc_conv_expr (&argse, arg);
2735       else
2736         gfc_conv_expr_descriptor (&argse, arg, ss);
2737       gfc_add_block_to_block (&se->pre, &argse.pre);
2738       gfc_add_block_to_block (&se->post, &argse.post);
2739       len = argse.string_length;
2740       break;
2741     }
2742   se->expr = convert (type, len);
2743 }
2744
2745 /* The length of a character string not including trailing blanks.  */
2746 static void
2747 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2748 {
2749   tree args[2];
2750   tree type;
2751
2752   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2753   type = gfc_typenode_for_spec (&expr->ts);
2754   se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2755   se->expr = convert (type, se->expr);
2756 }
2757
2758
2759 /* Returns the starting position of a substring within a string.  */
2760
2761 static void
2762 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2763                                       tree function)
2764 {
2765   tree logical4_type_node = gfc_get_logical_type (4);
2766   tree type;
2767   tree fndecl;
2768   tree *args;
2769   unsigned int num_args;
2770
2771   num_args = gfc_intrinsic_argument_list_length (expr);
2772   args = alloca (sizeof (tree) * 5);
2773
2774   gfc_conv_intrinsic_function_args (se, expr, args,
2775                                     num_args >= 5 ? 5 : num_args);
2776   type = gfc_typenode_for_spec (&expr->ts);
2777
2778   if (num_args == 4)
2779     args[4] = build_int_cst (logical4_type_node, 0);
2780   else
2781     args[4] = convert (logical4_type_node, args[4]);
2782
2783   fndecl = build_addr (function, current_function_decl);
2784   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
2785                                5, args);
2786   se->expr = convert (type, se->expr);
2787
2788 }
2789
2790 /* The ascii value for a single character.  */
2791 static void
2792 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2793 {
2794   tree args[2];
2795   tree type;
2796
2797   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2798   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2799   args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
2800   type = gfc_typenode_for_spec (&expr->ts);
2801
2802   se->expr = build_fold_indirect_ref (args[1]);
2803   se->expr = convert (type, se->expr);
2804 }
2805
2806
2807 /* Intrinsic ISNAN calls __builtin_isnan.  */
2808
2809 static void
2810 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
2811 {
2812   tree arg;
2813
2814   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2815   se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
2816   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2817 }
2818
2819 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2820
2821 static void
2822 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2823 {
2824   tree tsource;
2825   tree fsource;
2826   tree mask;
2827   tree type;
2828   tree len;
2829   tree *args;
2830   unsigned int num_args;
2831
2832   num_args = gfc_intrinsic_argument_list_length (expr);
2833   args = alloca (sizeof (tree) * num_args);
2834
2835   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2836   if (expr->ts.type != BT_CHARACTER)
2837     {
2838       tsource = args[0];
2839       fsource = args[1];
2840       mask = args[2];
2841     }
2842   else
2843     {
2844       /* We do the same as in the non-character case, but the argument
2845          list is different because of the string length arguments. We
2846          also have to set the string length for the result.  */
2847       len = args[0];
2848       tsource = args[1];
2849       fsource = args[3];
2850       mask = args[4];
2851
2852       se->string_length = len;
2853     }
2854   type = TREE_TYPE (tsource);
2855   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2856 }
2857
2858
2859 static void
2860 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2861 {
2862   gfc_actual_arglist *actual;
2863   tree arg1;
2864   tree type;
2865   tree fncall0;
2866   tree fncall1;
2867   gfc_se argse;
2868   gfc_ss *ss;
2869
2870   gfc_init_se (&argse, NULL);
2871   actual = expr->value.function.actual;
2872
2873   ss = gfc_walk_expr (actual->expr);
2874   gcc_assert (ss != gfc_ss_terminator);
2875   argse.want_pointer = 1;
2876   argse.data_not_needed = 1;
2877   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2878   gfc_add_block_to_block (&se->pre, &argse.pre);
2879   gfc_add_block_to_block (&se->post, &argse.post);
2880   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2881
2882   /* Build the call to size0.  */
2883   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2884
2885   actual = actual->next;
2886
2887   if (actual->expr)
2888     {
2889       gfc_init_se (&argse, NULL);
2890       gfc_conv_expr_type (&argse, actual->expr,
2891                           gfc_array_index_type);
2892       gfc_add_block_to_block (&se->pre, &argse.pre);
2893
2894       /* Build the call to size1.  */
2895       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2896                                  arg1, argse.expr);
2897
2898       /* Unusually, for an intrinsic, size does not exclude
2899          an optional arg2, so we must test for it.  */
2900       if (actual->expr->expr_type == EXPR_VARIABLE
2901             && actual->expr->symtree->n.sym->attr.dummy
2902             && actual->expr->symtree->n.sym->attr.optional)
2903         {
2904           tree tmp;
2905           gfc_init_se (&argse, NULL);
2906           argse.want_pointer = 1;
2907           argse.data_not_needed = 1;
2908           gfc_conv_expr (&argse, actual->expr);
2909           gfc_add_block_to_block (&se->pre, &argse.pre);
2910           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2911                         null_pointer_node);
2912           tmp = gfc_evaluate_now (tmp, &se->pre);
2913           se->expr = build3 (COND_EXPR, pvoid_type_node,
2914                              tmp, fncall1, fncall0);
2915         }
2916       else
2917         se->expr = fncall1;
2918     }
2919   else
2920     se->expr = fncall0;
2921
2922   type = gfc_typenode_for_spec (&expr->ts);
2923   se->expr = convert (type, se->expr);
2924 }
2925
2926
2927 static void
2928 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2929 {
2930   gfc_expr *arg;
2931   gfc_ss *ss;
2932   gfc_se argse;
2933   tree source;
2934   tree source_bytes;
2935   tree type;
2936   tree tmp;
2937   tree lower;
2938   tree upper;
2939   /*tree stride;*/
2940   int n;
2941
2942   arg = expr->value.function.actual->expr;
2943
2944   gfc_init_se (&argse, NULL);
2945   ss = gfc_walk_expr (arg);
2946
2947   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2948
2949   if (ss == gfc_ss_terminator)
2950     {
2951       gfc_conv_expr_reference (&argse, arg);
2952       source = argse.expr;
2953
2954       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2955
2956       /* Obtain the source word length.  */
2957       if (arg->ts.type == BT_CHARACTER)
2958         source_bytes = fold_convert (gfc_array_index_type,
2959                                      argse.string_length);
2960       else
2961         source_bytes = fold_convert (gfc_array_index_type,
2962                                      size_in_bytes (type));
2963     }
2964   else
2965     {
2966       argse.want_pointer = 0;
2967       gfc_conv_expr_descriptor (&argse, arg, ss);
2968       source = gfc_conv_descriptor_data_get (argse.expr);
2969       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2970
2971       /* Obtain the argument's word length.  */
2972       if (arg->ts.type == BT_CHARACTER)
2973         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2974       else
2975         tmp = fold_convert (gfc_array_index_type,
2976                             size_in_bytes (type));
2977       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2978
2979       /* Obtain the size of the array in bytes.  */
2980       for (n = 0; n < arg->rank; n++)
2981         {
2982           tree idx;
2983           idx = gfc_rank_cst[n];
2984           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2985           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2986           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2987                              upper, lower);
2988           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2989                              tmp, gfc_index_one_node);
2990           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2991                              tmp, source_bytes);
2992           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2993         }
2994     }
2995
2996   gfc_add_block_to_block (&se->pre, &argse.pre);
2997   se->expr = source_bytes;
2998 }
2999
3000
3001 /* Intrinsic string comparison functions.  */
3002
3003 static void
3004 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3005 {
3006   tree args[4];
3007
3008   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3009
3010   se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
3011   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3012                           build_int_cst (TREE_TYPE (se->expr), 0));
3013 }
3014
3015 /* Generate a call to the adjustl/adjustr library function.  */
3016 static void
3017 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3018 {
3019   tree args[3];
3020   tree len;
3021   tree type;
3022   tree var;
3023   tree tmp;
3024
3025   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3026   len = args[1];
3027
3028   type = TREE_TYPE (args[2]);
3029   var = gfc_conv_string_tmp (se, type, len);
3030   args[0] = var;
3031
3032   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3033   gfc_add_expr_to_block (&se->pre, tmp);
3034   se->expr = var;
3035   se->string_length = len;
3036 }
3037
3038
3039 /* Array transfer statement.
3040      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3041    where:
3042      typeof<DEST> = typeof<MOLD>
3043    and:
3044      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3045               sizeof (DEST(0) * SIZE).  */
3046
3047 static void
3048 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3049 {
3050   tree tmp;
3051   tree extent;
3052   tree source;
3053   tree source_type;
3054   tree source_bytes;
3055   tree mold_type;
3056   tree dest_word_len;
3057   tree size_words;
3058   tree size_bytes;
3059   tree upper;
3060   tree lower;
3061   tree stride;
3062   tree stmt;
3063   gfc_actual_arglist *arg;
3064   gfc_se argse;
3065   gfc_ss *ss;
3066   gfc_ss_info *info;
3067   stmtblock_t block;
3068   int n;
3069
3070   gcc_assert (se->loop);
3071   info = &se->ss->data.info;
3072
3073   /* Convert SOURCE.  The output from this stage is:-
3074         source_bytes = length of the source in bytes
3075         source = pointer to the source data.  */
3076   arg = expr->value.function.actual;
3077   gfc_init_se (&argse, NULL);
3078   ss = gfc_walk_expr (arg->expr);
3079
3080   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3081
3082   /* Obtain the pointer to source and the length of source in bytes.  */
3083   if (ss == gfc_ss_terminator)
3084     {
3085       gfc_conv_expr_reference (&argse, arg->expr);
3086       source = argse.expr;
3087
3088       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3089
3090       /* Obtain the source word length.  */
3091       if (arg->expr->ts.type == BT_CHARACTER)
3092         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3093       else
3094         tmp = fold_convert (gfc_array_index_type,
3095                             size_in_bytes (source_type));
3096     }
3097   else
3098     {
3099       argse.want_pointer = 0;
3100       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3101       source = gfc_conv_descriptor_data_get (argse.expr);
3102       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3103
3104       /* Repack the source if not a full variable array.  */
3105       if (!(arg->expr->expr_type == EXPR_VARIABLE
3106               && arg->expr->ref->u.ar.type == AR_FULL))
3107         {
3108           tmp = build_fold_addr_expr (argse.expr);
3109           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3110           source = gfc_evaluate_now (source, &argse.pre);
3111
3112           /* Free the temporary.  */
3113           gfc_start_block (&block);
3114           tmp = gfc_call_free (convert (pvoid_type_node, source));
3115           gfc_add_expr_to_block (&block, tmp);
3116           stmt = gfc_finish_block (&block);
3117
3118           /* Clean up if it was repacked.  */
3119           gfc_init_block (&block);
3120           tmp = gfc_conv_array_data (argse.expr);
3121           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3122           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3123           gfc_add_expr_to_block (&block, tmp);
3124           gfc_add_block_to_block (&block, &se->post);
3125           gfc_init_block (&se->post);
3126           gfc_add_block_to_block (&se->post, &block);
3127         }
3128
3129       /* Obtain the source word length.  */
3130       if (arg->expr->ts.type == BT_CHARACTER)
3131         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3132       else
3133         tmp = fold_convert (gfc_array_index_type,
3134                             size_in_bytes (source_type));
3135
3136       /* Obtain the size of the array in bytes.  */
3137       extent = gfc_create_var (gfc_array_index_type, NULL);
3138       for (n = 0; n < arg->expr->rank; n++)
3139         {
3140           tree idx;
3141           idx = gfc_rank_cst[n];
3142           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3143           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3144           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3145           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3146           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3147                              upper, lower);
3148           gfc_add_modify_expr (&argse.pre, extent, tmp);
3149           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3150                              extent, gfc_index_one_node);
3151           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3152                              tmp, source_bytes);
3153         }
3154     }
3155
3156   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3157   gfc_add_block_to_block (&se->pre, &argse.pre);
3158   gfc_add_block_to_block (&se->post, &argse.post);
3159
3160   /* Now convert MOLD.  The outputs are:
3161         mold_type = the TREE type of MOLD
3162         dest_word_len = destination word length in bytes.  */
3163   arg = arg->next;
3164
3165   gfc_init_se (&argse, NULL);
3166   ss = gfc_walk_expr (arg->expr);
3167
3168   if (ss == gfc_ss_terminator)
3169     {
3170       gfc_conv_expr_reference (&argse, arg->expr);
3171       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3172     }
3173   else
3174     {
3175       gfc_init_se (&argse, NULL);
3176       argse.want_pointer = 0;
3177       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3178       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3179     }
3180
3181   if (arg->expr->ts.type == BT_CHARACTER)
3182     {
3183       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3184       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3185     }
3186   else
3187     tmp = fold_convert (gfc_array_index_type,
3188                         size_in_bytes (mold_type));
3189
3190   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3191   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3192
3193   /* Finally convert SIZE, if it is present.  */
3194   arg = arg->next;
3195   size_words = gfc_create_var (gfc_array_index_type, NULL);
3196
3197   if (arg->expr)
3198     {
3199       gfc_init_se (&argse, NULL);
3200       gfc_conv_expr_reference (&argse, arg->expr);
3201       tmp = convert (gfc_array_index_type,
3202                          build_fold_indirect_ref (argse.expr));
3203       gfc_add_block_to_block (&se->pre, &argse.pre);
3204       gfc_add_block_to_block (&se->post, &argse.post);
3205     }
3206   else
3207     tmp = NULL_TREE;
3208
3209   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3210   if (tmp != NULL_TREE)
3211     {
3212       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3213                          tmp, dest_word_len);
3214       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3215                          tmp, source_bytes);
3216     }
3217   else
3218     tmp = source_bytes;
3219
3220   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3221   gfc_add_modify_expr (&se->pre, size_words,
3222                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3223                                     size_bytes, dest_word_len));
3224
3225   /* Evaluate the bounds of the result.  If the loop range exists, we have
3226      to check if it is too large.  If so, we modify loop->to be consistent
3227      with min(size, size(source)).  Otherwise, size is made consistent with
3228      the loop range, so that the right number of bytes is transferred.*/
3229   n = se->loop->order[0];
3230   if (se->loop->to[n] != NULL_TREE)
3231     {
3232       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3233                          se->loop->to[n], se->loop->from[n]);
3234       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3235                          tmp, gfc_index_one_node);
3236       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3237                          tmp, size_words);
3238       gfc_add_modify_expr (&se->pre, size_words, tmp);
3239       gfc_add_modify_expr (&se->pre, size_bytes,
3240                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3241                                         size_words, dest_word_len));
3242       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3243                            size_words, se->loop->from[n]);
3244       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3245                            upper, gfc_index_one_node);
3246     }
3247   else
3248     {
3249       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3250                            size_words, gfc_index_one_node);
3251       se->loop->from[n] = gfc_index_zero_node;
3252     }
3253
3254   se->loop->to[n] = upper;
3255
3256   /* Build a destination descriptor, using the pointer, source, as the
3257      data field.  This is already allocated so set callee_alloc.
3258      FIXME callee_alloc is not set!  */
3259
3260   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3261                                info, mold_type, false, true, false);
3262
3263   /* Cast the pointer to the result.  */
3264   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3265   tmp = fold_convert (pvoid_type_node, tmp);
3266
3267   /* Use memcpy to do the transfer.  */
3268   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3269                          3,
3270                          tmp,
3271                          fold_convert (pvoid_type_node, source),
3272                          size_bytes);
3273   gfc_add_expr_to_block (&se->pre, tmp);
3274
3275   se->expr = info->descriptor;
3276   if (expr->ts.type == BT_CHARACTER)
3277     se->string_length = dest_word_len;
3278 }
3279
3280
3281 /* Scalar transfer statement.
3282    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3283
3284 static void
3285 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3286 {
3287   gfc_actual_arglist *arg;
3288   gfc_se argse;
3289   tree type;
3290   tree ptr;
3291   gfc_ss *ss;
3292   tree tmpdecl, tmp;
3293
3294   /* Get a pointer to the source.  */
3295   arg = expr->value.function.actual;
3296   ss = gfc_walk_expr (arg->expr);
3297   gfc_init_se (&argse, NULL);
3298   if (ss == gfc_ss_terminator)
3299     gfc_conv_expr_reference (&argse, arg->expr);
3300   else
3301     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3302   gfc_add_block_to_block (&se->pre, &argse.pre);
3303   gfc_add_block_to_block (&se->post, &argse.post);
3304   ptr = argse.expr;
3305
3306   arg = arg->next;
3307   type = gfc_typenode_for_spec (&expr->ts);
3308
3309   if (expr->ts.type == BT_CHARACTER)
3310     {
3311       ptr = convert (build_pointer_type (type), ptr);
3312       gfc_init_se (&argse, NULL);
3313       gfc_conv_expr (&argse, arg->expr);
3314       gfc_add_block_to_block (&se->pre, &argse.pre);
3315       gfc_add_block_to_block (&se->post, &argse.post);
3316       se->expr = ptr;
3317       se->string_length = argse.string_length;
3318     }
3319   else
3320     {
3321       tree moldsize;
3322       tmpdecl = gfc_create_var (type, "transfer");
3323       moldsize = size_in_bytes (type);
3324
3325       /* Use memcpy to do the transfer.  */
3326       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3327       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3328                              fold_convert (pvoid_type_node, tmp),
3329                              fold_convert (pvoid_type_node, ptr),
3330                              moldsize);
3331       gfc_add_expr_to_block (&se->pre, tmp);
3332
3333       se->expr = tmpdecl;
3334     }
3335 }
3336
3337
3338 /* Generate code for the ALLOCATED intrinsic.
3339    Generate inline code that directly check the address of the argument.  */
3340
3341 static void
3342 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3343 {
3344   gfc_actual_arglist *arg1;
3345   gfc_se arg1se;
3346   gfc_ss *ss1;
3347   tree tmp;
3348
3349   gfc_init_se (&arg1se, NULL);
3350   arg1 = expr->value.function.actual;
3351   ss1 = gfc_walk_expr (arg1->expr);
3352   arg1se.descriptor_only = 1;
3353   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3354
3355   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3356   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3357                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3358   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3359 }
3360
3361
3362 /* Generate code for the ASSOCIATED intrinsic.
3363    If both POINTER and TARGET are arrays, generate a call to library function
3364    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3365    In other cases, generate inline code that directly compare the address of
3366    POINTER with the address of TARGET.  */
3367
3368 static void
3369 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3370 {
3371   gfc_actual_arglist *arg1;
3372   gfc_actual_arglist *arg2;
3373   gfc_se arg1se;
3374   gfc_se arg2se;
3375   tree tmp2;
3376   tree tmp;
3377   tree nonzero_charlen;
3378   tree nonzero_arraylen;
3379   gfc_ss *ss1, *ss2;
3380
3381   gfc_init_se (&arg1se, NULL);
3382   gfc_init_se (&arg2se, NULL);
3383   arg1 = expr->value.function.actual;
3384   arg2 = arg1->next;
3385   ss1 = gfc_walk_expr (arg1->expr);
3386
3387   if (!arg2->expr)
3388     {
3389       /* No optional target.  */
3390       if (ss1 == gfc_ss_terminator)
3391         {
3392           /* A pointer to a scalar.  */
3393           arg1se.want_pointer = 1;
3394           gfc_conv_expr (&arg1se, arg1->expr);
3395           tmp2 = arg1se.expr;
3396         }
3397       else
3398         {
3399           /* A pointer to an array.  */
3400           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3401           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3402         }
3403       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3404       gfc_add_block_to_block (&se->post, &arg1se.post);
3405       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3406                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3407       se->expr = tmp;
3408     }
3409   else
3410     {
3411       /* An optional target.  */
3412       ss2 = gfc_walk_expr (arg2->expr);
3413
3414       nonzero_charlen = NULL_TREE;
3415       if (arg1->expr->ts.type == BT_CHARACTER)
3416         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3417                                   arg1->expr->ts.cl->backend_decl,
3418                                   integer_zero_node);
3419
3420       if (ss1 == gfc_ss_terminator)
3421         {
3422           /* A pointer to a scalar.  */
3423           gcc_assert (ss2 == gfc_ss_terminator);
3424           arg1se.want_pointer = 1;
3425           gfc_conv_expr (&arg1se, arg1->expr);
3426           arg2se.want_pointer = 1;
3427           gfc_conv_expr (&arg2se, arg2->expr);
3428           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3429           gfc_add_block_to_block (&se->post, &arg1se.post);
3430           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3431           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3432                          null_pointer_node);
3433           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3434         }
3435       else
3436         {
3437           /* An array pointer of zero length is not associated if target is
3438              present.  */
3439           arg1se.descriptor_only = 1;
3440           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3441           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3442                                             gfc_rank_cst[arg1->expr->rank - 1]);
3443           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3444                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3445
3446           /* A pointer to an array, call library function _gfor_associated.  */
3447           gcc_assert (ss2 != gfc_ss_terminator);
3448           arg1se.want_pointer = 1;
3449           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3450
3451           arg2se.want_pointer = 1;
3452           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3453           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3454           gfc_add_block_to_block (&se->post, &arg2se.post);
3455           se->expr = build_call_expr (gfor_fndecl_associated, 2,
3456                                       arg1se.expr, arg2se.expr);
3457           se->expr = convert (boolean_type_node, se->expr);
3458           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3459                              se->expr, nonzero_arraylen);
3460         }
3461
3462       /* If target is present zero character length pointers cannot
3463          be associated.  */
3464       if (nonzero_charlen != NULL_TREE)
3465         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3466                            se->expr, nonzero_charlen);
3467     }
3468
3469   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3470 }
3471
3472
3473 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3474
3475 static void
3476 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3477 {
3478   tree arg, type;
3479
3480   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3481
3482   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
3483   type = gfc_get_int_type (4);
3484   arg = build_fold_addr_expr (fold_convert (type, arg));
3485
3486   /* Convert it to the required type.  */
3487   type = gfc_typenode_for_spec (&expr->ts);
3488   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3489   se->expr = fold_convert (type, se->expr);
3490 }
3491
3492
3493 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3494
3495 static void
3496 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3497 {
3498   gfc_actual_arglist *actual;
3499   tree args, type;
3500   gfc_se argse;
3501
3502   args = NULL_TREE;
3503   for (actual = expr->value.function.actual; actual; actual = actual->next)
3504     {
3505       gfc_init_se (&argse, se);
3506
3507       /* Pass a NULL pointer for an absent arg.  */
3508       if (actual->expr == NULL)
3509         argse.expr = null_pointer_node;
3510       else
3511         {
3512           gfc_typespec ts;
3513           if (actual->expr->ts.kind != gfc_c_int_kind)
3514             {
3515               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
3516               ts.type = BT_INTEGER;
3517               ts.kind = gfc_c_int_kind;
3518               gfc_convert_type (actual->expr, &ts, 2);
3519             }
3520           gfc_conv_expr_reference (&argse, actual->expr);
3521         }
3522
3523       gfc_add_block_to_block (&se->pre, &argse.pre);
3524       gfc_add_block_to_block (&se->post, &argse.post);
3525       args = gfc_chainon_list (args, argse.expr);
3526     }
3527
3528   /* Convert it to the required type.  */
3529   type = gfc_typenode_for_spec (&expr->ts);
3530   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3531   se->expr = fold_convert (type, se->expr);
3532 }
3533
3534
3535 /* Generate code for TRIM (A) intrinsic function.  */
3536
3537 static void
3538 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3539 {
3540   tree gfc_int4_type_node = gfc_get_int_type (4);
3541   tree var;
3542   tree len;
3543   tree addr;
3544   tree tmp;
3545   tree type;
3546   tree cond;
3547   tree fndecl;
3548   tree *args;
3549   unsigned int num_args;
3550
3551   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3552   args = alloca (sizeof (tree) * num_args);
3553
3554   type = build_pointer_type (gfc_character1_type_node);
3555   var = gfc_create_var (type, "pstr");
3556   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3557   len = gfc_create_var (gfc_int4_type_node, "len");
3558
3559   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3560   args[0] = build_fold_addr_expr (len);
3561   args[1] = addr;
3562
3563   fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3564   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3565                           fndecl, num_args, args);
3566   gfc_add_expr_to_block (&se->pre, tmp);
3567
3568   /* Free the temporary afterwards, if necessary.  */
3569   cond = build2 (GT_EXPR, boolean_type_node, len,
3570                  build_int_cst (TREE_TYPE (len), 0));
3571   tmp = gfc_call_free (var);
3572   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3573   gfc_add_expr_to_block (&se->post, tmp);
3574
3575   se->expr = var;
3576   se->string_length = len;
3577 }
3578
3579
3580 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3581
3582 static void
3583 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3584 {
3585   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3586   tree type, cond, tmp, count, exit_label, n, max, largest;
3587   stmtblock_t block, body;
3588   int i;
3589
3590   /* Get the arguments.  */
3591   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3592   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3593   src = args[1];
3594   ncopies = gfc_evaluate_now (args[2], &se->pre);
3595   ncopies_type = TREE_TYPE (ncopies);
3596
3597   /* Check that NCOPIES is not negative.  */
3598   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3599                       build_int_cst (ncopies_type, 0));
3600   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3601                            "Argument NCOPIES of REPEAT intrinsic is negative "
3602                            "(its value is %lld)",
3603                            fold_convert (long_integer_type_node, ncopies));
3604
3605   /* If the source length is zero, any non negative value of NCOPIES
3606      is valid, and nothing happens.  */
3607   n = gfc_create_var (ncopies_type, "ncopies");
3608   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3609                       build_int_cst (size_type_node, 0));
3610   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3611                      build_int_cst (ncopies_type, 0), ncopies);
3612   gfc_add_modify_expr (&se->pre, n, tmp);
3613   ncopies = n;
3614
3615   /* Check that ncopies is not too large: ncopies should be less than
3616      (or equal to) MAX / slen, where MAX is the maximal integer of
3617      the gfc_charlen_type_node type.  If slen == 0, we need a special
3618      case to avoid the division by zero.  */
3619   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3620   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3621   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3622                      fold_convert (size_type_node, max), slen);
3623   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3624               ? size_type_node : ncopies_type;
3625   cond = fold_build2 (GT_EXPR, boolean_type_node,
3626                       fold_convert (largest, ncopies),
3627                       fold_convert (largest, max));
3628   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3629                      build_int_cst (size_type_node, 0));
3630   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3631                       cond);
3632   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3633                            "Argument NCOPIES of REPEAT intrinsic is too large");
3634
3635
3636   /* Compute the destination length.  */
3637   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3638                       fold_convert (gfc_charlen_type_node, slen),
3639                       fold_convert (gfc_charlen_type_node, ncopies));
3640   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3641   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3642
3643   /* Generate the code to do the repeat operation:
3644        for (i = 0; i < ncopies; i++)
3645          memmove (dest + (i * slen), src, slen);  */
3646   gfc_start_block (&block);
3647   count = gfc_create_var (ncopies_type, "count");
3648   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3649   exit_label = gfc_build_label_decl (NULL_TREE);
3650
3651   /* Start the loop body.  */
3652   gfc_start_block (&body);
3653
3654   /* Exit the loop if count >= ncopies.  */
3655   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3656   tmp = build1_v (GOTO_EXPR, exit_label);
3657   TREE_USED (exit_label) = 1;
3658   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3659                      build_empty_stmt ());
3660   gfc_add_expr_to_block (&body, tmp);
3661
3662   /* Call memmove (dest + (i*slen), src, slen).  */
3663   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3664                      fold_convert (gfc_charlen_type_node, slen),
3665                      fold_convert (gfc_charlen_type_node, count));
3666   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3667                      fold_convert (pchar_type_node, dest),
3668                      fold_convert (sizetype, tmp));
3669   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3670                          tmp, src, slen);
3671   gfc_add_expr_to_block (&body, tmp);
3672
3673   /* Increment count.  */
3674   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3675                 build_int_cst (TREE_TYPE (count), 1));
3676   gfc_add_modify_expr (&body, count, tmp);
3677
3678   /* Build the loop.  */
3679   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3680   gfc_add_expr_to_block (&block, tmp);
3681
3682   /* Add the exit label.  */
3683   tmp = build1_v (LABEL_EXPR, exit_label);
3684   gfc_add_expr_to_block (&block, tmp);
3685
3686   /* Finish the block.  */
3687   tmp = gfc_finish_block (&block);
3688   gfc_add_expr_to_block (&se->pre, tmp);
3689
3690   /* Set the result value.  */
3691   se->expr = dest;
3692   se->string_length = dlen;
3693 }
3694
3695
3696 /* Generate code for the IARGC intrinsic.  */
3697
3698 static void
3699 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3700 {
3701   tree tmp;
3702   tree fndecl;
3703   tree type;
3704
3705   /* Call the library function.  This always returns an INTEGER(4).  */
3706   fndecl = gfor_fndecl_iargc;
3707   tmp = build_call_expr (fndecl, 0);
3708
3709   /* Convert it to the required type.  */
3710   type = gfc_typenode_for_spec (&expr->ts);
3711   tmp = fold_convert (type, tmp);
3712
3713   se->expr = tmp;
3714 }
3715
3716
3717 /* The loc intrinsic returns the address of its argument as
3718    gfc_index_integer_kind integer.  */
3719
3720 static void
3721 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3722 {
3723   tree temp_var;
3724   gfc_expr *arg_expr;
3725   gfc_ss *ss;
3726
3727   gcc_assert (!se->ss);
3728
3729   arg_expr = expr->value.function.actual->expr;
3730   ss = gfc_walk_expr (arg_expr);
3731   if (ss == gfc_ss_terminator)
3732     gfc_conv_expr_reference (se, arg_expr);
3733   else
3734     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3735   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3736
3737   /* Create a temporary variable for loc return value.  Without this,
3738      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3739   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3740   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3741   se->expr = temp_var;
3742 }
3743
3744 /* Generate code for an intrinsic function.  Some map directly to library
3745    calls, others get special handling.  In some cases the name of the function
3746    used depends on the type specifiers.  */
3747
3748 void
3749 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3750 {
3751   gfc_intrinsic_sym *isym;
3752   const char *name;
3753   int lib;
3754
3755   isym = expr->value.function.isym;
3756
3757   name = &expr->value.function.name[2];
3758
3759   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3760     {
3761       lib = gfc_is_intrinsic_libcall (expr);
3762       if (lib != 0)
3763         {
3764           if (lib == 1)
3765             se->ignore_optional = 1;
3766           gfc_conv_intrinsic_funcall (se, expr);
3767           return;
3768         }
3769     }
3770
3771   switch (expr->value.function.isym->id)
3772     {
3773     case GFC_ISYM_NONE:
3774       gcc_unreachable ();
3775
3776     case GFC_ISYM_REPEAT:
3777       gfc_conv_intrinsic_repeat (se, expr);
3778       break;
3779
3780     case GFC_ISYM_TRIM:
3781       gfc_conv_intrinsic_trim (se, expr);
3782       break;
3783
3784     case GFC_ISYM_SI_KIND:
3785       gfc_conv_intrinsic_si_kind (se, expr);
3786       break;
3787
3788     case GFC_ISYM_SR_KIND:
3789       gfc_conv_intrinsic_sr_kind (se, expr);
3790       break;
3791
3792     case GFC_ISYM_EXPONENT:
3793       gfc_conv_intrinsic_exponent (se, expr);
3794       break;
3795
3796     case GFC_ISYM_SCAN:
3797       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
3798       break;
3799
3800     case GFC_ISYM_VERIFY:
3801       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
3802       break;
3803
3804     case GFC_ISYM_ALLOCATED:
3805       gfc_conv_allocated (se, expr);
3806       break;
3807
3808     case GFC_ISYM_ASSOCIATED:
3809       gfc_conv_associated(se, expr);
3810       break;
3811
3812     case GFC_ISYM_ABS:
3813       gfc_conv_intrinsic_abs (se, expr);
3814       break;
3815
3816     case GFC_ISYM_ADJUSTL:
3817       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3818       break;
3819
3820     case GFC_ISYM_ADJUSTR:
3821       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3822       break;
3823
3824     case GFC_ISYM_AIMAG:
3825       gfc_conv_intrinsic_imagpart (se, expr);
3826       break;
3827
3828     case GFC_ISYM_AINT:
3829       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3830       break;
3831
3832     case GFC_ISYM_ALL:
3833       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3834       break;
3835
3836     case GFC_ISYM_ANINT:
3837       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3838       break;
3839
3840     case GFC_ISYM_AND:
3841       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3842       break;
3843
3844     case GFC_ISYM_ANY:
3845       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3846       break;
3847
3848     case GFC_ISYM_BTEST:
3849       gfc_conv_intrinsic_btest (se, expr);
3850       break;
3851
3852     case GFC_ISYM_ACHAR:
3853     case GFC_ISYM_CHAR:
3854       gfc_conv_intrinsic_char (se, expr);
3855       break;
3856
3857     case GFC_ISYM_CONVERSION:
3858     case GFC_ISYM_REAL:
3859     case GFC_ISYM_LOGICAL:
3860     case GFC_ISYM_DBLE:
3861       gfc_conv_intrinsic_conversion (se, expr);
3862       break;
3863
3864       /* Integer conversions are handled separately to make sure we get the
3865          correct rounding mode.  */
3866     case GFC_ISYM_INT:
3867     case GFC_ISYM_INT2:
3868     case GFC_ISYM_INT8:
3869     case GFC_ISYM_LONG:
3870       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3871       break;
3872
3873     case GFC_ISYM_NINT:
3874       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3875       break;
3876
3877     case GFC_ISYM_CEILING:
3878       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3879       break;
3880
3881     case GFC_ISYM_FLOOR:
3882       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3883       break;
3884
3885     case GFC_ISYM_MOD:
3886       gfc_conv_intrinsic_mod (se, expr, 0);
3887       break;
3888
3889     case GFC_ISYM_MODULO:
3890       gfc_conv_intrinsic_mod (se, expr, 1);
3891       break;
3892
3893     case GFC_ISYM_CMPLX:
3894       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3895       break;
3896
3897     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3898       gfc_conv_intrinsic_iargc (se, expr);
3899       break;
3900
3901     case GFC_ISYM_COMPLEX:
3902       gfc_conv_intrinsic_cmplx (se, expr, 1);
3903       break;
3904
3905     case GFC_ISYM_CONJG:
3906       gfc_conv_intrinsic_conjg (se, expr);
3907       break;
3908
3909     case GFC_ISYM_COUNT:
3910       gfc_conv_intrinsic_count (se, expr);
3911       break;
3912
3913     case GFC_ISYM_CTIME:
3914       gfc_conv_intrinsic_ctime (se, expr);
3915       break;
3916
3917     case GFC_ISYM_DIM:
3918       gfc_conv_intrinsic_dim (se, expr);
3919       break;
3920
3921     case GFC_ISYM_DOT_PRODUCT:
3922       gfc_conv_intrinsic_dot_product (se, expr);
3923       break;
3924
3925     case GFC_ISYM_DPROD:
3926       gfc_conv_intrinsic_dprod (se, expr);
3927       break;
3928
3929     case GFC_ISYM_FDATE:
3930       gfc_conv_intrinsic_fdate (se, expr);
3931       break;
3932
3933     case GFC_ISYM_IAND:
3934       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3935       break;
3936
3937     case GFC_ISYM_IBCLR:
3938       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3939       break;
3940
3941     case GFC_ISYM_IBITS:
3942       gfc_conv_intrinsic_ibits (se, expr);
3943       break;
3944
3945     case GFC_ISYM_IBSET:
3946       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3947       break;
3948
3949     case GFC_ISYM_IACHAR:
3950     case GFC_ISYM_ICHAR:
3951       /* We assume ASCII character sequence.  */
3952       gfc_conv_intrinsic_ichar (se, expr);
3953       break;
3954
3955     case GFC_ISYM_IARGC:
3956       gfc_conv_intrinsic_iargc (se, expr);
3957       break;
3958
3959     case GFC_ISYM_IEOR:
3960       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3961       break;
3962
3963     case GFC_ISYM_INDEX:
3964       gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
3965       break;
3966
3967     case GFC_ISYM_IOR:
3968       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3969       break;
3970
3971     case GFC_ISYM_ISNAN:
3972       gfc_conv_intrinsic_isnan (se, expr);
3973       break;
3974
3975     case GFC_ISYM_LSHIFT:
3976       gfc_conv_intrinsic_rlshift (se, expr, 0);
3977       break;
3978
3979     case GFC_ISYM_RSHIFT:
3980       gfc_conv_intrinsic_rlshift (se, expr, 1);
3981       break;
3982
3983     case GFC_ISYM_ISHFT:
3984       gfc_conv_intrinsic_ishft (se, expr);
3985       break;
3986
3987     case GFC_ISYM_ISHFTC:
3988       gfc_conv_intrinsic_ishftc (se, expr);
3989       break;
3990
3991     case GFC_ISYM_LBOUND:
3992       gfc_conv_intrinsic_bound (se, expr, 0);
3993       break;
3994
3995     case GFC_ISYM_TRANSPOSE:
3996       if (se->ss && se->ss->useflags)
3997         {
3998           gfc_conv_tmp_array_ref (se);
3999           gfc_advance_se_ss_chain (se);
4000         }
4001       else
4002         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4003       break;
4004
4005     case GFC_ISYM_LEN:
4006       gfc_conv_intrinsic_len (se, expr);
4007       break;
4008
4009     case GFC_ISYM_LEN_TRIM:
4010       gfc_conv_intrinsic_len_trim (se, expr);
4011       break;
4012
4013     case GFC_ISYM_LGE:
4014       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4015       break;
4016
4017     case GFC_ISYM_LGT:
4018       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4019       break;
4020
4021     case GFC_ISYM_LLE:
4022       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4023       break;
4024
4025     case GFC_ISYM_LLT:
4026       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4027       break;
4028
4029     case GFC_ISYM_MAX:
4030       if (expr->ts.type == BT_CHARACTER)
4031         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4032       else
4033         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4034       break;
4035
4036     case GFC_ISYM_MAXLOC:
4037       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4038       break;
4039
4040     case GFC_ISYM_MAXVAL:
4041       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4042       break;
4043
4044     case GFC_ISYM_MERGE:
4045       gfc_conv_intrinsic_merge (se, expr);
4046       break;
4047
4048     case GFC_ISYM_MIN:
4049       if (expr->ts.type == BT_CHARACTER)
4050         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4051       else
4052         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4053       break;
4054
4055     case GFC_ISYM_MINLOC:
4056       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4057       break;
4058
4059     case GFC_ISYM_MINVAL:
4060       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4061       break;
4062
4063     case GFC_ISYM_NOT:
4064       gfc_conv_intrinsic_not (se, expr);
4065       break;
4066
4067     case GFC_ISYM_OR:
4068       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4069       break;
4070
4071     case GFC_ISYM_PRESENT:
4072       gfc_conv_intrinsic_present (se, expr);
4073       break;
4074
4075     case GFC_ISYM_PRODUCT:
4076       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4077       break;
4078
4079     case GFC_ISYM_SIGN:
4080       gfc_conv_intrinsic_sign (se, expr);
4081       break;
4082
4083     case GFC_ISYM_SIZE:
4084       gfc_conv_intrinsic_size (se, expr);
4085       break;
4086
4087     case GFC_ISYM_SIZEOF:
4088       gfc_conv_intrinsic_sizeof (se, expr);
4089       break;
4090
4091     case GFC_ISYM_SUM:
4092       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4093       break;
4094
4095     case GFC_ISYM_TRANSFER:
4096       if (se->ss)
4097         {
4098           if (se->ss->useflags)
4099             {
4100               /* Access the previously obtained result.  */
4101               gfc_conv_tmp_array_ref (se);
4102               gfc_advance_se_ss_chain (se);
4103               break;
4104             }
4105           else
4106             gfc_conv_intrinsic_array_transfer (se, expr);
4107         }
4108       else
4109         gfc_conv_intrinsic_transfer (se, expr);
4110       break;
4111
4112     case GFC_ISYM_TTYNAM:
4113       gfc_conv_intrinsic_ttynam (se, expr);
4114       break;
4115
4116     case GFC_ISYM_UBOUND:
4117       gfc_conv_intrinsic_bound (se, expr, 1);
4118       break;
4119
4120     case GFC_ISYM_XOR:
4121       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4122       break;
4123
4124     case GFC_ISYM_LOC:
4125       gfc_conv_intrinsic_loc (se, expr);
4126       break;
4127
4128     case GFC_ISYM_ACCESS:
4129     case GFC_ISYM_CHDIR:
4130     case GFC_ISYM_CHMOD:
4131     case GFC_ISYM_ETIME:
4132     case GFC_ISYM_FGET:
4133     case GFC_ISYM_FGETC:
4134     case GFC_ISYM_FNUM:
4135     case GFC_ISYM_FPUT:
4136     case GFC_ISYM_FPUTC:
4137     case GFC_ISYM_FSTAT:
4138     case GFC_ISYM_FTELL:
4139     case GFC_ISYM_GETCWD:
4140     case GFC_ISYM_GETGID:
4141     case GFC_ISYM_GETPID:
4142     case GFC_ISYM_GETUID:
4143     case GFC_ISYM_HOSTNM:
4144     case GFC_ISYM_KILL:
4145     case GFC_ISYM_IERRNO:
4146     case GFC_ISYM_IRAND:
4147     case GFC_ISYM_ISATTY:
4148     case GFC_ISYM_LINK:
4149     case GFC_ISYM_LSTAT:
4150     case GFC_ISYM_MALLOC:
4151     case GFC_ISYM_MATMUL:
4152     case GFC_ISYM_MCLOCK:
4153     case GFC_ISYM_MCLOCK8:
4154     case GFC_ISYM_RAND:
4155     case GFC_ISYM_RENAME:
4156     case GFC_ISYM_SECOND:
4157     case GFC_ISYM_SECNDS:
4158     case GFC_ISYM_SIGNAL:
4159     case GFC_ISYM_STAT:
4160     case GFC_ISYM_SYMLNK:
4161     case GFC_ISYM_SYSTEM:
4162     case GFC_ISYM_TIME:
4163     case GFC_ISYM_TIME8:
4164     case GFC_ISYM_UMASK:
4165     case GFC_ISYM_UNLINK:
4166       gfc_conv_intrinsic_funcall (se, expr);
4167       break;
4168
4169     default:
4170       gfc_conv_intrinsic_lib_function (se, expr);
4171       break;
4172     }
4173 }
4174
4175
4176 /* This generates code to execute before entering the scalarization loop.
4177    Currently does nothing.  */
4178
4179 void
4180 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4181 {
4182   switch (ss->expr->value.function.isym->id)
4183     {
4184     case GFC_ISYM_UBOUND:
4185     case GFC_ISYM_LBOUND:
4186       break;
4187
4188     default:
4189       gcc_unreachable ();
4190     }
4191 }
4192
4193
4194 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4195    inside the scalarization loop.  */
4196
4197 static gfc_ss *
4198 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4199 {
4200   gfc_ss *newss;
4201
4202   /* The two argument version returns a scalar.  */
4203   if (expr->value.function.actual->next->expr)
4204     return ss;
4205
4206   newss = gfc_get_ss ();
4207   newss->type = GFC_SS_INTRINSIC;
4208   newss->expr = expr;
4209   newss->next = ss;
4210   newss->data.info.dimen = 1;
4211
4212   return newss;
4213 }
4214
4215
4216 /* Walk an intrinsic array libcall.  */
4217
4218 static gfc_ss *
4219 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4220 {
4221   gfc_ss *newss;
4222
4223   gcc_assert (expr->rank > 0);
4224
4225   newss = gfc_get_ss ();
4226   newss->type = GFC_SS_FUNCTION;
4227   newss->expr = expr;
4228   newss->next = ss;
4229   newss->data.info.dimen = expr->rank;
4230
4231   return newss;
4232 }
4233
4234
4235 /* Returns nonzero if the specified intrinsic function call maps directly to a
4236    an external library call.  Should only be used for functions that return
4237    arrays.  */
4238
4239 int
4240 gfc_is_intrinsic_libcall (gfc_expr * expr)
4241 {
4242   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4243   gcc_assert (expr->rank > 0);
4244
4245   switch (expr->value.function.isym->id)
4246     {
4247     case GFC_ISYM_ALL:
4248     case GFC_ISYM_ANY:
4249     case GFC_ISYM_COUNT:
4250     case GFC_ISYM_MATMUL:
4251     case GFC_ISYM_MAXLOC:
4252     case GFC_ISYM_MAXVAL:
4253     case GFC_ISYM_MINLOC:
4254     case GFC_ISYM_MINVAL:
4255     case GFC_ISYM_PRODUCT:
4256     case GFC_ISYM_SUM:
4257     case GFC_ISYM_SHAPE:
4258     case GFC_ISYM_SPREAD:
4259     case GFC_ISYM_TRANSPOSE:
4260       /* Ignore absent optional parameters.  */
4261       return 1;
4262
4263     case GFC_ISYM_RESHAPE:
4264     case GFC_ISYM_CSHIFT:
4265     case GFC_ISYM_EOSHIFT:
4266     case GFC_ISYM_PACK:
4267     case GFC_ISYM_UNPACK:
4268       /* Pass absent optional parameters.  */
4269       return 2;
4270
4271     default:
4272       return 0;
4273     }
4274 }
4275
4276 /* Walk an intrinsic function.  */
4277 gfc_ss *
4278 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4279                              gfc_intrinsic_sym * isym)
4280 {
4281   gcc_assert (isym);
4282
4283   if (isym->elemental)
4284     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4285
4286   if (expr->rank == 0)
4287     return ss;
4288
4289   if (gfc_is_intrinsic_libcall (expr))
4290     return gfc_walk_intrinsic_libfunc (ss, expr);
4291
4292   /* Special cases.  */
4293   switch (isym->id)
4294     {
4295     case GFC_ISYM_LBOUND:
4296     case GFC_ISYM_UBOUND:
4297       return gfc_walk_intrinsic_bound (ss, expr);
4298
4299     case GFC_ISYM_TRANSFER:
4300       return gfc_walk_intrinsic_libfunc (ss, expr);
4301
4302     default:
4303       /* This probably meant someone forgot to add an intrinsic to the above
4304          list(s) when they implemented it, or something's gone horribly wrong.
4305        */
4306       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4307                       expr->value.function.name);
4308     }
4309 }
4310
4311 #include "gt-fortran-trans-intrinsic.h"