gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "tree-gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct gfc_intrinsic_map_t      GTY(())
  49 {
  50   /* The explicit enum is required to work around inadequacies in the
  51      garbage collection/gengtype parsing mechanism.  */
  52   enum gfc_isym_id id;
  53
  54   /* Enum value from the "language-independent", aka C-centric, part
  55      of gcc, or END_BUILTINS of no such value set.  */
  56   enum built_in_function code_r4;
  57   enum built_in_function code_r8;
  58   enum built_in_function code_r10;
  59   enum built_in_function code_r16;
  60   enum built_in_function code_c4;
  61   enum built_in_function code_c8;
  62   enum built_in_function code_c10;
  63   enum built_in_function code_c16;
  64
  65   /* True if the naming pattern is to prepend "c" for complex and
  66      append "f" for kind=4.  False if the naming pattern is to
  67      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  68   bool libm_name;
  69
  70   /* True if a complex version of the function exists.  */
  71   bool complex_available;
  72
  73   /* True if the function should be marked const.  */
  74   bool is_constant;
  75
  76   /* The base library name of this function.  */
  77   const char *name;
  78
  79   /* Cache decls created for the various operand types.  */
  80   tree real4_decl;
  81   tree real8_decl;
  82   tree real10_decl;
  83   tree real16_decl;
  84   tree complex4_decl;
  85   tree complex8_decl;
  86   tree complex10_decl;
  87   tree complex16_decl;
  88 }
  89 gfc_intrinsic_map_t;
  90
  91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  92    defines complex variants of all of the entries in mathbuiltins.def
  93    except for atan2.  */
  94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  95   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  96     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  97     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  99
 100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 106
 107 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 112
 113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 114   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 115     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 116     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 117     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 118
 119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 120 {
 121   /* Functions built into gcc itself.  */
 122 #include "mathbuiltins.def"
 123
 124   /* Functions in libm.  */
 125   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 126      pattern for other mathbuiltins.def entries.  At present we have no
 127      optimizations for this in the common sources.  */
 128   LIBM_FUNCTION (SCALE, "scalbn", false),
 129
 130   /* Functions in libgfortran.  */
 131   LIBF_FUNCTION (FRACTION, "fraction", false),
 132   LIBF_FUNCTION (NEAREST, "nearest", false),
 133   LIBF_FUNCTION (RRSPACING, "rrspacing", false),
 134   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 135   LIBF_FUNCTION (SPACING, "spacing", false),
 136
 137   /* End the list.  */
 138   LIBF_FUNCTION (NONE, NULL, false)
 139 };
 140 #undef DEFINE_MATH_BUILTIN
 141 #undef DEFINE_MATH_BUILTIN_C
 142 #undef LIBM_FUNCTION
 143 #undef LIBF_FUNCTION
 144
 145 /* Structure for storing components of a floating number to be used by
 146    elemental functions to manipulate reals.  */
 147 typedef struct
 148 {
 149   tree arg;     /* Variable tree to view convert to integer.  */
 150   tree expn;    /* Variable tree to save exponent.  */
 151   tree frac;    /* Variable tree to save fraction.  */
 152   tree smask;   /* Constant tree of sign's mask.  */
 153   tree emask;   /* Constant tree of exponent's mask.  */
 154   tree fmask;   /* Constant tree of fraction's mask.  */
 155   tree edigits; /* Constant tree of the number of exponent bits.  */
 156   tree fdigits; /* Constant tree of the number of fraction bits.  */
 157   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 158   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 159   tree type;    /* Type tree of arg1.  */
 160   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 161 }
 162 real_compnt_info;
 163
 164 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 165
 166 /* Evaluate the arguments to an intrinsic function.  The value
 167    of NARGS may be less than the actual number of arguments in EXPR
 168    to allow optional "KIND" arguments that are not included in the
 169    generated code to be ignored.  */
 170
 171 static void
 172 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 173                                   tree *argarray, int nargs)
 174 {
 175   gfc_actual_arglist *actual;
 176   gfc_expr *e;
 177   gfc_intrinsic_arg  *formal;
 178   gfc_se argse;
 179   int curr_arg;
 180
 181   formal = expr->value.function.isym->formal;
 182   actual = expr->value.function.actual;
 183
 184    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 185         actual = actual->next,
 186         formal = formal ? formal->next : NULL)
 187     {
 188       gcc_assert (actual);
 189       e = actual->expr;
 190       /* Skip omitted optional arguments.  */
 191       if (!e)
 192         {
 193           --curr_arg;
 194           continue;
 195         }
 196
 197       /* Evaluate the parameter.  This will substitute scalarized
 198          references automatically.  */
 199       gfc_init_se (&argse, se);
 200
 201       if (e->ts.type == BT_CHARACTER)
 202         {
 203           gfc_conv_expr (&argse, e);
 204           gfc_conv_string_parameter (&argse);
 205           argarray[curr_arg++] = argse.string_length;
 206           gcc_assert (curr_arg < nargs);
 207         }
 208       else
 209         gfc_conv_expr_val (&argse, e);
 210
 211       /* If an optional argument is itself an optional dummy argument,
 212          check its presence and substitute a null if absent.  */
 213       if (e->expr_type ==EXPR_VARIABLE
 214             && e->symtree->n.sym->attr.optional
 215             && formal
 216             && formal->optional)
 217         gfc_conv_missing_dummy (&argse, e, formal->ts);
 218
 219       gfc_add_block_to_block (&se->pre, &argse.pre);
 220       gfc_add_block_to_block (&se->post, &argse.post);
 221       argarray[curr_arg] = argse.expr;
 222     }
 223 }
 224
 225 /* Count the number of actual arguments to the intrinsic function EXPR
 226    including any "hidden" string length arguments.  */
 227
 228 static unsigned int
 229 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 230 {
 231   int n = 0;
 232   gfc_actual_arglist *actual;
 233
 234   for (actual = expr->value.function.actual; actual; actual = actual->next)
 235     {
 236       if (!actual->expr)
 237         continue;
 238
 239       if (actual->expr->ts.type == BT_CHARACTER)
 240         n += 2;
 241       else
 242         n++;
 243     }
 244
 245   return n;
 246 }
 247
 248
 249 /* Conversions between different types are output by the frontend as
 250    intrinsic functions.  We implement these directly with inline code.  */
 251
 252 static void
 253 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 254 {
 255   tree type;
 256   tree *args;
 257   int nargs;
 258
 259   nargs = gfc_intrinsic_argument_list_length (expr);
 260   args = alloca (sizeof (tree) * nargs);
 261
 262   /* Evaluate all the arguments passed. Whilst we're only interested in the
 263      first one here, there are other parts of the front-end that assume this
 264      and will trigger an ICE if it's not the case.  */
 265   type = gfc_typenode_for_spec (&expr->ts);
 266   gcc_assert (expr->value.function.actual->expr);
 267   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 268
 269   /* Conversion from complex to non-complex involves taking the real
 270      component of the value.  */
 271   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 272       && expr->ts.type != BT_COMPLEX)
 273     {
 274       tree artype;
 275
 276       artype = TREE_TYPE (TREE_TYPE (args[0]));
 277       args[0] = build1 (REALPART_EXPR, artype, args[0]);
 278     }
 279
 280   se->expr = convert (type, args[0]);
 281 }
 282
 283 /* This is needed because the gcc backend only implements
 284    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 285    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 286    Similarly for CEILING.  */
 287
 288 static tree
 289 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 290 {
 291   tree tmp;
 292   tree cond;
 293   tree argtype;
 294   tree intval;
 295
 296   argtype = TREE_TYPE (arg);
 297   arg = gfc_evaluate_now (arg, pblock);
 298
 299   intval = convert (type, arg);
 300   intval = gfc_evaluate_now (intval, pblock);
 301
 302   tmp = convert (argtype, intval);
 303   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 304
 305   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 306                 build_int_cst (type, 1));
 307   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 308   return tmp;
 309 }
 310
 311
 312 /* Round to nearest integer, away from zero.  */
 313
 314 static tree
 315 build_round_expr (tree arg, tree restype)
 316 {
 317   tree tmp;
 318   tree argtype;
 319   tree fn;
 320   bool longlong, convert;
 321   int argprec, resprec;
 322
 323   argtype = TREE_TYPE (arg);
 324   argprec = TYPE_PRECISION (argtype);
 325   resprec = TYPE_PRECISION (restype);
 326
 327   /* Depending on the type of the result, choose the long int intrinsic
 328      (lround family) or long long intrinsic (llround).  We might also
 329      need to convert the result afterwards.  */
 330   if (resprec <= LONG_TYPE_SIZE)
 331     {
 332       longlong = false;
 333       if (resprec != LONG_TYPE_SIZE)
 334         convert = true;
 335       else
 336         convert = false;
 337     }
 338   else if (resprec <= LONG_LONG_TYPE_SIZE)
 339     {
 340       longlong = true;
 341       if (resprec != LONG_LONG_TYPE_SIZE)
 342         convert = true;
 343       else
 344         convert = false;
 345     }
 346   else
 347     gcc_unreachable ();
 348
 349   /* Now, depending on the argument type, we choose between intrinsics.  */
 350   if (argprec == TYPE_PRECISION (float_type_node))
 351     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
 352   else if (argprec == TYPE_PRECISION (double_type_node))
 353     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
 354   else if (argprec == TYPE_PRECISION (long_double_type_node))
 355     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
 356   else
 357     gcc_unreachable ();
 358
 359   tmp = build_call_expr (fn, 1, arg);
 360   if (convert)
 361     tmp = fold_convert (restype, tmp);
 362   return tmp;
 363 }
 364
 365
 366 /* Convert a real to an integer using a specific rounding mode.
 367    Ideally we would just build the corresponding GENERIC node,
 368    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 369
 370 static tree
 371 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 372                enum rounding_mode op)
 373 {
 374   switch (op)
 375     {
 376     case RND_FLOOR:
 377       return build_fixbound_expr (pblock, arg, type, 0);
 378       break;
 379
 380     case RND_CEIL:
 381       return build_fixbound_expr (pblock, arg, type, 1);
 382       break;
 383
 384     case RND_ROUND:
 385       return build_round_expr (arg, type);
 386       break;
 387
 388     case RND_TRUNC:
 389       return build1 (FIX_TRUNC_EXPR, type, arg);
 390       break;
 391
 392     default:
 393       gcc_unreachable ();
 394     }
 395 }
 396
 397
 398 /* Round a real value using the specified rounding mode.
 399    We use a temporary integer of that same kind size as the result.
 400    Values larger than those that can be represented by this kind are
 401    unchanged, as they will not be accurate enough to represent the
 402    rounding.
 403     huge = HUGE (KIND (a))
 404     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 405    */
 406
 407 static void
 408 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 409 {
 410   tree type;
 411   tree itype;
 412   tree arg;
 413   tree tmp;
 414   tree cond;
 415   mpfr_t huge;
 416   int n;
 417   int kind;
 418
 419   kind = expr->ts.kind;
 420
 421   n = END_BUILTINS;
 422   /* We have builtin functions for some cases.  */
 423   switch (op)
 424     {
 425     case RND_ROUND:
 426       switch (kind)
 427         {
 428         case 4:
 429           n = BUILT_IN_ROUNDF;
 430           break;
 431
 432         case 8:
 433           n = BUILT_IN_ROUND;
 434           break;
 435
 436         case 10:
 437         case 16:
 438           n = BUILT_IN_ROUNDL;
 439           break;
 440         }
 441       break;
 442
 443     case RND_TRUNC:
 444       switch (kind)
 445         {
 446         case 4:
 447           n = BUILT_IN_TRUNCF;
 448           break;
 449
 450         case 8:
 451           n = BUILT_IN_TRUNC;
 452           break;
 453
 454         case 10:
 455         case 16:
 456           n = BUILT_IN_TRUNCL;
 457           break;
 458         }
 459       break;
 460
 461     default:
 462       gcc_unreachable ();
 463     }
 464
 465   /* Evaluate the argument.  */
 466   gcc_assert (expr->value.function.actual->expr);
 467   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 468
 469   /* Use a builtin function if one exists.  */
 470   if (n != END_BUILTINS)
 471     {
 472       tmp = built_in_decls[n];
 473       se->expr = build_call_expr (tmp, 1, arg);
 474       return;
 475     }
 476
 477   /* This code is probably redundant, but we'll keep it lying around just
 478      in case.  */
 479   type = gfc_typenode_for_spec (&expr->ts);
 480   arg = gfc_evaluate_now (arg, &se->pre);
 481
 482   /* Test if the value is too large to handle sensibly.  */
 483   gfc_set_model_kind (kind);
 484   mpfr_init (huge);
 485   n = gfc_validate_kind (BT_INTEGER, kind, false);
 486   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 487   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 488   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
 489
 490   mpfr_neg (huge, huge, GFC_RND_MODE);
 491   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 492   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
 493   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 494   itype = gfc_get_int_type (kind);
 495
 496   tmp = build_fix_expr (&se->pre, arg, itype, op);
 497   tmp = convert (type, tmp);
 498   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
 499   mpfr_clear (huge);
 500 }
 501
 502
 503 /* Convert to an integer using the specified rounding mode.  */
 504
 505 static void
 506 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 507 {
 508   tree type;
 509   tree *args;
 510   int nargs;
 511
 512   nargs = gfc_intrinsic_argument_list_length (expr);
 513   args = alloca (sizeof (tree) * nargs);
 514
 515   /* Evaluate the argument, we process all arguments even though we only
 516      use the first one for code generation purposes.  */
 517   type = gfc_typenode_for_spec (&expr->ts);
 518   gcc_assert (expr->value.function.actual->expr);
 519   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 520
 521   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 522     {
 523       /* Conversion to a different integer kind.  */
 524       se->expr = convert (type, args[0]);
 525     }
 526   else
 527     {
 528       /* Conversion from complex to non-complex involves taking the real
 529          component of the value.  */
 530       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 531           && expr->ts.type != BT_COMPLEX)
 532         {
 533           tree artype;
 534
 535           artype = TREE_TYPE (TREE_TYPE (args[0]));
 536           args[0] = build1 (REALPART_EXPR, artype, args[0]);
 537         }
 538
 539       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 540     }
 541 }
 542
 543
 544 /* Get the imaginary component of a value.  */
 545
 546 static void
 547 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 548 {
 549   tree arg;
 550
 551   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 552   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 553 }
 554
 555
 556 /* Get the complex conjugate of a value.  */
 557
 558 static void
 559 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 560 {
 561   tree arg;
 562
 563   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 564   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 565 }
 566
 567
 568 /* Initialize function decls for library functions.  The external functions
 569    are created as required.  Builtin functions are added here.  */
 570
 571 void
 572 gfc_build_intrinsic_lib_fndecls (void)
 573 {
 574   gfc_intrinsic_map_t *m;
 575
 576   /* Add GCC builtin functions.  */
 577   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 578     {
 579       if (m->code_r4 != END_BUILTINS)
 580         m->real4_decl = built_in_decls[m->code_r4];
 581       if (m->code_r8 != END_BUILTINS)
 582         m->real8_decl = built_in_decls[m->code_r8];
 583       if (m->code_r10 != END_BUILTINS)
 584         m->real10_decl = built_in_decls[m->code_r10];
 585       if (m->code_r16 != END_BUILTINS)
 586         m->real16_decl = built_in_decls[m->code_r16];
 587       if (m->code_c4 != END_BUILTINS)
 588         m->complex4_decl = built_in_decls[m->code_c4];
 589       if (m->code_c8 != END_BUILTINS)
 590         m->complex8_decl = built_in_decls[m->code_c8];
 591       if (m->code_c10 != END_BUILTINS)
 592         m->complex10_decl = built_in_decls[m->code_c10];
 593       if (m->code_c16 != END_BUILTINS)
 594         m->complex16_decl = built_in_decls[m->code_c16];
 595     }
 596 }
 597
 598
 599 /* Create a fndecl for a simple intrinsic library function.  */
 600
 601 static tree
 602 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 603 {
 604   tree type;
 605   tree argtypes;
 606   tree fndecl;
 607   gfc_actual_arglist *actual;
 608   tree *pdecl;
 609   gfc_typespec *ts;
 610   char name[GFC_MAX_SYMBOL_LEN + 3];
 611
 612   ts = &expr->ts;
 613   if (ts->type == BT_REAL)
 614     {
 615       switch (ts->kind)
 616         {
 617         case 4:
 618           pdecl = &m->real4_decl;
 619           break;
 620         case 8:
 621           pdecl = &m->real8_decl;
 622           break;
 623         case 10:
 624           pdecl = &m->real10_decl;
 625           break;
 626         case 16:
 627           pdecl = &m->real16_decl;
 628           break;
 629         default:
 630           gcc_unreachable ();
 631         }
 632     }
 633   else if (ts->type == BT_COMPLEX)
 634     {
 635       gcc_assert (m->complex_available);
 636
 637       switch (ts->kind)
 638         {
 639         case 4:
 640           pdecl = &m->complex4_decl;
 641           break;
 642         case 8:
 643           pdecl = &m->complex8_decl;
 644           break;
 645         case 10:
 646           pdecl = &m->complex10_decl;
 647           break;
 648         case 16:
 649           pdecl = &m->complex16_decl;
 650           break;
 651         default:
 652           gcc_unreachable ();
 653         }
 654     }
 655   else
 656     gcc_unreachable ();
 657
 658   if (*pdecl)
 659     return *pdecl;
 660
 661   if (m->libm_name)
 662     {
 663       if (ts->kind == 4)
 664         snprintf (name, sizeof (name), "%s%s%s",
 665                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 666       else if (ts->kind == 8)
 667         snprintf (name, sizeof (name), "%s%s",
 668                 ts->type == BT_COMPLEX ? "c" : "", m->name);
 669       else
 670         {
 671           gcc_assert (ts->kind == 10 || ts->kind == 16);
 672           snprintf (name, sizeof (name), "%s%s%s",
 673                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 674         }
 675     }
 676   else
 677     {
 678       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 679                 ts->type == BT_COMPLEX ? 'c' : 'r',
 680                 ts->kind);
 681     }
 682
 683   argtypes = NULL_TREE;
 684   for (actual = expr->value.function.actual; actual; actual = actual->next)
 685     {
 686       type = gfc_typenode_for_spec (&actual->expr->ts);
 687       argtypes = gfc_chainon_list (argtypes, type);
 688     }
 689   argtypes = gfc_chainon_list (argtypes, void_type_node);
 690   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 691   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 692
 693   /* Mark the decl as external.  */
 694   DECL_EXTERNAL (fndecl) = 1;
 695   TREE_PUBLIC (fndecl) = 1;
 696
 697   /* Mark it __attribute__((const)), if possible.  */
 698   TREE_READONLY (fndecl) = m->is_constant;
 699
 700   rest_of_decl_compilation (fndecl, 1, 0);
 701
 702   (*pdecl) = fndecl;
 703   return fndecl;
 704 }
 705
 706
 707 /* Convert an intrinsic function into an external or builtin call.  */
 708
 709 static void
 710 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 711 {
 712   gfc_intrinsic_map_t *m;
 713   tree fndecl;
 714   tree rettype;
 715   tree *args;
 716   unsigned int num_args;
 717   gfc_isym_id id;
 718
 719   id = expr->value.function.isym->id;
 720   /* Find the entry for this function.  */
 721   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 722     {
 723       if (id == m->id)
 724         break;
 725     }
 726
 727   if (m->id == GFC_ISYM_NONE)
 728     {
 729       internal_error ("Intrinsic function %s(%d) not recognized",
 730                       expr->value.function.name, id);
 731     }
 732
 733   /* Get the decl and generate the call.  */
 734   num_args = gfc_intrinsic_argument_list_length (expr);
 735   args = alloca (sizeof (tree) * num_args);
 736
 737   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 738   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 739   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 740
 741   fndecl = build_addr (fndecl, current_function_decl);
 742   se->expr = build_call_array (rettype, fndecl, num_args, args);
 743 }
 744
 745 /* Generate code for EXPONENT(X) intrinsic function.  */
 746
 747 static void
 748 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 749 {
 750   tree arg, fndecl, type;
 751   gfc_expr *a1;
 752
 753   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 754
 755   a1 = expr->value.function.actual->expr;
 756   switch (a1->ts.kind)
 757     {
 758     case 4:
 759       fndecl = gfor_fndecl_math_exponent4;
 760       break;
 761     case 8:
 762       fndecl = gfor_fndecl_math_exponent8;
 763       break;
 764     case 10:
 765       fndecl = gfor_fndecl_math_exponent10;
 766       break;
 767     case 16:
 768       fndecl = gfor_fndecl_math_exponent16;
 769       break;
 770     default:
 771       gcc_unreachable ();
 772     }
 773
 774   /* Convert it to the required type.  */
 775   type = gfc_typenode_for_spec (&expr->ts);
 776   se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
 777 }
 778
 779 /* Evaluate a single upper or lower bound.  */
 780 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 781
 782 static void
 783 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 784 {
 785   gfc_actual_arglist *arg;
 786   gfc_actual_arglist *arg2;
 787   tree desc;
 788   tree type;
 789   tree bound;
 790   tree tmp;
 791   tree cond, cond1, cond2, cond3, cond4, size;
 792   tree ubound;
 793   tree lbound;
 794   gfc_se argse;
 795   gfc_ss *ss;
 796   gfc_array_spec * as;
 797   gfc_ref *ref;
 798
 799   arg = expr->value.function.actual;
 800   arg2 = arg->next;
 801
 802   if (se->ss)
 803     {
 804       /* Create an implicit second parameter from the loop variable.  */
 805       gcc_assert (!arg2->expr);
 806       gcc_assert (se->loop->dimen == 1);
 807       gcc_assert (se->ss->expr == expr);
 808       gfc_advance_se_ss_chain (se);
 809       bound = se->loop->loopvar[0];
 810       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 811                            se->loop->from[0]);
 812     }
 813   else
 814     {
 815       /* use the passed argument.  */
 816       gcc_assert (arg->next->expr);
 817       gfc_init_se (&argse, NULL);
 818       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 819       gfc_add_block_to_block (&se->pre, &argse.pre);
 820       bound = argse.expr;
 821       /* Convert from one based to zero based.  */
 822       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 823                            gfc_index_one_node);
 824     }
 825
 826   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 827   /* Get a descriptor for the first parameter.  */
 828   ss = gfc_walk_expr (arg->expr);
 829   gcc_assert (ss != gfc_ss_terminator);
 830   gfc_init_se (&argse, NULL);
 831   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 832   gfc_add_block_to_block (&se->pre, &argse.pre);
 833   gfc_add_block_to_block (&se->post, &argse.post);
 834
 835   desc = argse.expr;
 836
 837   if (INTEGER_CST_P (bound))
 838     {
 839       int hi, low;
 840
 841       hi = TREE_INT_CST_HIGH (bound);
 842       low = TREE_INT_CST_LOW (bound);
 843       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 844         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 845                    "dimension index", upper ? "UBOUND" : "LBOUND",
 846                    &expr->where);
 847     }
 848   else
 849     {
 850       if (flag_bounds_check)
 851         {
 852           bound = gfc_evaluate_now (bound, &se->pre);
 853           cond = fold_build2 (LT_EXPR, boolean_type_node,
 854                               bound, build_int_cst (TREE_TYPE (bound), 0));
 855           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 856           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 857           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 858           gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
 859         }
 860     }
 861
 862   ubound = gfc_conv_descriptor_ubound (desc, bound);
 863   lbound = gfc_conv_descriptor_lbound (desc, bound);
 864
 865   /* Follow any component references.  */
 866   if (arg->expr->expr_type == EXPR_VARIABLE
 867       || arg->expr->expr_type == EXPR_CONSTANT)
 868     {
 869       as = arg->expr->symtree->n.sym->as;
 870       for (ref = arg->expr->ref; ref; ref = ref->next)
 871         {
 872           switch (ref->type)
 873             {
 874             case REF_COMPONENT:
 875               as = ref->u.c.component->as;
 876               continue;
 877
 878             case REF_SUBSTRING:
 879               continue;
 880
 881             case REF_ARRAY:
 882               {
 883                 switch (ref->u.ar.type)
 884                   {
 885                   case AR_ELEMENT:
 886                   case AR_SECTION:
 887                   case AR_UNKNOWN:
 888                     as = NULL;
 889                     continue;
 890
 891                   case AR_FULL:
 892                     break;
 893                   }
 894               }
 895             }
 896         }
 897     }
 898   else
 899     as = NULL;
 900
 901   /* 13.14.53: Result value for LBOUND
 902
 903      Case (i): For an array section or for an array expression other than a
 904                whole array or array structure component, LBOUND(ARRAY, DIM)
 905                has the value 1.  For a whole array or array structure
 906                component, LBOUND(ARRAY, DIM) has the value:
 907                  (a) equal to the lower bound for subscript DIM of ARRAY if
 908                      dimension DIM of ARRAY does not have extent zero
 909                      or if ARRAY is an assumed-size array of rank DIM,
 910               or (b) 1 otherwise.
 911
 912      13.14.113: Result value for UBOUND
 913
 914      Case (i): For an array section or for an array expression other than a
 915                whole array or array structure component, UBOUND(ARRAY, DIM)
 916                has the value equal to the number of elements in the given
 917                dimension; otherwise, it has a value equal to the upper bound
 918                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 919                not have size zero and has value zero if dimension DIM has
 920                size zero.  */
 921
 922   if (as)
 923     {
 924       tree stride = gfc_conv_descriptor_stride (desc, bound);
 925
 926       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 927       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 928
 929       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 930                            gfc_index_zero_node);
 931       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 932
 933       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 934                            gfc_index_zero_node);
 935       cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
 936
 937       if (upper)
 938         {
 939           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 940
 941           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 942                                   ubound, gfc_index_zero_node);
 943         }
 944       else
 945         {
 946           if (as->type == AS_ASSUMED_SIZE)
 947             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 948                                 build_int_cst (TREE_TYPE (bound),
 949                                                arg->expr->rank - 1));
 950           else
 951             cond = boolean_false_node;
 952
 953           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 954           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 955
 956           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 957                                   lbound, gfc_index_one_node);
 958         }
 959     }
 960   else
 961     {
 962       if (upper)
 963         {
 964           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
 965           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 966                                   gfc_index_one_node);
 967         }
 968       else
 969         se->expr = gfc_index_one_node;
 970     }
 971
 972   type = gfc_typenode_for_spec (&expr->ts);
 973   se->expr = convert (type, se->expr);
 974 }
 975
 976
 977 static void
 978 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 979 {
 980   tree arg;
 981   int n;
 982
 983   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 984
 985   switch (expr->value.function.actual->expr->ts.type)
 986     {
 987     case BT_INTEGER:
 988     case BT_REAL:
 989       se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
 990       break;
 991
 992     case BT_COMPLEX:
 993       switch (expr->ts.kind)
 994         {
 995         case 4:
 996           n = BUILT_IN_CABSF;
 997           break;
 998         case 8:
 999           n = BUILT_IN_CABS;
1000           break;
1001         case 10:
1002         case 16:
1003           n = BUILT_IN_CABSL;
1004           break;
1005         default:
1006           gcc_unreachable ();
1007         }
1008       se->expr = build_call_expr (built_in_decls[n], 1, arg);
1009       break;
1010
1011     default:
1012       gcc_unreachable ();
1013     }
1014 }
1015
1016
1017 /* Create a complex value from one or two real components.  */
1018
1019 static void
1020 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1021 {
1022   tree real;
1023   tree imag;
1024   tree type;
1025   tree *args;
1026   unsigned int num_args;
1027
1028   num_args = gfc_intrinsic_argument_list_length (expr);
1029   args = alloca (sizeof (tree) * num_args);
1030
1031   type = gfc_typenode_for_spec (&expr->ts);
1032   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1033   real = convert (TREE_TYPE (type), args[0]);
1034   if (both)
1035     imag = convert (TREE_TYPE (type), args[1]);
1036   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1037     {
1038       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1039       imag = convert (TREE_TYPE (type), imag);
1040     }
1041   else
1042     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1043
1044   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1045 }
1046
1047 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1048                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1049 /* TODO: MOD(x, 0)  */
1050
1051 static void
1052 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1053 {
1054   tree type;
1055   tree itype;
1056   tree tmp;
1057   tree test;
1058   tree test2;
1059   mpfr_t huge;
1060   int n, ikind;
1061   tree args[2];
1062
1063   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1064
1065   switch (expr->ts.type)
1066     {
1067     case BT_INTEGER:
1068       /* Integer case is easy, we've got a builtin op.  */
1069       type = TREE_TYPE (args[0]);
1070
1071       if (modulo)
1072        se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1073       else
1074        se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1075       break;
1076
1077     case BT_REAL:
1078       n = END_BUILTINS;
1079       /* Check if we have a builtin fmod.  */
1080       switch (expr->ts.kind)
1081         {
1082         case 4:
1083           n = BUILT_IN_FMODF;
1084           break;
1085
1086         case 8:
1087           n = BUILT_IN_FMOD;
1088           break;
1089
1090         case 10:
1091         case 16:
1092           n = BUILT_IN_FMODL;
1093           break;
1094
1095         default:
1096           break;
1097         }
1098
1099       /* Use it if it exists.  */
1100       if (n != END_BUILTINS)
1101         {
1102           tmp = build_addr (built_in_decls[n], current_function_decl);
1103           se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1104                                        tmp, 2, args);
1105           if (modulo == 0)
1106             return;
1107         }
1108
1109       type = TREE_TYPE (args[0]);
1110
1111       args[0] = gfc_evaluate_now (args[0], &se->pre);
1112       args[1] = gfc_evaluate_now (args[1], &se->pre);
1113
1114       /* Definition:
1115          modulo = arg - floor (arg/arg2) * arg2, so
1116                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1117          where
1118           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1119          thereby avoiding another division and retaining the accuracy
1120          of the builtin function.  */
1121       if (n != END_BUILTINS && modulo)
1122         {
1123           tree zero = gfc_build_const (type, integer_zero_node);
1124           tmp = gfc_evaluate_now (se->expr, &se->pre);
1125           test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
1126           test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
1127           test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1128           test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
1129           test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1130           test = gfc_evaluate_now (test, &se->pre);
1131           se->expr = build3 (COND_EXPR, type, test,
1132                              build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
1133           return;
1134         }
1135
1136       /* If we do not have a built_in fmod, the calculation is going to
1137          have to be done longhand.  */
1138       tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
1139
1140       /* Test if the value is too large to handle sensibly.  */
1141       gfc_set_model_kind (expr->ts.kind);
1142       mpfr_init (huge);
1143       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1144       ikind = expr->ts.kind;
1145       if (n < 0)
1146         {
1147           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1148           ikind = gfc_max_integer_kind;
1149         }
1150       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1151       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1152       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1153
1154       mpfr_neg (huge, huge, GFC_RND_MODE);
1155       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1156       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1157       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1158
1159       itype = gfc_get_int_type (ikind);
1160       if (modulo)
1161        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1162       else
1163        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1164       tmp = convert (type, tmp);
1165       tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
1166       tmp = build2 (MULT_EXPR, type, tmp, args[1]);
1167       se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
1168       mpfr_clear (huge);
1169       break;
1170
1171     default:
1172       gcc_unreachable ();
1173     }
1174 }
1175
1176 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1177
1178 static void
1179 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1180 {
1181   tree val;
1182   tree tmp;
1183   tree type;
1184   tree zero;
1185   tree args[2];
1186
1187   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1188   type = TREE_TYPE (args[0]);
1189
1190   val = build2 (MINUS_EXPR, type, args[0], args[1]);
1191   val = gfc_evaluate_now (val, &se->pre);
1192
1193   zero = gfc_build_const (type, integer_zero_node);
1194   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1195   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1196 }
1197
1198
1199 /* SIGN(A, B) is absolute value of A times sign of B.
1200    The real value versions use library functions to ensure the correct
1201    handling of negative zero.  Integer case implemented as:
1202    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1203   */
1204
1205 static void
1206 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1207 {
1208   tree tmp;
1209   tree type;
1210   tree args[2];
1211
1212   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1213   if (expr->ts.type == BT_REAL)
1214     {
1215       switch (expr->ts.kind)
1216         {
1217         case 4:
1218           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1219           break;
1220         case 8:
1221           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1222           break;
1223         case 10:
1224         case 16:
1225           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1226           break;
1227         default:
1228           gcc_unreachable ();
1229         }
1230       se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1231       return;
1232     }
1233
1234   /* Having excluded floating point types, we know we are now dealing
1235      with signed integer types.  */
1236   type = TREE_TYPE (args[0]);
1237
1238   /* Args[0] is used multiple times below.  */
1239   args[0] = gfc_evaluate_now (args[0], &se->pre);
1240
1241   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1242      the signs of A and B are the same, and of all ones if they differ.  */
1243   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1244   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1245                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1246   tmp = gfc_evaluate_now (tmp, &se->pre);
1247
1248   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1249      is all ones (i.e. -1).  */
1250   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1251                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1252                           tmp);
1253 }
1254
1255
1256 /* Test for the presence of an optional argument.  */
1257
1258 static void
1259 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1260 {
1261   gfc_expr *arg;
1262
1263   arg = expr->value.function.actual->expr;
1264   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1265   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1266   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1267 }
1268
1269
1270 /* Calculate the double precision product of two single precision values.  */
1271
1272 static void
1273 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1274 {
1275   tree type;
1276   tree args[2];
1277
1278   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1279
1280   /* Convert the args to double precision before multiplying.  */
1281   type = gfc_typenode_for_spec (&expr->ts);
1282   args[0] = convert (type, args[0]);
1283   args[1] = convert (type, args[1]);
1284   se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
1285 }
1286
1287
1288 /* Return a length one character string containing an ascii character.  */
1289
1290 static void
1291 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1292 {
1293   tree arg;
1294   tree var;
1295   tree type;
1296
1297   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1298
1299   /* We currently don't support character types != 1.  */
1300   gcc_assert (expr->ts.kind == 1);
1301   type = gfc_character1_type_node;
1302   var = gfc_create_var (type, "char");
1303
1304   arg = convert (type, arg);
1305   gfc_add_modify_expr (&se->pre, var, arg);
1306   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1307   se->string_length = integer_one_node;
1308 }
1309
1310
1311 static void
1312 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1313 {
1314   tree var;
1315   tree len;
1316   tree tmp;
1317   tree type;
1318   tree cond;
1319   tree gfc_int8_type_node = gfc_get_int_type (8);
1320   tree fndecl;
1321   tree *args;
1322   unsigned int num_args;
1323
1324   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1325   args = alloca (sizeof (tree) * num_args);
1326
1327   type = build_pointer_type (gfc_character1_type_node);
1328   var = gfc_create_var (type, "pstr");
1329   len = gfc_create_var (gfc_int8_type_node, "len");
1330
1331   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1332   args[0] = build_fold_addr_expr (var);
1333   args[1] = build_fold_addr_expr (len);
1334
1335   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1336   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1337                           fndecl, num_args, args);
1338   gfc_add_expr_to_block (&se->pre, tmp);
1339
1340   /* Free the temporary afterwards, if necessary.  */
1341   cond = build2 (GT_EXPR, boolean_type_node, len,
1342                  build_int_cst (TREE_TYPE (len), 0));
1343   tmp = gfc_call_free (var);
1344   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1345   gfc_add_expr_to_block (&se->post, tmp);
1346
1347   se->expr = var;
1348   se->string_length = len;
1349 }
1350
1351
1352 static void
1353 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1354 {
1355   tree var;
1356   tree len;
1357   tree tmp;
1358   tree type;
1359   tree cond;
1360   tree gfc_int4_type_node = gfc_get_int_type (4);
1361   tree fndecl;
1362   tree *args;
1363   unsigned int num_args;
1364
1365   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1366   args = alloca (sizeof (tree) * num_args);
1367
1368   type = build_pointer_type (gfc_character1_type_node);
1369   var = gfc_create_var (type, "pstr");
1370   len = gfc_create_var (gfc_int4_type_node, "len");
1371
1372   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1373   args[0] = build_fold_addr_expr (var);
1374   args[1] = build_fold_addr_expr (len);
1375
1376   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1377   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1378                           fndecl, num_args, args);
1379   gfc_add_expr_to_block (&se->pre, tmp);
1380
1381   /* Free the temporary afterwards, if necessary.  */
1382   cond = build2 (GT_EXPR, boolean_type_node, len,
1383                  build_int_cst (TREE_TYPE (len), 0));
1384   tmp = gfc_call_free (var);
1385   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1386   gfc_add_expr_to_block (&se->post, tmp);
1387
1388   se->expr = var;
1389   se->string_length = len;
1390 }
1391
1392
1393 /* Return a character string containing the tty name.  */
1394
1395 static void
1396 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1397 {
1398   tree var;
1399   tree len;
1400   tree tmp;
1401   tree type;
1402   tree cond;
1403   tree fndecl;
1404   tree gfc_int4_type_node = gfc_get_int_type (4);
1405   tree *args;
1406   unsigned int num_args;
1407
1408   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1409   args = alloca (sizeof (tree) * num_args);
1410
1411   type = build_pointer_type (gfc_character1_type_node);
1412   var = gfc_create_var (type, "pstr");
1413   len = gfc_create_var (gfc_int4_type_node, "len");
1414
1415   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416   args[0] = build_fold_addr_expr (var);
1417   args[1] = build_fold_addr_expr (len);
1418
1419   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1420   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1421                           fndecl, num_args, args);
1422   gfc_add_expr_to_block (&se->pre, tmp);
1423
1424   /* Free the temporary afterwards, if necessary.  */
1425   cond = build2 (GT_EXPR, boolean_type_node, len,
1426                  build_int_cst (TREE_TYPE (len), 0));
1427   tmp = gfc_call_free (var);
1428   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429   gfc_add_expr_to_block (&se->post, tmp);
1430
1431   se->expr = var;
1432   se->string_length = len;
1433 }
1434
1435
1436 /* Get the minimum/maximum value of all the parameters.
1437     minmax (a1, a2, a3, ...)
1438     {
1439       if (a2 .op. a1 || isnan(a1))
1440         mvar = a2;
1441       else
1442         mvar = a1;
1443       if (a3 .op. mvar || isnan(mvar))
1444         mvar = a3;
1445       ...
1446       return mvar
1447     }
1448  */
1449
1450 /* TODO: Mismatching types can occur when specific names are used.
1451    These should be handled during resolution.  */
1452 static void
1453 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1454 {
1455   tree limit;
1456   tree tmp;
1457   tree mvar;
1458   tree val;
1459   tree thencase;
1460   tree elsecase;
1461   tree *args;
1462   tree type;
1463   gfc_actual_arglist *argexpr;
1464   unsigned int i;
1465   unsigned int nargs;
1466
1467   nargs = gfc_intrinsic_argument_list_length (expr);
1468   args = alloca (sizeof (tree) * nargs);
1469
1470   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1471   type = gfc_typenode_for_spec (&expr->ts);
1472
1473   /* The first and second arguments should be present, if they are
1474      optional dummy arguments.  */
1475   argexpr = expr->value.function.actual;
1476   if (argexpr->expr->expr_type == EXPR_VARIABLE
1477       && argexpr->expr->symtree->n.sym->attr.optional
1478       && TREE_CODE (args[0]) == INDIRECT_REF)
1479     {
1480       /* Check the first argument.  */
1481       tree cond;
1482       char *msg;
1483
1484       asprintf (&msg, "First argument of '%s' intrinsic should be present",
1485                 expr->symtree->n.sym->name);
1486       cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
1487                      build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
1488       gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1489       gfc_free (msg);
1490     }
1491
1492   if (argexpr->next->expr->expr_type == EXPR_VARIABLE
1493       && argexpr->next->expr->symtree->n.sym->attr.optional
1494       && TREE_CODE (args[1]) == INDIRECT_REF)
1495     {
1496       /* Check the second argument.  */
1497       tree cond;
1498       char *msg;
1499
1500       asprintf (&msg, "Second argument of '%s' intrinsic should be present",
1501                 expr->symtree->n.sym->name);
1502       cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
1503                      build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
1504       gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1505       gfc_free (msg);
1506     }
1507
1508   limit = args[0];
1509   if (TREE_TYPE (limit) != type)
1510     limit = convert (type, limit);
1511   /* Only evaluate the argument once.  */
1512   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1513     limit = gfc_evaluate_now (limit, &se->pre);
1514
1515   mvar = gfc_create_var (type, "M");
1516   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1517   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1518     {
1519       tree cond, isnan;
1520
1521       val = args[i];
1522
1523       /* Handle absent optional arguments by ignoring the comparison.  */
1524       if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
1525           && argexpr->expr->symtree->n.sym->attr.optional
1526           && TREE_CODE (val) == INDIRECT_REF)
1527         cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1528                        build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1529       else
1530       {
1531         cond = NULL_TREE;
1532
1533         /* Only evaluate the argument once.  */
1534         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1535           val = gfc_evaluate_now (val, &se->pre);
1536       }
1537
1538       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1539
1540       tmp = build2 (op, boolean_type_node, convert (type, val), limit);
1541
1542       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1543          __builtin_isnan might be made dependent on that module being loaded,
1544          to help performance of programs that don't rely on IEEE semantics.  */
1545       if (FLOAT_TYPE_P (TREE_TYPE (limit)))
1546         {
1547           isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
1548           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
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 (gfc_se * se, gfc_expr * expr)
2763 {
2764   tree logical4_type_node = gfc_get_logical_type (4);
2765   tree type;
2766   tree fndecl;
2767   tree *args;
2768   unsigned int num_args;
2769
2770   num_args = gfc_intrinsic_argument_list_length (expr);
2771   args = alloca (sizeof (tree) * 5);
2772
2773   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2774   type = gfc_typenode_for_spec (&expr->ts);
2775
2776   if (num_args == 4)
2777     args[4] = build_int_cst (logical4_type_node, 0);
2778   else
2779     {
2780       gcc_assert (num_args == 5);
2781       args[4] = convert (logical4_type_node, args[4]);
2782     }
2783
2784   fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
2785   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
2786                                fndecl, 5, args);
2787   se->expr = convert (type, se->expr);
2788
2789 }
2790
2791 /* The ascii value for a single character.  */
2792 static void
2793 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2794 {
2795   tree args[2];
2796   tree type;
2797
2798   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2799   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2800   args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
2801   type = gfc_typenode_for_spec (&expr->ts);
2802
2803   se->expr = build_fold_indirect_ref (args[1]);
2804   se->expr = convert (type, se->expr);
2805 }
2806
2807
2808 /* Intrinsic ISNAN calls __builtin_isnan.  */
2809
2810 static void
2811 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
2812 {
2813   tree arg;
2814
2815   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2816   se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
2817   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2818 }
2819
2820 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2821
2822 static void
2823 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2824 {
2825   tree tsource;
2826   tree fsource;
2827   tree mask;
2828   tree type;
2829   tree len;
2830   tree *args;
2831   unsigned int num_args;
2832
2833   num_args = gfc_intrinsic_argument_list_length (expr);
2834   args = alloca (sizeof (tree) * num_args);
2835
2836   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2837   if (expr->ts.type != BT_CHARACTER)
2838     {
2839       tsource = args[0];
2840       fsource = args[1];
2841       mask = args[2];
2842     }
2843   else
2844     {
2845       /* We do the same as in the non-character case, but the argument
2846          list is different because of the string length arguments. We
2847          also have to set the string length for the result.  */
2848       len = args[0];
2849       tsource = args[1];
2850       fsource = args[3];
2851       mask = args[4];
2852
2853       se->string_length = len;
2854     }
2855   type = TREE_TYPE (tsource);
2856   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2857 }
2858
2859
2860 static void
2861 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2862 {
2863   gfc_actual_arglist *actual;
2864   tree arg1;
2865   tree type;
2866   tree fncall0;
2867   tree fncall1;
2868   gfc_se argse;
2869   gfc_ss *ss;
2870
2871   gfc_init_se (&argse, NULL);
2872   actual = expr->value.function.actual;
2873
2874   ss = gfc_walk_expr (actual->expr);
2875   gcc_assert (ss != gfc_ss_terminator);
2876   argse.want_pointer = 1;
2877   argse.data_not_needed = 1;
2878   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2879   gfc_add_block_to_block (&se->pre, &argse.pre);
2880   gfc_add_block_to_block (&se->post, &argse.post);
2881   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2882
2883   /* Build the call to size0.  */
2884   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2885
2886   actual = actual->next;
2887
2888   if (actual->expr)
2889     {
2890       gfc_init_se (&argse, NULL);
2891       gfc_conv_expr_type (&argse, actual->expr,
2892                           gfc_array_index_type);
2893       gfc_add_block_to_block (&se->pre, &argse.pre);
2894
2895       /* Build the call to size1.  */
2896       fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2897                                  arg1, argse.expr);
2898
2899       /* Unusually, for an intrinsic, size does not exclude
2900          an optional arg2, so we must test for it.  */
2901       if (actual->expr->expr_type == EXPR_VARIABLE
2902             && actual->expr->symtree->n.sym->attr.dummy
2903             && actual->expr->symtree->n.sym->attr.optional)
2904         {
2905           tree tmp;
2906           gfc_init_se (&argse, NULL);
2907           argse.want_pointer = 1;
2908           argse.data_not_needed = 1;
2909           gfc_conv_expr (&argse, actual->expr);
2910           gfc_add_block_to_block (&se->pre, &argse.pre);
2911           tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2912                         null_pointer_node);
2913           tmp = gfc_evaluate_now (tmp, &se->pre);
2914           se->expr = build3 (COND_EXPR, pvoid_type_node,
2915                              tmp, fncall1, fncall0);
2916         }
2917       else
2918         se->expr = fncall1;
2919     }
2920   else
2921     se->expr = fncall0;
2922
2923   type = gfc_typenode_for_spec (&expr->ts);
2924   se->expr = convert (type, se->expr);
2925 }
2926
2927
2928 static void
2929 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2930 {
2931   gfc_expr *arg;
2932   gfc_ss *ss;
2933   gfc_se argse;
2934   tree source;
2935   tree source_bytes;
2936   tree type;
2937   tree tmp;
2938   tree lower;
2939   tree upper;
2940   /*tree stride;*/
2941   int n;
2942
2943   arg = expr->value.function.actual->expr;
2944
2945   gfc_init_se (&argse, NULL);
2946   ss = gfc_walk_expr (arg);
2947
2948   source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2949
2950   if (ss == gfc_ss_terminator)
2951     {
2952       gfc_conv_expr_reference (&argse, arg);
2953       source = argse.expr;
2954
2955       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2956
2957       /* Obtain the source word length.  */
2958       if (arg->ts.type == BT_CHARACTER)
2959         source_bytes = fold_convert (gfc_array_index_type,
2960                                      argse.string_length);
2961       else
2962         source_bytes = fold_convert (gfc_array_index_type,
2963                                      size_in_bytes (type));
2964     }
2965   else
2966     {
2967       argse.want_pointer = 0;
2968       gfc_conv_expr_descriptor (&argse, arg, ss);
2969       source = gfc_conv_descriptor_data_get (argse.expr);
2970       type = gfc_get_element_type (TREE_TYPE (argse.expr));
2971
2972       /* Obtain the argument's word length.  */
2973       if (arg->ts.type == BT_CHARACTER)
2974         tmp = fold_convert (gfc_array_index_type, argse.string_length);
2975       else
2976         tmp = fold_convert (gfc_array_index_type,
2977                             size_in_bytes (type));
2978       gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2979
2980       /* Obtain the size of the array in bytes.  */
2981       for (n = 0; n < arg->rank; n++)
2982         {
2983           tree idx;
2984           idx = gfc_rank_cst[n];
2985           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2986           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2987           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2988                              upper, lower);
2989           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2990                              tmp, gfc_index_one_node);
2991           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2992                              tmp, source_bytes);
2993           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2994         }
2995     }
2996
2997   gfc_add_block_to_block (&se->pre, &argse.pre);
2998   se->expr = source_bytes;
2999 }
3000
3001
3002 /* Intrinsic string comparison functions.  */
3003
3004 static void
3005 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3006 {
3007   tree args[4];
3008
3009   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3010
3011   se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
3012   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3013                           build_int_cst (TREE_TYPE (se->expr), 0));
3014 }
3015
3016 /* Generate a call to the adjustl/adjustr library function.  */
3017 static void
3018 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3019 {
3020   tree args[3];
3021   tree len;
3022   tree type;
3023   tree var;
3024   tree tmp;
3025
3026   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3027   len = args[1];
3028
3029   type = TREE_TYPE (args[2]);
3030   var = gfc_conv_string_tmp (se, type, len);
3031   args[0] = var;
3032
3033   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3034   gfc_add_expr_to_block (&se->pre, tmp);
3035   se->expr = var;
3036   se->string_length = len;
3037 }
3038
3039
3040 /* Array transfer statement.
3041      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3042    where:
3043      typeof<DEST> = typeof<MOLD>
3044    and:
3045      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3046               sizeof (DEST(0) * SIZE).  */
3047
3048 static void
3049 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3050 {
3051   tree tmp;
3052   tree extent;
3053   tree source;
3054   tree source_type;
3055   tree source_bytes;
3056   tree mold_type;
3057   tree dest_word_len;
3058   tree size_words;
3059   tree size_bytes;
3060   tree upper;
3061   tree lower;
3062   tree stride;
3063   tree stmt;
3064   gfc_actual_arglist *arg;
3065   gfc_se argse;
3066   gfc_ss *ss;
3067   gfc_ss_info *info;
3068   stmtblock_t block;
3069   int n;
3070
3071   gcc_assert (se->loop);
3072   info = &se->ss->data.info;
3073
3074   /* Convert SOURCE.  The output from this stage is:-
3075         source_bytes = length of the source in bytes
3076         source = pointer to the source data.  */
3077   arg = expr->value.function.actual;
3078   gfc_init_se (&argse, NULL);
3079   ss = gfc_walk_expr (arg->expr);
3080
3081   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3082
3083   /* Obtain the pointer to source and the length of source in bytes.  */
3084   if (ss == gfc_ss_terminator)
3085     {
3086       gfc_conv_expr_reference (&argse, arg->expr);
3087       source = argse.expr;
3088
3089       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3090
3091       /* Obtain the source word length.  */
3092       if (arg->expr->ts.type == BT_CHARACTER)
3093         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3094       else
3095         tmp = fold_convert (gfc_array_index_type,
3096                             size_in_bytes (source_type));
3097     }
3098   else
3099     {
3100       argse.want_pointer = 0;
3101       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3102       source = gfc_conv_descriptor_data_get (argse.expr);
3103       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3104
3105       /* Repack the source if not a full variable array.  */
3106       if (!(arg->expr->expr_type == EXPR_VARIABLE
3107               && arg->expr->ref->u.ar.type == AR_FULL))
3108         {
3109           tmp = build_fold_addr_expr (argse.expr);
3110           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3111           source = gfc_evaluate_now (source, &argse.pre);
3112
3113           /* Free the temporary.  */
3114           gfc_start_block (&block);
3115           tmp = gfc_call_free (convert (pvoid_type_node, source));
3116           gfc_add_expr_to_block (&block, tmp);
3117           stmt = gfc_finish_block (&block);
3118
3119           /* Clean up if it was repacked.  */
3120           gfc_init_block (&block);
3121           tmp = gfc_conv_array_data (argse.expr);
3122           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3123           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3124           gfc_add_expr_to_block (&block, tmp);
3125           gfc_add_block_to_block (&block, &se->post);
3126           gfc_init_block (&se->post);
3127           gfc_add_block_to_block (&se->post, &block);
3128         }
3129
3130       /* Obtain the source word length.  */
3131       if (arg->expr->ts.type == BT_CHARACTER)
3132         tmp = fold_convert (gfc_array_index_type, argse.string_length);
3133       else
3134         tmp = fold_convert (gfc_array_index_type,
3135                             size_in_bytes (source_type));
3136
3137       /* Obtain the size of the array in bytes.  */
3138       extent = gfc_create_var (gfc_array_index_type, NULL);
3139       for (n = 0; n < arg->expr->rank; n++)
3140         {
3141           tree idx;
3142           idx = gfc_rank_cst[n];
3143           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3144           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3145           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3146           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3147           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3148                              upper, lower);
3149           gfc_add_modify_expr (&argse.pre, extent, tmp);
3150           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3151                              extent, gfc_index_one_node);
3152           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3153                              tmp, source_bytes);
3154         }
3155     }
3156
3157   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3158   gfc_add_block_to_block (&se->pre, &argse.pre);
3159   gfc_add_block_to_block (&se->post, &argse.post);
3160
3161   /* Now convert MOLD.  The outputs are:
3162         mold_type = the TREE type of MOLD
3163         dest_word_len = destination word length in bytes.  */
3164   arg = arg->next;
3165
3166   gfc_init_se (&argse, NULL);
3167   ss = gfc_walk_expr (arg->expr);
3168
3169   if (ss == gfc_ss_terminator)
3170     {
3171       gfc_conv_expr_reference (&argse, arg->expr);
3172       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3173     }
3174   else
3175     {
3176       gfc_init_se (&argse, NULL);
3177       argse.want_pointer = 0;
3178       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3179       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3180     }
3181
3182   if (arg->expr->ts.type == BT_CHARACTER)
3183     {
3184       tmp = fold_convert (gfc_array_index_type, argse.string_length);
3185       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3186     }
3187   else
3188     tmp = fold_convert (gfc_array_index_type,
3189                         size_in_bytes (mold_type));
3190
3191   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3192   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3193
3194   /* Finally convert SIZE, if it is present.  */
3195   arg = arg->next;
3196   size_words = gfc_create_var (gfc_array_index_type, NULL);
3197
3198   if (arg->expr)
3199     {
3200       gfc_init_se (&argse, NULL);
3201       gfc_conv_expr_reference (&argse, arg->expr);
3202       tmp = convert (gfc_array_index_type,
3203                          build_fold_indirect_ref (argse.expr));
3204       gfc_add_block_to_block (&se->pre, &argse.pre);
3205       gfc_add_block_to_block (&se->post, &argse.post);
3206     }
3207   else
3208     tmp = NULL_TREE;
3209
3210   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3211   if (tmp != NULL_TREE)
3212     {
3213       tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3214                          tmp, dest_word_len);
3215       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3216                          tmp, source_bytes);
3217     }
3218   else
3219     tmp = source_bytes;
3220
3221   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3222   gfc_add_modify_expr (&se->pre, size_words,
3223                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3224                                     size_bytes, dest_word_len));
3225
3226   /* Evaluate the bounds of the result.  If the loop range exists, we have
3227      to check if it is too large.  If so, we modify loop->to be consistent
3228      with min(size, size(source)).  Otherwise, size is made consistent with
3229      the loop range, so that the right number of bytes is transferred.*/
3230   n = se->loop->order[0];
3231   if (se->loop->to[n] != NULL_TREE)
3232     {
3233       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3234                          se->loop->to[n], se->loop->from[n]);
3235       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3236                          tmp, gfc_index_one_node);
3237       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3238                          tmp, size_words);
3239       gfc_add_modify_expr (&se->pre, size_words, tmp);
3240       gfc_add_modify_expr (&se->pre, size_bytes,
3241                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3242                                         size_words, dest_word_len));
3243       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3244                            size_words, se->loop->from[n]);
3245       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3246                            upper, gfc_index_one_node);
3247     }
3248   else
3249     {
3250       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3251                            size_words, gfc_index_one_node);
3252       se->loop->from[n] = gfc_index_zero_node;
3253     }
3254
3255   se->loop->to[n] = upper;
3256
3257   /* Build a destination descriptor, using the pointer, source, as the
3258      data field.  This is already allocated so set callee_alloc.
3259      FIXME callee_alloc is not set!  */
3260
3261   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3262                                info, mold_type, false, true, false);
3263
3264   /* Cast the pointer to the result.  */
3265   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3266   tmp = fold_convert (pvoid_type_node, tmp);
3267
3268   /* Use memcpy to do the transfer.  */
3269   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3270                          3,
3271                          tmp,
3272                          fold_convert (pvoid_type_node, source),
3273                          size_bytes);
3274   gfc_add_expr_to_block (&se->pre, tmp);
3275
3276   se->expr = info->descriptor;
3277   if (expr->ts.type == BT_CHARACTER)
3278     se->string_length = dest_word_len;
3279 }
3280
3281
3282 /* Scalar transfer statement.
3283    TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl.  */
3284
3285 static void
3286 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3287 {
3288   gfc_actual_arglist *arg;
3289   gfc_se argse;
3290   tree type;
3291   tree ptr;
3292   gfc_ss *ss;
3293   tree tmpdecl, tmp;
3294
3295   /* Get a pointer to the source.  */
3296   arg = expr->value.function.actual;
3297   ss = gfc_walk_expr (arg->expr);
3298   gfc_init_se (&argse, NULL);
3299   if (ss == gfc_ss_terminator)
3300     gfc_conv_expr_reference (&argse, arg->expr);
3301   else
3302     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3303   gfc_add_block_to_block (&se->pre, &argse.pre);
3304   gfc_add_block_to_block (&se->post, &argse.post);
3305   ptr = argse.expr;
3306
3307   arg = arg->next;
3308   type = gfc_typenode_for_spec (&expr->ts);
3309
3310   if (expr->ts.type == BT_CHARACTER)
3311     {
3312       ptr = convert (build_pointer_type (type), ptr);
3313       gfc_init_se (&argse, NULL);
3314       gfc_conv_expr (&argse, arg->expr);
3315       gfc_add_block_to_block (&se->pre, &argse.pre);
3316       gfc_add_block_to_block (&se->post, &argse.post);
3317       se->expr = ptr;
3318       se->string_length = argse.string_length;
3319     }
3320   else
3321     {
3322       tree moldsize;
3323       tmpdecl = gfc_create_var (type, "transfer");
3324       moldsize = size_in_bytes (type);
3325
3326       /* Use memcpy to do the transfer.  */
3327       tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3328       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3329                              fold_convert (pvoid_type_node, tmp),
3330                              fold_convert (pvoid_type_node, ptr),
3331                              moldsize);
3332       gfc_add_expr_to_block (&se->pre, tmp);
3333
3334       se->expr = tmpdecl;
3335     }
3336 }
3337
3338
3339 /* Generate code for the ALLOCATED intrinsic.
3340    Generate inline code that directly check the address of the argument.  */
3341
3342 static void
3343 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3344 {
3345   gfc_actual_arglist *arg1;
3346   gfc_se arg1se;
3347   gfc_ss *ss1;
3348   tree tmp;
3349
3350   gfc_init_se (&arg1se, NULL);
3351   arg1 = expr->value.function.actual;
3352   ss1 = gfc_walk_expr (arg1->expr);
3353   arg1se.descriptor_only = 1;
3354   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3355
3356   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3357   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3358                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3359   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3360 }
3361
3362
3363 /* Generate code for the ASSOCIATED intrinsic.
3364    If both POINTER and TARGET are arrays, generate a call to library function
3365    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3366    In other cases, generate inline code that directly compare the address of
3367    POINTER with the address of TARGET.  */
3368
3369 static void
3370 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3371 {
3372   gfc_actual_arglist *arg1;
3373   gfc_actual_arglist *arg2;
3374   gfc_se arg1se;
3375   gfc_se arg2se;
3376   tree tmp2;
3377   tree tmp;
3378   tree nonzero_charlen;
3379   tree nonzero_arraylen;
3380   gfc_ss *ss1, *ss2;
3381
3382   gfc_init_se (&arg1se, NULL);
3383   gfc_init_se (&arg2se, NULL);
3384   arg1 = expr->value.function.actual;
3385   arg2 = arg1->next;
3386   ss1 = gfc_walk_expr (arg1->expr);
3387
3388   if (!arg2->expr)
3389     {
3390       /* No optional target.  */
3391       if (ss1 == gfc_ss_terminator)
3392         {
3393           /* A pointer to a scalar.  */
3394           arg1se.want_pointer = 1;
3395           gfc_conv_expr (&arg1se, arg1->expr);
3396           tmp2 = arg1se.expr;
3397         }
3398       else
3399         {
3400           /* A pointer to an array.  */
3401           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3402           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3403         }
3404       gfc_add_block_to_block (&se->pre, &arg1se.pre);
3405       gfc_add_block_to_block (&se->post, &arg1se.post);
3406       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3407                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3408       se->expr = tmp;
3409     }
3410   else
3411     {
3412       /* An optional target.  */
3413       ss2 = gfc_walk_expr (arg2->expr);
3414
3415       nonzero_charlen = NULL_TREE;
3416       if (arg1->expr->ts.type == BT_CHARACTER)
3417         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3418                                   arg1->expr->ts.cl->backend_decl,
3419                                   integer_zero_node);
3420
3421       if (ss1 == gfc_ss_terminator)
3422         {
3423           /* A pointer to a scalar.  */
3424           gcc_assert (ss2 == gfc_ss_terminator);
3425           arg1se.want_pointer = 1;
3426           gfc_conv_expr (&arg1se, arg1->expr);
3427           arg2se.want_pointer = 1;
3428           gfc_conv_expr (&arg2se, arg2->expr);
3429           gfc_add_block_to_block (&se->pre, &arg1se.pre);
3430           gfc_add_block_to_block (&se->post, &arg1se.post);
3431           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3432           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3433                          null_pointer_node);
3434           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3435         }
3436       else
3437         {
3438           /* An array pointer of zero length is not associated if target is
3439              present.  */
3440           arg1se.descriptor_only = 1;
3441           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3442           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3443                                             gfc_rank_cst[arg1->expr->rank - 1]);
3444           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3445                                      tmp, build_int_cst (TREE_TYPE (tmp), 0));
3446
3447           /* A pointer to an array, call library function _gfor_associated.  */
3448           gcc_assert (ss2 != gfc_ss_terminator);
3449           arg1se.want_pointer = 1;
3450           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3451
3452           arg2se.want_pointer = 1;
3453           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3454           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3455           gfc_add_block_to_block (&se->post, &arg2se.post);
3456           se->expr = build_call_expr (gfor_fndecl_associated, 2,
3457                                       arg1se.expr, arg2se.expr);
3458           se->expr = convert (boolean_type_node, se->expr);
3459           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3460                              se->expr, nonzero_arraylen);
3461         }
3462
3463       /* If target is present zero character length pointers cannot
3464          be associated.  */
3465       if (nonzero_charlen != NULL_TREE)
3466         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3467                            se->expr, nonzero_charlen);
3468     }
3469
3470   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3471 }
3472
3473
3474 /* Scan a string for any one of the characters in a set of characters.  */
3475
3476 static void
3477 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3478 {
3479   tree logical4_type_node = gfc_get_logical_type (4);
3480   tree type;
3481   tree fndecl;
3482   tree *args;
3483   unsigned int num_args;
3484
3485   num_args = gfc_intrinsic_argument_list_length (expr);
3486   args = alloca (sizeof (tree) * 5);
3487
3488   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3489   type = gfc_typenode_for_spec (&expr->ts);
3490
3491   if (num_args == 4)
3492     args[4] = build_int_cst (logical4_type_node, 0);
3493   else
3494     {
3495       gcc_assert (num_args == 5);
3496       args[4] = convert (logical4_type_node, args[4]);
3497     }
3498
3499   fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
3500   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
3501                                fndecl, 5, args);
3502   se->expr = convert (type, se->expr);
3503 }
3504
3505
3506 /* Verify that a set of characters contains all the characters in a string
3507    by identifying the position of the first character in a string of
3508    characters that does not appear in a given set of characters.  */
3509
3510 static void
3511 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3512 {
3513   tree logical4_type_node = gfc_get_logical_type (4);
3514   tree type;
3515   tree fndecl;
3516   tree *args;
3517   unsigned int num_args;
3518
3519   num_args = gfc_intrinsic_argument_list_length (expr);
3520   args = alloca (sizeof (tree) * 5);
3521
3522   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3523   type = gfc_typenode_for_spec (&expr->ts);
3524
3525   if (num_args == 4)
3526     args[4] = build_int_cst (logical4_type_node, 0);
3527   else
3528     {
3529       gcc_assert (num_args == 5);
3530       args[4] = convert (logical4_type_node, args[4]);
3531     }
3532
3533   fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
3534   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
3535                                fndecl, 5, args);
3536
3537   se->expr = convert (type, se->expr);
3538 }
3539
3540
3541 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3542
3543 static void
3544 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3545 {
3546   tree arg, type;
3547
3548   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3549
3550   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
3551   type = gfc_get_int_type (4);
3552   arg = build_fold_addr_expr (fold_convert (type, arg));
3553
3554   /* Convert it to the required type.  */
3555   type = gfc_typenode_for_spec (&expr->ts);
3556   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3557   se->expr = fold_convert (type, se->expr);
3558 }
3559
3560
3561 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3562
3563 static void
3564 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3565 {
3566   gfc_actual_arglist *actual;
3567   tree args, type;
3568   gfc_se argse;
3569
3570   args = NULL_TREE;
3571   for (actual = expr->value.function.actual; actual; actual = actual->next)
3572     {
3573       gfc_init_se (&argse, se);
3574
3575       /* Pass a NULL pointer for an absent arg.  */
3576       if (actual->expr == NULL)
3577         argse.expr = null_pointer_node;
3578       else
3579         {
3580           gfc_typespec ts;
3581           if (actual->expr->ts.kind != gfc_c_int_kind)
3582             {
3583               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
3584               ts.type = BT_INTEGER;
3585               ts.kind = gfc_c_int_kind;
3586               gfc_convert_type (actual->expr, &ts, 2);
3587             }
3588           gfc_conv_expr_reference (&argse, actual->expr);
3589         }
3590
3591       gfc_add_block_to_block (&se->pre, &argse.pre);
3592       gfc_add_block_to_block (&se->post, &argse.post);
3593       args = gfc_chainon_list (args, argse.expr);
3594     }
3595
3596   /* Convert it to the required type.  */
3597   type = gfc_typenode_for_spec (&expr->ts);
3598   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3599   se->expr = fold_convert (type, se->expr);
3600 }
3601
3602
3603 /* Generate code for TRIM (A) intrinsic function.  */
3604
3605 static void
3606 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3607 {
3608   tree gfc_int4_type_node = gfc_get_int_type (4);
3609   tree var;
3610   tree len;
3611   tree addr;
3612   tree tmp;
3613   tree type;
3614   tree cond;
3615   tree fndecl;
3616   tree *args;
3617   unsigned int num_args;
3618
3619   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3620   args = alloca (sizeof (tree) * num_args);
3621
3622   type = build_pointer_type (gfc_character1_type_node);
3623   var = gfc_create_var (type, "pstr");
3624   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3625   len = gfc_create_var (gfc_int4_type_node, "len");
3626
3627   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3628   args[0] = build_fold_addr_expr (len);
3629   args[1] = addr;
3630
3631   fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3632   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3633                           fndecl, num_args, args);
3634   gfc_add_expr_to_block (&se->pre, tmp);
3635
3636   /* Free the temporary afterwards, if necessary.  */
3637   cond = build2 (GT_EXPR, boolean_type_node, len,
3638                  build_int_cst (TREE_TYPE (len), 0));
3639   tmp = gfc_call_free (var);
3640   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3641   gfc_add_expr_to_block (&se->post, tmp);
3642
3643   se->expr = var;
3644   se->string_length = len;
3645 }
3646
3647
3648 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3649
3650 static void
3651 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3652 {
3653   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3654   tree type, cond, tmp, count, exit_label, n, max, largest;
3655   stmtblock_t block, body;
3656   int i;
3657
3658   /* Get the arguments.  */
3659   gfc_conv_intrinsic_function_args (se, expr, args, 3);
3660   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3661   src = args[1];
3662   ncopies = gfc_evaluate_now (args[2], &se->pre);
3663   ncopies_type = TREE_TYPE (ncopies);
3664
3665   /* Check that NCOPIES is not negative.  */
3666   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3667                       build_int_cst (ncopies_type, 0));
3668   gfc_trans_runtime_check (cond,
3669                            "Argument NCOPIES of REPEAT intrinsic is negative",
3670                            &se->pre, &expr->where);
3671
3672   /* If the source length is zero, any non negative value of NCOPIES
3673      is valid, and nothing happens.  */
3674   n = gfc_create_var (ncopies_type, "ncopies");
3675   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3676                       build_int_cst (size_type_node, 0));
3677   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3678                      build_int_cst (ncopies_type, 0), ncopies);
3679   gfc_add_modify_expr (&se->pre, n, tmp);
3680   ncopies = n;
3681
3682   /* Check that ncopies is not too large: ncopies should be less than
3683      (or equal to) MAX / slen, where MAX is the maximal integer of
3684      the gfc_charlen_type_node type.  If slen == 0, we need a special
3685      case to avoid the division by zero.  */
3686   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3687   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3688   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3689                      fold_convert (size_type_node, max), slen);
3690   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3691               ? size_type_node : ncopies_type;
3692   cond = fold_build2 (GT_EXPR, boolean_type_node,
3693                       fold_convert (largest, ncopies),
3694                       fold_convert (largest, max));
3695   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3696                      build_int_cst (size_type_node, 0));
3697   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3698                       cond);
3699   gfc_trans_runtime_check (cond,
3700                            "Argument NCOPIES of REPEAT intrinsic is too large",
3701                            &se->pre, &expr->where);
3702
3703   /* Compute the destination length.  */
3704   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3705                       fold_convert (gfc_charlen_type_node, slen),
3706                       fold_convert (gfc_charlen_type_node, ncopies));
3707   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3708   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3709
3710   /* Generate the code to do the repeat operation:
3711        for (i = 0; i < ncopies; i++)
3712          memmove (dest + (i * slen), src, slen);  */
3713   gfc_start_block (&block);
3714   count = gfc_create_var (ncopies_type, "count");
3715   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3716   exit_label = gfc_build_label_decl (NULL_TREE);
3717
3718   /* Start the loop body.  */
3719   gfc_start_block (&body);
3720
3721   /* Exit the loop if count >= ncopies.  */
3722   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3723   tmp = build1_v (GOTO_EXPR, exit_label);
3724   TREE_USED (exit_label) = 1;
3725   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3726                      build_empty_stmt ());
3727   gfc_add_expr_to_block (&body, tmp);
3728
3729   /* Call memmove (dest + (i*slen), src, slen).  */
3730   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3731                      fold_convert (gfc_charlen_type_node, slen),
3732                      fold_convert (gfc_charlen_type_node, count));
3733   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3734                      fold_convert (pchar_type_node, dest),
3735                      fold_convert (sizetype, tmp));
3736   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3737                          tmp, src, slen);
3738   gfc_add_expr_to_block (&body, tmp);
3739
3740   /* Increment count.  */
3741   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3742                 build_int_cst (TREE_TYPE (count), 1));
3743   gfc_add_modify_expr (&body, count, tmp);
3744
3745   /* Build the loop.  */
3746   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3747   gfc_add_expr_to_block (&block, tmp);
3748
3749   /* Add the exit label.  */
3750   tmp = build1_v (LABEL_EXPR, exit_label);
3751   gfc_add_expr_to_block (&block, tmp);
3752
3753   /* Finish the block.  */
3754   tmp = gfc_finish_block (&block);
3755   gfc_add_expr_to_block (&se->pre, tmp);
3756
3757   /* Set the result value.  */
3758   se->expr = dest;
3759   se->string_length = dlen;
3760 }
3761
3762
3763 /* Generate code for the IARGC intrinsic.  */
3764
3765 static void
3766 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3767 {
3768   tree tmp;
3769   tree fndecl;
3770   tree type;
3771
3772   /* Call the library function.  This always returns an INTEGER(4).  */
3773   fndecl = gfor_fndecl_iargc;
3774   tmp = build_call_expr (fndecl, 0);
3775
3776   /* Convert it to the required type.  */
3777   type = gfc_typenode_for_spec (&expr->ts);
3778   tmp = fold_convert (type, tmp);
3779
3780   se->expr = tmp;
3781 }
3782
3783
3784 /* The loc intrinsic returns the address of its argument as
3785    gfc_index_integer_kind integer.  */
3786
3787 static void
3788 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3789 {
3790   tree temp_var;
3791   gfc_expr *arg_expr;
3792   gfc_ss *ss;
3793
3794   gcc_assert (!se->ss);
3795
3796   arg_expr = expr->value.function.actual->expr;
3797   ss = gfc_walk_expr (arg_expr);
3798   if (ss == gfc_ss_terminator)
3799     gfc_conv_expr_reference (se, arg_expr);
3800   else
3801     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3802   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3803
3804   /* Create a temporary variable for loc return value.  Without this,
3805      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3806   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3807   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3808   se->expr = temp_var;
3809 }
3810
3811 /* Generate code for an intrinsic function.  Some map directly to library
3812    calls, others get special handling.  In some cases the name of the function
3813    used depends on the type specifiers.  */
3814
3815 void
3816 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3817 {
3818   gfc_intrinsic_sym *isym;
3819   const char *name;
3820   int lib;
3821
3822   isym = expr->value.function.isym;
3823
3824   name = &expr->value.function.name[2];
3825
3826   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3827     {
3828       lib = gfc_is_intrinsic_libcall (expr);
3829       if (lib != 0)
3830         {
3831           if (lib == 1)
3832             se->ignore_optional = 1;
3833           gfc_conv_intrinsic_funcall (se, expr);
3834           return;
3835         }
3836     }
3837
3838   switch (expr->value.function.isym->id)
3839     {
3840     case GFC_ISYM_NONE:
3841       gcc_unreachable ();
3842
3843     case GFC_ISYM_REPEAT:
3844       gfc_conv_intrinsic_repeat (se, expr);
3845       break;
3846
3847     case GFC_ISYM_TRIM:
3848       gfc_conv_intrinsic_trim (se, expr);
3849       break;
3850
3851     case GFC_ISYM_SI_KIND:
3852       gfc_conv_intrinsic_si_kind (se, expr);
3853       break;
3854
3855     case GFC_ISYM_SR_KIND:
3856       gfc_conv_intrinsic_sr_kind (se, expr);
3857       break;
3858
3859     case GFC_ISYM_EXPONENT:
3860       gfc_conv_intrinsic_exponent (se, expr);
3861       break;
3862
3863     case GFC_ISYM_SCAN:
3864       gfc_conv_intrinsic_scan (se, expr);
3865       break;
3866
3867     case GFC_ISYM_VERIFY:
3868       gfc_conv_intrinsic_verify (se, expr);
3869       break;
3870
3871     case GFC_ISYM_ALLOCATED:
3872       gfc_conv_allocated (se, expr);
3873       break;
3874
3875     case GFC_ISYM_ASSOCIATED:
3876       gfc_conv_associated(se, expr);
3877       break;
3878
3879     case GFC_ISYM_ABS:
3880       gfc_conv_intrinsic_abs (se, expr);
3881       break;
3882
3883     case GFC_ISYM_ADJUSTL:
3884       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3885       break;
3886
3887     case GFC_ISYM_ADJUSTR:
3888       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3889       break;
3890
3891     case GFC_ISYM_AIMAG:
3892       gfc_conv_intrinsic_imagpart (se, expr);
3893       break;
3894
3895     case GFC_ISYM_AINT:
3896       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3897       break;
3898
3899     case GFC_ISYM_ALL:
3900       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3901       break;
3902
3903     case GFC_ISYM_ANINT:
3904       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3905       break;
3906
3907     case GFC_ISYM_AND:
3908       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3909       break;
3910
3911     case GFC_ISYM_ANY:
3912       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3913       break;
3914
3915     case GFC_ISYM_BTEST:
3916       gfc_conv_intrinsic_btest (se, expr);
3917       break;
3918
3919     case GFC_ISYM_ACHAR:
3920     case GFC_ISYM_CHAR:
3921       gfc_conv_intrinsic_char (se, expr);
3922       break;
3923
3924     case GFC_ISYM_CONVERSION:
3925     case GFC_ISYM_REAL:
3926     case GFC_ISYM_LOGICAL:
3927     case GFC_ISYM_DBLE:
3928       gfc_conv_intrinsic_conversion (se, expr);
3929       break;
3930
3931       /* Integer conversions are handled separately to make sure we get the
3932          correct rounding mode.  */
3933     case GFC_ISYM_INT:
3934     case GFC_ISYM_INT2:
3935     case GFC_ISYM_INT8:
3936     case GFC_ISYM_LONG:
3937       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3938       break;
3939
3940     case GFC_ISYM_NINT:
3941       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3942       break;
3943
3944     case GFC_ISYM_CEILING:
3945       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3946       break;
3947
3948     case GFC_ISYM_FLOOR:
3949       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3950       break;
3951
3952     case GFC_ISYM_MOD:
3953       gfc_conv_intrinsic_mod (se, expr, 0);
3954       break;
3955
3956     case GFC_ISYM_MODULO:
3957       gfc_conv_intrinsic_mod (se, expr, 1);
3958       break;
3959
3960     case GFC_ISYM_CMPLX:
3961       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3962       break;
3963
3964     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3965       gfc_conv_intrinsic_iargc (se, expr);
3966       break;
3967
3968     case GFC_ISYM_COMPLEX:
3969       gfc_conv_intrinsic_cmplx (se, expr, 1);
3970       break;
3971
3972     case GFC_ISYM_CONJG:
3973       gfc_conv_intrinsic_conjg (se, expr);
3974       break;
3975
3976     case GFC_ISYM_COUNT:
3977       gfc_conv_intrinsic_count (se, expr);
3978       break;
3979
3980     case GFC_ISYM_CTIME:
3981       gfc_conv_intrinsic_ctime (se, expr);
3982       break;
3983
3984     case GFC_ISYM_DIM:
3985       gfc_conv_intrinsic_dim (se, expr);
3986       break;
3987
3988     case GFC_ISYM_DOT_PRODUCT:
3989       gfc_conv_intrinsic_dot_product (se, expr);
3990       break;
3991
3992     case GFC_ISYM_DPROD:
3993       gfc_conv_intrinsic_dprod (se, expr);
3994       break;
3995
3996     case GFC_ISYM_FDATE:
3997       gfc_conv_intrinsic_fdate (se, expr);
3998       break;
3999
4000     case GFC_ISYM_IAND:
4001       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4002       break;
4003
4004     case GFC_ISYM_IBCLR:
4005       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4006       break;
4007
4008     case GFC_ISYM_IBITS:
4009       gfc_conv_intrinsic_ibits (se, expr);
4010       break;
4011
4012     case GFC_ISYM_IBSET:
4013       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4014       break;
4015
4016     case GFC_ISYM_IACHAR:
4017     case GFC_ISYM_ICHAR:
4018       /* We assume ASCII character sequence.  */
4019       gfc_conv_intrinsic_ichar (se, expr);
4020       break;
4021
4022     case GFC_ISYM_IARGC:
4023       gfc_conv_intrinsic_iargc (se, expr);
4024       break;
4025
4026     case GFC_ISYM_IEOR:
4027       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4028       break;
4029
4030     case GFC_ISYM_INDEX:
4031       gfc_conv_intrinsic_index (se, expr);
4032       break;
4033
4034     case GFC_ISYM_IOR:
4035       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4036       break;
4037
4038     case GFC_ISYM_ISNAN:
4039       gfc_conv_intrinsic_isnan (se, expr);
4040       break;
4041
4042     case GFC_ISYM_LSHIFT:
4043       gfc_conv_intrinsic_rlshift (se, expr, 0);
4044       break;
4045
4046     case GFC_ISYM_RSHIFT:
4047       gfc_conv_intrinsic_rlshift (se, expr, 1);
4048       break;
4049
4050     case GFC_ISYM_ISHFT:
4051       gfc_conv_intrinsic_ishft (se, expr);
4052       break;
4053
4054     case GFC_ISYM_ISHFTC:
4055       gfc_conv_intrinsic_ishftc (se, expr);
4056       break;
4057
4058     case GFC_ISYM_LBOUND:
4059       gfc_conv_intrinsic_bound (se, expr, 0);
4060       break;
4061
4062     case GFC_ISYM_TRANSPOSE:
4063       if (se->ss && se->ss->useflags)
4064         {
4065           gfc_conv_tmp_array_ref (se);
4066           gfc_advance_se_ss_chain (se);
4067         }
4068       else
4069         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4070       break;
4071
4072     case GFC_ISYM_LEN:
4073       gfc_conv_intrinsic_len (se, expr);
4074       break;
4075
4076     case GFC_ISYM_LEN_TRIM:
4077       gfc_conv_intrinsic_len_trim (se, expr);
4078       break;
4079
4080     case GFC_ISYM_LGE:
4081       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4082       break;
4083
4084     case GFC_ISYM_LGT:
4085       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4086       break;
4087
4088     case GFC_ISYM_LLE:
4089       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4090       break;
4091
4092     case GFC_ISYM_LLT:
4093       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4094       break;
4095
4096     case GFC_ISYM_MAX:
4097       if (expr->ts.type == BT_CHARACTER)
4098         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4099       else
4100         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4101       break;
4102
4103     case GFC_ISYM_MAXLOC:
4104       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4105       break;
4106
4107     case GFC_ISYM_MAXVAL:
4108       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4109       break;
4110
4111     case GFC_ISYM_MERGE:
4112       gfc_conv_intrinsic_merge (se, expr);
4113       break;
4114
4115     case GFC_ISYM_MIN:
4116       if (expr->ts.type == BT_CHARACTER)
4117         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4118       else
4119         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4120       break;
4121
4122     case GFC_ISYM_MINLOC:
4123       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4124       break;
4125
4126     case GFC_ISYM_MINVAL:
4127       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4128       break;
4129
4130     case GFC_ISYM_NOT:
4131       gfc_conv_intrinsic_not (se, expr);
4132       break;
4133
4134     case GFC_ISYM_OR:
4135       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4136       break;
4137
4138     case GFC_ISYM_PRESENT:
4139       gfc_conv_intrinsic_present (se, expr);
4140       break;
4141
4142     case GFC_ISYM_PRODUCT:
4143       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4144       break;
4145
4146     case GFC_ISYM_SIGN:
4147       gfc_conv_intrinsic_sign (se, expr);
4148       break;
4149
4150     case GFC_ISYM_SIZE:
4151       gfc_conv_intrinsic_size (se, expr);
4152       break;
4153
4154     case GFC_ISYM_SIZEOF:
4155       gfc_conv_intrinsic_sizeof (se, expr);
4156       break;
4157
4158     case GFC_ISYM_SUM:
4159       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4160       break;
4161
4162     case GFC_ISYM_TRANSFER:
4163       if (se->ss)
4164         {
4165           if (se->ss->useflags)
4166             {
4167               /* Access the previously obtained result.  */
4168               gfc_conv_tmp_array_ref (se);
4169               gfc_advance_se_ss_chain (se);
4170               break;
4171             }
4172           else
4173             gfc_conv_intrinsic_array_transfer (se, expr);
4174         }
4175       else
4176         gfc_conv_intrinsic_transfer (se, expr);
4177       break;
4178
4179     case GFC_ISYM_TTYNAM:
4180       gfc_conv_intrinsic_ttynam (se, expr);
4181       break;
4182
4183     case GFC_ISYM_UBOUND:
4184       gfc_conv_intrinsic_bound (se, expr, 1);
4185       break;
4186
4187     case GFC_ISYM_XOR:
4188       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4189       break;
4190
4191     case GFC_ISYM_LOC:
4192       gfc_conv_intrinsic_loc (se, expr);
4193       break;
4194
4195     case GFC_ISYM_ACCESS:
4196     case GFC_ISYM_CHDIR:
4197     case GFC_ISYM_CHMOD:
4198     case GFC_ISYM_ETIME:
4199     case GFC_ISYM_FGET:
4200     case GFC_ISYM_FGETC:
4201     case GFC_ISYM_FNUM:
4202     case GFC_ISYM_FPUT:
4203     case GFC_ISYM_FPUTC:
4204     case GFC_ISYM_FSTAT:
4205     case GFC_ISYM_FTELL:
4206     case GFC_ISYM_GETCWD:
4207     case GFC_ISYM_GETGID:
4208     case GFC_ISYM_GETPID:
4209     case GFC_ISYM_GETUID:
4210     case GFC_ISYM_HOSTNM:
4211     case GFC_ISYM_KILL:
4212     case GFC_ISYM_IERRNO:
4213     case GFC_ISYM_IRAND:
4214     case GFC_ISYM_ISATTY:
4215     case GFC_ISYM_LINK:
4216     case GFC_ISYM_LSTAT:
4217     case GFC_ISYM_MALLOC:
4218     case GFC_ISYM_MATMUL:
4219     case GFC_ISYM_MCLOCK:
4220     case GFC_ISYM_MCLOCK8:
4221     case GFC_ISYM_RAND:
4222     case GFC_ISYM_RENAME:
4223     case GFC_ISYM_SECOND:
4224     case GFC_ISYM_SECNDS:
4225     case GFC_ISYM_SIGNAL:
4226     case GFC_ISYM_STAT:
4227     case GFC_ISYM_SYMLNK:
4228     case GFC_ISYM_SYSTEM:
4229     case GFC_ISYM_TIME:
4230     case GFC_ISYM_TIME8:
4231     case GFC_ISYM_UMASK:
4232     case GFC_ISYM_UNLINK:
4233       gfc_conv_intrinsic_funcall (se, expr);
4234       break;
4235
4236     default:
4237       gfc_conv_intrinsic_lib_function (se, expr);
4238       break;
4239     }
4240 }
4241
4242
4243 /* This generates code to execute before entering the scalarization loop.
4244    Currently does nothing.  */
4245
4246 void
4247 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4248 {
4249   switch (ss->expr->value.function.isym->id)
4250     {
4251     case GFC_ISYM_UBOUND:
4252     case GFC_ISYM_LBOUND:
4253       break;
4254
4255     default:
4256       gcc_unreachable ();
4257     }
4258 }
4259
4260
4261 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4262    inside the scalarization loop.  */
4263
4264 static gfc_ss *
4265 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4266 {
4267   gfc_ss *newss;
4268
4269   /* The two argument version returns a scalar.  */
4270   if (expr->value.function.actual->next->expr)
4271     return ss;
4272
4273   newss = gfc_get_ss ();
4274   newss->type = GFC_SS_INTRINSIC;
4275   newss->expr = expr;
4276   newss->next = ss;
4277   newss->data.info.dimen = 1;
4278
4279   return newss;
4280 }
4281
4282
4283 /* Walk an intrinsic array libcall.  */
4284
4285 static gfc_ss *
4286 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4287 {
4288   gfc_ss *newss;
4289
4290   gcc_assert (expr->rank > 0);
4291
4292   newss = gfc_get_ss ();
4293   newss->type = GFC_SS_FUNCTION;
4294   newss->expr = expr;
4295   newss->next = ss;
4296   newss->data.info.dimen = expr->rank;
4297
4298   return newss;
4299 }
4300
4301
4302 /* Returns nonzero if the specified intrinsic function call maps directly to a
4303    an external library call.  Should only be used for functions that return
4304    arrays.  */
4305
4306 int
4307 gfc_is_intrinsic_libcall (gfc_expr * expr)
4308 {
4309   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4310   gcc_assert (expr->rank > 0);
4311
4312   switch (expr->value.function.isym->id)
4313     {
4314     case GFC_ISYM_ALL:
4315     case GFC_ISYM_ANY:
4316     case GFC_ISYM_COUNT:
4317     case GFC_ISYM_MATMUL:
4318     case GFC_ISYM_MAXLOC:
4319     case GFC_ISYM_MAXVAL:
4320     case GFC_ISYM_MINLOC:
4321     case GFC_ISYM_MINVAL:
4322     case GFC_ISYM_PRODUCT:
4323     case GFC_ISYM_SUM:
4324     case GFC_ISYM_SHAPE:
4325     case GFC_ISYM_SPREAD:
4326     case GFC_ISYM_TRANSPOSE:
4327       /* Ignore absent optional parameters.  */
4328       return 1;
4329
4330     case GFC_ISYM_RESHAPE:
4331     case GFC_ISYM_CSHIFT:
4332     case GFC_ISYM_EOSHIFT:
4333     case GFC_ISYM_PACK:
4334     case GFC_ISYM_UNPACK:
4335       /* Pass absent optional parameters.  */
4336       return 2;
4337
4338     default:
4339       return 0;
4340     }
4341 }
4342
4343 /* Walk an intrinsic function.  */
4344 gfc_ss *
4345 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4346                              gfc_intrinsic_sym * isym)
4347 {
4348   gcc_assert (isym);
4349
4350   if (isym->elemental)
4351     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4352
4353   if (expr->rank == 0)
4354     return ss;
4355
4356   if (gfc_is_intrinsic_libcall (expr))
4357     return gfc_walk_intrinsic_libfunc (ss, expr);
4358
4359   /* Special cases.  */
4360   switch (isym->id)
4361     {
4362     case GFC_ISYM_LBOUND:
4363     case GFC_ISYM_UBOUND:
4364       return gfc_walk_intrinsic_bound (ss, expr);
4365
4366     case GFC_ISYM_TRANSFER:
4367       return gfc_walk_intrinsic_libfunc (ss, expr);
4368
4369     default:
4370       /* This probably meant someone forgot to add an intrinsic to the above
4371          list(s) when they implemented it, or something's gone horribly wrong.
4372        */
4373       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4374                       expr->value.function.name);
4375     }
4376 }
4377
4378 #include "gt-fortran-trans-intrinsic.h"