gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics.  */
  24
  25 #include "config.h"
  26 #include "system.h"
  27 #include "coretypes.h"
  28 #include "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "tree-gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct gfc_intrinsic_map_t      GTY(())
  49 {
  50   /* The explicit enum is required to work around inadequacies in the
  51      garbage collection/gengtype parsing mechanism.  */
  52   enum gfc_isym_id id;
  53
  54   /* Enum value from the "language-independent", aka C-centric, part
  55      of gcc, or END_BUILTINS of no such value set.  */
  56   enum built_in_function code_r4;
  57   enum built_in_function code_r8;
  58   enum built_in_function code_r10;
  59   enum built_in_function code_r16;
  60   enum built_in_function code_c4;
  61   enum built_in_function code_c8;
  62   enum built_in_function code_c10;
  63   enum built_in_function code_c16;
  64
  65   /* True if the naming pattern is to prepend "c" for complex and
  66      append "f" for kind=4.  False if the naming pattern is to
  67      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  68   bool libm_name;
  69
  70   /* True if a complex version of the function exists.  */
  71   bool complex_available;
  72
  73   /* True if the function should be marked const.  */
  74   bool is_constant;
  75
  76   /* The base library name of this function.  */
  77   const char *name;
  78
  79   /* Cache decls created for the various operand types.  */
  80   tree real4_decl;
  81   tree real8_decl;
  82   tree real10_decl;
  83   tree real16_decl;
  84   tree complex4_decl;
  85   tree complex8_decl;
  86   tree complex10_decl;
  87   tree complex16_decl;
  88 }
  89 gfc_intrinsic_map_t;
  90
  91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  92    defines complex variants of all of the entries in mathbuiltins.def
  93    except for atan2.  */
  94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  95   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  96     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  97     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  99
 100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 106
 107 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 112
 113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 114   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 115     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 116     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 117     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 118
 119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 120 {
 121   /* Functions built into gcc itself.  */
 122 #include "mathbuiltins.def"
 123
 124   /* Functions in libm.  */
 125   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 126      pattern for other mathbuiltins.def entries.  At present we have no
 127      optimizations for this in the common sources.  */
 128   LIBM_FUNCTION (SCALE, "scalbn", false),
 129
 130   /* Functions in libgfortran.  */
 131   LIBF_FUNCTION (FRACTION, "fraction", false),
 132   LIBF_FUNCTION (NEAREST, "nearest", false),
 133   LIBF_FUNCTION (RRSPACING, "rrspacing", false),
 134   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 135   LIBF_FUNCTION (SPACING, "spacing", false),
 136
 137   /* End the list.  */
 138   LIBF_FUNCTION (NONE, NULL, false)
 139 };
 140 #undef DEFINE_MATH_BUILTIN
 141 #undef DEFINE_MATH_BUILTIN_C
 142 #undef LIBM_FUNCTION
 143 #undef LIBF_FUNCTION
 144
 145 /* Structure for storing components of a floating number to be used by
 146    elemental functions to manipulate reals.  */
 147 typedef struct
 148 {
 149   tree arg;     /* Variable tree to view convert to integer.  */
 150   tree expn;    /* Variable tree to save exponent.  */
 151   tree frac;    /* Variable tree to save fraction.  */
 152   tree smask;   /* Constant tree of sign's mask.  */
 153   tree emask;   /* Constant tree of exponent's mask.  */
 154   tree fmask;   /* Constant tree of fraction's mask.  */
 155   tree edigits; /* Constant tree of the number of exponent bits.  */
 156   tree fdigits; /* Constant tree of the number of fraction bits.  */
 157   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 158   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 159   tree type;    /* Type tree of arg1.  */
 160   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 161 }
 162 real_compnt_info;
 163
 164 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 165
 166 /* Evaluate the arguments to an intrinsic function.  The value
 167    of NARGS may be less than the actual number of arguments in EXPR
 168    to allow optional "KIND" arguments that are not included in the
 169    generated code to be ignored.  */
 170
 171 static void
 172 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 173                                   tree *argarray, int nargs)
 174 {
 175   gfc_actual_arglist *actual;
 176   gfc_expr *e;
 177   gfc_intrinsic_arg  *formal;
 178   gfc_se argse;
 179   int curr_arg;
 180
 181   formal = expr->value.function.isym->formal;
 182   actual = expr->value.function.actual;
 183
 184    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 185         actual = actual->next,
 186         formal = formal ? formal->next : NULL)
 187     {
 188       gcc_assert (actual);
 189       e = actual->expr;
 190       /* Skip omitted optional arguments.  */
 191       if (!e)
 192         {
 193           --curr_arg;
 194           continue;
 195         }
 196
 197       /* Evaluate the parameter.  This will substitute scalarized
 198          references automatically.  */
 199       gfc_init_se (&argse, se);
 200
 201       if (e->ts.type == BT_CHARACTER)
 202         {
 203           gfc_conv_expr (&argse, e);
 204           gfc_conv_string_parameter (&argse);
 205           argarray[curr_arg++] = argse.string_length;
 206           gcc_assert (curr_arg < nargs);
 207         }
 208       else
 209         gfc_conv_expr_val (&argse, e);
 210
 211       /* If an optional argument is itself an optional dummy argument,
 212          check its presence and substitute a null if absent.  */
 213       if (e->expr_type ==EXPR_VARIABLE
 214             && e->symtree->n.sym->attr.optional
 215             && formal
 216             && formal->optional)
 217         gfc_conv_missing_dummy (&argse, e, formal->ts);
 218
 219       gfc_add_block_to_block (&se->pre, &argse.pre);
 220       gfc_add_block_to_block (&se->post, &argse.post);
 221       argarray[curr_arg] = argse.expr;
 222     }
 223 }
 224
 225 /* Count the number of actual arguments to the intrinsic function EXPR
 226    including any "hidden" string length arguments.  */
 227
 228 static unsigned int
 229 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 230 {
 231   int n = 0;
 232   gfc_actual_arglist *actual;
 233
 234   for (actual = expr->value.function.actual; actual; actual = actual->next)
 235     {
 236       if (!actual->expr)
 237         continue;
 238
 239       if (actual->expr->ts.type == BT_CHARACTER)
 240         n += 2;
 241       else
 242         n++;
 243     }
 244
 245   return n;
 246 }
 247
 248
 249 /* Conversions between different types are output by the frontend as
 250    intrinsic functions.  We implement these directly with inline code.  */
 251
 252 static void
 253 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 254 {
 255   tree type;
 256   tree *args;
 257   int nargs;
 258
 259   nargs = gfc_intrinsic_argument_list_length (expr);
 260   args = alloca (sizeof (tree) * nargs);
 261
 262   /* Evaluate all the arguments passed. Whilst we're only interested in the
 263      first one here, there are other parts of the front-end that assume this
 264      and will trigger an ICE if it's not the case.  */
 265   type = gfc_typenode_for_spec (&expr->ts);
 266   gcc_assert (expr->value.function.actual->expr);
 267   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 268
 269   /* Conversion from complex to non-complex involves taking the real
 270      component of the value.  */
 271   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 272       && expr->ts.type != BT_COMPLEX)
 273     {
 274       tree artype;
 275
 276       artype = TREE_TYPE (TREE_TYPE (args[0]));
 277       args[0] = build1 (REALPART_EXPR, artype, args[0]);
 278     }
 279
 280   se->expr = convert (type, args[0]);
 281 }
 282
 283 /* This is needed because the gcc backend only implements
 284    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 285    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 286    Similarly for CEILING.  */
 287
 288 static tree
 289 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 290 {
 291   tree tmp;
 292   tree cond;
 293   tree argtype;
 294   tree intval;
 295
 296   argtype = TREE_TYPE (arg);
 297   arg = gfc_evaluate_now (arg, pblock);
 298
 299   intval = convert (type, arg);
 300   intval = gfc_evaluate_now (intval, pblock);
 301
 302   tmp = convert (argtype, intval);
 303   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 304
 305   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 306                 build_int_cst (type, 1));
 307   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 308   return tmp;
 309 }
 310
 311
 312 /* Round to nearest integer, away from zero.  */
 313
 314 static tree
 315 build_round_expr (tree arg, tree restype)
 316 {
 317   tree tmp;
 318   tree argtype;
 319   tree fn;
 320   bool longlong, convert;
 321   int argprec, resprec;
 322
 323   argtype = TREE_TYPE (arg);
 324   argprec = TYPE_PRECISION (argtype);
 325   resprec = TYPE_PRECISION (restype);
 326
 327   /* Depending on the type of the result, choose the long int intrinsic
 328      (lround family) or long long intrinsic (llround).  We might also
 329      need to convert the result afterwards.  */
 330   if (resprec <= LONG_TYPE_SIZE)
 331     {
 332       longlong = false;
 333       if (resprec != LONG_TYPE_SIZE)
 334         convert = true;
 335       else
 336         convert = false;
 337     }
 338   else if (resprec <= LONG_LONG_TYPE_SIZE)
 339     {
 340       longlong = true;
 341       if (resprec != LONG_LONG_TYPE_SIZE)
 342         convert = true;
 343       else
 344         convert = false;
 345     }
 346   else
 347     gcc_unreachable ();
 348
 349   /* Now, depending on the argument type, we choose between intrinsics.  */
 350   if (argprec == TYPE_PRECISION (float_type_node))
 351     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
 352   else if (argprec == TYPE_PRECISION (double_type_node))
 353     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
 354   else if (argprec == TYPE_PRECISION (long_double_type_node))
 355     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
 356   else
 357     gcc_unreachable ();
 358
 359   tmp = build_call_expr (fn, 1, arg);
 360   if (convert)
 361     tmp = fold_convert (restype, tmp);
 362   return tmp;
 363 }
 364
 365
 366 /* Convert a real to an integer using a specific rounding mode.
 367    Ideally we would just build the corresponding GENERIC node,
 368    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 369
 370 static tree
 371 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 372                enum rounding_mode op)
 373 {
 374   switch (op)
 375     {
 376     case RND_FLOOR:
 377       return build_fixbound_expr (pblock, arg, type, 0);
 378       break;
 379
 380     case RND_CEIL:
 381       return build_fixbound_expr (pblock, arg, type, 1);
 382       break;
 383
 384     case RND_ROUND:
 385       return build_round_expr (arg, type);
 386       break;
 387
 388     case RND_TRUNC:
 389       return build1 (FIX_TRUNC_EXPR, type, arg);
 390       break;
 391
 392     default:
 393       gcc_unreachable ();
 394     }
 395 }
 396
 397
 398 /* Round a real value using the specified rounding mode.
 399    We use a temporary integer of that same kind size as the result.
 400    Values larger than those that can be represented by this kind are
 401    unchanged, as they will not be accurate enough to represent the
 402    rounding.
 403     huge = HUGE (KIND (a))
 404     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 405    */
 406
 407 static void
 408 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 409 {
 410   tree type;
 411   tree itype;
 412   tree arg;
 413   tree tmp;
 414   tree cond;
 415   mpfr_t huge;
 416   int n;
 417   int kind;
 418
 419   kind = expr->ts.kind;
 420
 421   n = END_BUILTINS;
 422   /* We have builtin functions for some cases.  */
 423   switch (op)
 424     {
 425     case RND_ROUND:
 426       switch (kind)
 427         {
 428         case 4:
 429           n = BUILT_IN_ROUNDF;
 430           break;
 431
 432         case 8:
 433           n = BUILT_IN_ROUND;
 434           break;
 435
 436         case 10:
 437         case 16:
 438           n = BUILT_IN_ROUNDL;
 439           break;
 440         }
 441       break;
 442
 443     case RND_TRUNC:
 444       switch (kind)
 445         {
 446         case 4:
 447           n = BUILT_IN_TRUNCF;
 448           break;
 449
 450         case 8:
 451           n = BUILT_IN_TRUNC;
 452           break;
 453
 454         case 10:
 455         case 16:
 456           n = BUILT_IN_TRUNCL;
 457           break;
 458         }
 459       break;
 460
 461     default:
 462       gcc_unreachable ();
 463     }
 464
 465   /* Evaluate the argument.  */
 466   gcc_assert (expr->value.function.actual->expr);
 467   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 468
 469   /* Use a builtin function if one exists.  */
 470   if (n != END_BUILTINS)
 471     {
 472       tmp = built_in_decls[n];
 473       se->expr = build_call_expr (tmp, 1, arg);
 474       return;
 475     }
 476
 477   /* This code is probably redundant, but we'll keep it lying around just
 478      in case.  */
 479   type = gfc_typenode_for_spec (&expr->ts);
 480   arg = gfc_evaluate_now (arg, &se->pre);
 481
 482   /* Test if the value is too large to handle sensibly.  */
 483   gfc_set_model_kind (kind);
 484   mpfr_init (huge);
 485   n = gfc_validate_kind (BT_INTEGER, kind, false);
 486   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 487   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 488   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
 489
 490   mpfr_neg (huge, huge, GFC_RND_MODE);
 491   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 492   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
 493   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 494   itype = gfc_get_int_type (kind);
 495
 496   tmp = build_fix_expr (&se->pre, arg, itype, op);
 497   tmp = convert (type, tmp);
 498   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
 499   mpfr_clear (huge);
 500 }
 501
 502
 503 /* Convert to an integer using the specified rounding mode.  */
 504
 505 static void
 506 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 507 {
 508   tree type;
 509   tree *args;
 510   int nargs;
 511
 512   nargs = gfc_intrinsic_argument_list_length (expr);
 513   args = alloca (sizeof (tree) * nargs);
 514
 515   /* Evaluate the argument, we process all arguments even though we only
 516      use the first one for code generation purposes.  */
 517   type = gfc_typenode_for_spec (&expr->ts);
 518   gcc_assert (expr->value.function.actual->expr);
 519   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 520
 521   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 522     {
 523       /* Conversion to a different integer kind.  */
 524       se->expr = convert (type, args[0]);
 525     }
 526   else
 527     {
 528       /* Conversion from complex to non-complex involves taking the real
 529          component of the value.  */
 530       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 531           && expr->ts.type != BT_COMPLEX)
 532         {
 533           tree artype;
 534
 535           artype = TREE_TYPE (TREE_TYPE (args[0]));
 536           args[0] = build1 (REALPART_EXPR, artype, args[0]);
 537         }
 538
 539       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 540     }
 541 }
 542
 543
 544 /* Get the imaginary component of a value.  */
 545
 546 static void
 547 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 548 {
 549   tree arg;
 550
 551   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 552   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 553 }
 554
 555
 556 /* Get the complex conjugate of a value.  */
 557
 558 static void
 559 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 560 {
 561   tree arg;
 562
 563   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 564   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 565 }
 566
 567
 568 /* Initialize function decls for library functions.  The external functions
 569    are created as required.  Builtin functions are added here.  */
 570
 571 void
 572 gfc_build_intrinsic_lib_fndecls (void)
 573 {
 574   gfc_intrinsic_map_t *m;
 575
 576   /* Add GCC builtin functions.  */
 577   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 578     {
 579       if (m->code_r4 != END_BUILTINS)
 580         m->real4_decl = built_in_decls[m->code_r4];
 581       if (m->code_r8 != END_BUILTINS)
 582         m->real8_decl = built_in_decls[m->code_r8];
 583       if (m->code_r10 != END_BUILTINS)
 584         m->real10_decl = built_in_decls[m->code_r10];
 585       if (m->code_r16 != END_BUILTINS)
 586         m->real16_decl = built_in_decls[m->code_r16];
 587       if (m->code_c4 != END_BUILTINS)
 588         m->complex4_decl = built_in_decls[m->code_c4];
 589       if (m->code_c8 != END_BUILTINS)
 590         m->complex8_decl = built_in_decls[m->code_c8];
 591       if (m->code_c10 != END_BUILTINS)
 592         m->complex10_decl = built_in_decls[m->code_c10];
 593       if (m->code_c16 != END_BUILTINS)
 594         m->complex16_decl = built_in_decls[m->code_c16];
 595     }
 596 }
 597
 598
 599 /* Create a fndecl for a simple intrinsic library function.  */
 600
 601 static tree
 602 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 603 {
 604   tree type;
 605   tree argtypes;
 606   tree fndecl;
 607   gfc_actual_arglist *actual;
 608   tree *pdecl;
 609   gfc_typespec *ts;
 610   char name[GFC_MAX_SYMBOL_LEN + 3];
 611
 612   ts = &expr->ts;
 613   if (ts->type == BT_REAL)
 614     {
 615       switch (ts->kind)
 616         {
 617         case 4:
 618           pdecl = &m->real4_decl;
 619           break;
 620         case 8:
 621           pdecl = &m->real8_decl;
 622           break;
 623         case 10:
 624           pdecl = &m->real10_decl;
 625           break;
 626         case 16:
 627           pdecl = &m->real16_decl;
 628           break;
 629         default:
 630           gcc_unreachable ();
 631         }
 632     }
 633   else if (ts->type == BT_COMPLEX)
 634     {
 635       gcc_assert (m->complex_available);
 636
 637       switch (ts->kind)
 638         {
 639         case 4:
 640           pdecl = &m->complex4_decl;
 641           break;
 642         case 8:
 643           pdecl = &m->complex8_decl;
 644           break;
 645         case 10:
 646           pdecl = &m->complex10_decl;
 647           break;
 648         case 16:
 649           pdecl = &m->complex16_decl;
 650           break;
 651         default:
 652           gcc_unreachable ();
 653         }
 654     }
 655   else
 656     gcc_unreachable ();
 657
 658   if (*pdecl)
 659     return *pdecl;
 660
 661   if (m->libm_name)
 662     {
 663       if (ts->kind == 4)
 664         snprintf (name, sizeof (name), "%s%s%s",
 665                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 666       else if (ts->kind == 8)
 667         snprintf (name, sizeof (name), "%s%s",
 668                 ts->type == BT_COMPLEX ? "c" : "", m->name);
 669       else
 670         {
 671           gcc_assert (ts->kind == 10 || ts->kind == 16);
 672           snprintf (name, sizeof (name), "%s%s%s",
 673                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 674         }
 675     }
 676   else
 677     {
 678       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 679                 ts->type == BT_COMPLEX ? 'c' : 'r',
 680                 ts->kind);
 681     }
 682
 683   argtypes = NULL_TREE;
 684   for (actual = expr->value.function.actual; actual; actual = actual->next)
 685     {
 686       type = gfc_typenode_for_spec (&actual->expr->ts);
 687       argtypes = gfc_chainon_list (argtypes, type);
 688     }
 689   argtypes = gfc_chainon_list (argtypes, void_type_node);
 690   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 691   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 692
 693   /* Mark the decl as external.  */
 694   DECL_EXTERNAL (fndecl) = 1;
 695   TREE_PUBLIC (fndecl) = 1;
 696
 697   /* Mark it __attribute__((const)), if possible.  */
 698   TREE_READONLY (fndecl) = m->is_constant;
 699
 700   rest_of_decl_compilation (fndecl, 1, 0);
 701
 702   (*pdecl) = fndecl;
 703   return fndecl;
 704 }
 705
 706
 707 /* Convert an intrinsic function into an external or builtin call.  */
 708
 709 static void
 710 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 711 {
 712   gfc_intrinsic_map_t *m;
 713   tree fndecl;
 714   tree rettype;
 715   tree *args;
 716   unsigned int num_args;
 717   gfc_isym_id id;
 718
 719   id = expr->value.function.isym->id;
 720   /* Find the entry for this function.  */
 721   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 722     {
 723       if (id == m->id)
 724         break;
 725     }
 726
 727   if (m->id == GFC_ISYM_NONE)
 728     {
 729       internal_error ("Intrinsic function %s(%d) not recognized",
 730                       expr->value.function.name, id);
 731     }
 732
 733   /* Get the decl and generate the call.  */
 734   num_args = gfc_intrinsic_argument_list_length (expr);
 735   args = alloca (sizeof (tree) * num_args);
 736
 737   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 738   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 739   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 740
 741   fndecl = build_addr (fndecl, current_function_decl);
 742   se->expr = build_call_array (rettype, fndecl, num_args, args);
 743 }
 744
 745 /* Generate code for EXPONENT(X) intrinsic function.  */
 746
 747 static void
 748 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 749 {
 750   tree arg, fndecl, type;
 751   gfc_expr *a1;
 752
 753   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 754
 755   a1 = expr->value.function.actual->expr;
 756   switch (a1->ts.kind)
 757     {
 758     case 4:
 759       fndecl = gfor_fndecl_math_exponent4;
 760       break;
 761     case 8:
 762       fndecl = gfor_fndecl_math_exponent8;
 763       break;
 764     case 10:
 765       fndecl = gfor_fndecl_math_exponent10;
 766       break;
 767     case 16:
 768       fndecl = gfor_fndecl_math_exponent16;
 769       break;
 770     default:
 771       gcc_unreachable ();
 772     }
 773
 774   /* Convert it to the required type.  */
 775   type = gfc_typenode_for_spec (&expr->ts);
 776   se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
 777 }
 778
 779 /* Evaluate a single upper or lower bound.  */
 780 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 781
 782 static void
 783 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 784 {
 785   gfc_actual_arglist *arg;
 786   gfc_actual_arglist *arg2;
 787   tree desc;
 788   tree type;
 789   tree bound;
 790   tree tmp;
 791   tree cond, cond1, cond2, cond3, cond4, size;
 792   tree ubound;
 793   tree lbound;
 794   gfc_se argse;
 795   gfc_ss *ss;
 796   gfc_array_spec * as;
 797   gfc_ref *ref;
 798
 799   arg = expr->value.function.actual;
 800   arg2 = arg->next;
 801
 802   if (se->ss)
 803     {
 804       /* Create an implicit second parameter from the loop variable.  */
 805       gcc_assert (!arg2->expr);
 806       gcc_assert (se->loop->dimen == 1);
 807       gcc_assert (se->ss->expr == expr);
 808       gfc_advance_se_ss_chain (se);
 809       bound = se->loop->loopvar[0];
 810       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 811                            se->loop->from[0]);
 812     }
 813   else
 814     {
 815       /* use the passed argument.  */
 816       gcc_assert (arg->next->expr);
 817       gfc_init_se (&argse, NULL);
 818       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 819       gfc_add_block_to_block (&se->pre, &argse.pre);
 820       bound = argse.expr;
 821       /* Convert from one based to zero based.  */
 822       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 823                            gfc_index_one_node);
 824     }
 825
 826   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 827   /* Get a descriptor for the first parameter.  */
 828   ss = gfc_walk_expr (arg->expr);
 829   gcc_assert (ss != gfc_ss_terminator);
 830   gfc_init_se (&argse, NULL);
 831   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 832   gfc_add_block_to_block (&se->pre, &argse.pre);
 833   gfc_add_block_to_block (&se->post, &argse.post);
 834
 835   desc = argse.expr;
 836
 837   if (INTEGER_CST_P (bound))
 838     {
 839       int hi, low;
 840
 841       hi = TREE_INT_CST_HIGH (bound);
 842       low = TREE_INT_CST_LOW (bound);
 843       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 844         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 845                    "dimension index", upper ? "UBOUND" : "LBOUND",
 846                    &expr->where);
 847     }
 848   else
 849     {
 850       if (flag_bounds_check)
 851         {
 852           bound = gfc_evaluate_now (bound, &se->pre);
 853           cond = fold_build2 (LT_EXPR, boolean_type_node,
 854                               bound, build_int_cst (TREE_TYPE (bound), 0));
 855           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 856           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 857           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 858           gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);
 859         }
 860     }
 861
 862   ubound = gfc_conv_descriptor_ubound (desc, bound);
 863   lbound = gfc_conv_descriptor_lbound (desc, bound);
 864
 865   /* Follow any component references.  */
 866   if (arg->expr->expr_type == EXPR_VARIABLE
 867       || arg->expr->expr_type == EXPR_CONSTANT)
 868     {
 869       as = arg->expr->symtree->n.sym->as;
 870       for (ref = arg->expr->ref; ref; ref = ref->next)
 871         {
 872           switch (ref->type)
 873             {
 874             case REF_COMPONENT:
 875               as = ref->u.c.component->as;
 876               continue;
 877
 878             case REF_SUBSTRING:
 879               continue;
 880
 881             case REF_ARRAY:
 882               {
 883                 switch (ref->u.ar.type)
 884                   {
 885                   case AR_ELEMENT:
 886                   case AR_SECTION:
 887                   case AR_UNKNOWN:
 888                     as = NULL;
 889                     continue;
 890
 891                   case AR_FULL:
 892                     break;
 893                   }
 894               }
 895             }
 896         }
 897     }
 898   else
 899     as = NULL;
 900
 901   /* 13.14.53: Result value for LBOUND
 902
 903      Case (i): For an array section or for an array expression other than a
 904                whole array or array structure component, LBOUND(ARRAY, DIM)
 905                has the value 1.  For a whole array or array structure
 906                component, LBOUND(ARRAY, DIM) has the value:
 907                  (a) equal to the lower bound for subscript DIM of ARRAY if
 908                      dimension DIM of ARRAY does not have extent zero
 909                      or if ARRAY is an assumed-size array of rank DIM,
 910               or (b) 1 otherwise.
 911
 912      13.14.113: Result value for UBOUND
 913
 914      Case (i): For an array section or for an array expression other than a
 915                whole array or array structure component, UBOUND(ARRAY, DIM)
 916                has the value equal to the number of elements in the given
 917                dimension; otherwise, it has a value equal to the upper bound
 918                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 919                not have size zero and has value zero if dimension DIM has
 920                size zero.  */
 921
 922   if (as)
 923     {
 924       tree stride = gfc_conv_descriptor_stride (desc, bound);
 925
 926       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 927       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 928
 929       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 930                            gfc_index_zero_node);
 931       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 932
 933       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 934                            gfc_index_zero_node);
 935       cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
 936
 937       if (upper)
 938         {
 939           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 940
 941           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 942                                   ubound, gfc_index_zero_node);
 943         }
 944       else
 945         {
 946           if (as->type == AS_ASSUMED_SIZE)
 947             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 948                                 build_int_cst (TREE_TYPE (bound),
 949                                                arg->expr->rank - 1));
 950           else
 951             cond = boolean_false_node;
 952
 953           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 954           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
 955
 956           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 957                                   lbound, gfc_index_one_node);
 958         }
 959     }
 960   else
 961     {
 962       if (upper)
 963         {
 964           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
 965           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
 966                                   gfc_index_one_node);
 967         }
 968       else
 969         se->expr = gfc_index_one_node;
 970     }
 971
 972   type = gfc_typenode_for_spec (&expr->ts);
 973   se->expr = convert (type, se->expr);
 974 }
 975
 976
 977 static void
 978 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 979 {
 980   tree arg;
 981   int n;
 982
 983   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 984
 985   switch (expr->value.function.actual->expr->ts.type)
 986     {
 987     case BT_INTEGER:
 988     case BT_REAL:
 989       se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
 990       break;
 991
 992     case BT_COMPLEX:
 993       switch (expr->ts.kind)
 994         {
 995         case 4:
 996           n = BUILT_IN_CABSF;
 997           break;
 998         case 8:
 999           n = BUILT_IN_CABS;
1000           break;
1001         case 10:
1002         case 16:
1003           n = BUILT_IN_CABSL;
1004           break;
1005         default:
1006           gcc_unreachable ();
1007         }
1008       se->expr = build_call_expr (built_in_decls[n], 1, arg);
1009       break;
1010
1011     default:
1012       gcc_unreachable ();
1013     }
1014 }
1015
1016
1017 /* Create a complex value from one or two real components.  */
1018
1019 static void
1020 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1021 {
1022   tree real;
1023   tree imag;
1024   tree type;
1025   tree *args;
1026   unsigned int num_args;
1027
1028   num_args = gfc_intrinsic_argument_list_length (expr);
1029   args = alloca (sizeof (tree) * num_args);
1030
1031   type = gfc_typenode_for_spec (&expr->ts);
1032   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1033   real = convert (TREE_TYPE (type), args[0]);
1034   if (both)
1035     imag = convert (TREE_TYPE (type), args[1]);
1036   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1037     {
1038       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1039       imag = convert (TREE_TYPE (type), imag);
1040     }
1041   else
1042     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1043
1044   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1045 }
1046
1047 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1048                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1049 /* TODO: MOD(x, 0)  */
1050
1051 static void
1052 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1053 {
1054   tree type;
1055   tree itype;
1056   tree tmp;
1057   tree test;
1058   tree test2;
1059   mpfr_t huge;
1060   int n, ikind;
1061   tree args[2];
1062
1063   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1064
1065   switch (expr->ts.type)
1066     {
1067     case BT_INTEGER:
1068       /* Integer case is easy, we've got a builtin op.  */
1069       type = TREE_TYPE (args[0]);
1070
1071       if (modulo)
1072        se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1073       else
1074        se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1075       break;
1076
1077     case BT_REAL:
1078       n = END_BUILTINS;
1079       /* Check if we have a builtin fmod.  */
1080       switch (expr->ts.kind)
1081         {
1082         case 4:
1083           n = BUILT_IN_FMODF;
1084           break;
1085
1086         case 8:
1087           n = BUILT_IN_FMOD;
1088           break;
1089
1090         case 10:
1091         case 16:
1092           n = BUILT_IN_FMODL;
1093           break;
1094
1095         default:
1096           break;
1097         }
1098
1099       /* Use it if it exists.  */
1100       if (n != END_BUILTINS)
1101         {
1102           tmp = build_addr (built_in_decls[n], current_function_decl);
1103           se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1104                                        tmp, 2, args);
1105           if (modulo == 0)
1106             return;
1107         }
1108
1109       type = TREE_TYPE (args[0]);
1110
1111       args[0] = gfc_evaluate_now (args[0], &se->pre);
1112       args[1] = gfc_evaluate_now (args[1], &se->pre);
1113
1114       /* Definition:
1115          modulo = arg - floor (arg/arg2) * arg2, so
1116                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1117          where
1118           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1119          thereby avoiding another division and retaining the accuracy
1120          of the builtin function.  */
1121       if (n != END_BUILTINS && modulo)
1122         {
1123           tree zero = gfc_build_const (type, integer_zero_node);
1124           tmp = gfc_evaluate_now (se->expr, &se->pre);
1125           test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
1126           test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
1127           test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1128           test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
1129           test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1130           test = gfc_evaluate_now (test, &se->pre);
1131           se->expr = build3 (COND_EXPR, type, test,
1132                              build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
1133           return;
1134         }
1135
1136       /* If we do not have a built_in fmod, the calculation is going to
1137          have to be done longhand.  */
1138       tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
1139
1140       /* Test if the value is too large to handle sensibly.  */
1141       gfc_set_model_kind (expr->ts.kind);
1142       mpfr_init (huge);
1143       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1144       ikind = expr->ts.kind;
1145       if (n < 0)
1146         {
1147           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1148           ikind = gfc_max_integer_kind;
1149         }
1150       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1151       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1152       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1153
1154       mpfr_neg (huge, huge, GFC_RND_MODE);
1155       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1156       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1157       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1158
1159       itype = gfc_get_int_type (ikind);
1160       if (modulo)
1161        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1162       else
1163        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1164       tmp = convert (type, tmp);
1165       tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
1166       tmp = build2 (MULT_EXPR, type, tmp, args[1]);
1167       se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
1168       mpfr_clear (huge);
1169       break;
1170
1171     default:
1172       gcc_unreachable ();
1173     }
1174 }
1175
1176 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1177
1178 static void
1179 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1180 {
1181   tree val;
1182   tree tmp;
1183   tree type;
1184   tree zero;
1185   tree args[2];
1186
1187   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1188   type = TREE_TYPE (args[0]);
1189
1190   val = build2 (MINUS_EXPR, type, args[0], args[1]);
1191   val = gfc_evaluate_now (val, &se->pre);
1192
1193   zero = gfc_build_const (type, integer_zero_node);
1194   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1195   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1196 }
1197
1198
1199 /* SIGN(A, B) is absolute value of A times sign of B.
1200    The real value versions use library functions to ensure the correct
1201    handling of negative zero.  Integer case implemented as:
1202    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1203   */
1204
1205 static void
1206 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1207 {
1208   tree tmp;
1209   tree type;
1210   tree args[2];
1211
1212   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1213   if (expr->ts.type == BT_REAL)
1214     {
1215       switch (expr->ts.kind)
1216         {
1217         case 4:
1218           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1219           break;
1220         case 8:
1221           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1222           break;
1223         case 10:
1224         case 16:
1225           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1226           break;
1227         default:
1228           gcc_unreachable ();
1229         }
1230       se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1231       return;
1232     }
1233
1234   /* Having excluded floating point types, we know we are now dealing
1235      with signed integer types.  */
1236   type = TREE_TYPE (args[0]);
1237
1238   /* Args[0] is used multiple times below.  */
1239   args[0] = gfc_evaluate_now (args[0], &se->pre);
1240
1241   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1242      the signs of A and B are the same, and of all ones if they differ.  */
1243   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1244   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1245                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1246   tmp = gfc_evaluate_now (tmp, &se->pre);
1247
1248   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1249      is all ones (i.e. -1).  */
1250   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1251                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1252                           tmp);
1253 }
1254
1255
1256 /* Test for the presence of an optional argument.  */
1257
1258 static void
1259 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1260 {
1261   gfc_expr *arg;
1262
1263   arg = expr->value.function.actual->expr;
1264   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1265   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1266   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1267 }
1268
1269
1270 /* Calculate the double precision product of two single precision values.  */
1271
1272 static void
1273 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1274 {
1275   tree type;
1276   tree args[2];
1277
1278   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1279
1280   /* Convert the args to double precision before multiplying.  */
1281   type = gfc_typenode_for_spec (&expr->ts);
1282   args[0] = convert (type, args[0]);
1283   args[1] = convert (type, args[1]);
1284   se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
1285 }
1286
1287
1288 /* Return a length one character string containing an ascii character.  */
1289
1290 static void
1291 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1292 {
1293   tree arg;
1294   tree var;
1295   tree type;
1296
1297   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1298
1299   /* We currently don't support character types != 1.  */
1300   gcc_assert (expr->ts.kind == 1);
1301   type = gfc_character1_type_node;
1302   var = gfc_create_var (type, "char");
1303
1304   arg = convert (type, arg);
1305   gfc_add_modify_expr (&se->pre, var, arg);
1306   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1307   se->string_length = integer_one_node;
1308 }
1309
1310
1311 static void
1312 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1313 {
1314   tree var;
1315   tree len;
1316   tree tmp;
1317   tree type;
1318   tree cond;
1319   tree gfc_int8_type_node = gfc_get_int_type (8);
1320   tree fndecl;
1321   tree *args;
1322   unsigned int num_args;
1323
1324   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1325   args = alloca (sizeof (tree) * num_args);
1326
1327   type = build_pointer_type (gfc_character1_type_node);
1328   var = gfc_create_var (type, "pstr");
1329   len = gfc_create_var (gfc_int8_type_node, "len");
1330
1331   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1332   args[0] = build_fold_addr_expr (var);
1333   args[1] = build_fold_addr_expr (len);
1334
1335   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1336   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1337                           fndecl, num_args, args);
1338   gfc_add_expr_to_block (&se->pre, tmp);
1339
1340   /* Free the temporary afterwards, if necessary.  */
1341   cond = build2 (GT_EXPR, boolean_type_node, len,
1342                  build_int_cst (TREE_TYPE (len), 0));
1343   tmp = gfc_call_free (var);
1344   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1345   gfc_add_expr_to_block (&se->post, tmp);
1346
1347   se->expr = var;
1348   se->string_length = len;
1349 }
1350
1351
1352 static void
1353 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1354 {
1355   tree var;
1356   tree len;
1357   tree tmp;
1358   tree type;
1359   tree cond;
1360   tree gfc_int4_type_node = gfc_get_int_type (4);
1361   tree fndecl;
1362   tree *args;
1363   unsigned int num_args;
1364
1365   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1366   args = alloca (sizeof (tree) * num_args);
1367
1368   type = build_pointer_type (gfc_character1_type_node);
1369   var = gfc_create_var (type, "pstr");
1370   len = gfc_create_var (gfc_int4_type_node, "len");
1371
1372   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1373   args[0] = build_fold_addr_expr (var);
1374   args[1] = build_fold_addr_expr (len);
1375
1376   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1377   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1378                           fndecl, num_args, args);
1379   gfc_add_expr_to_block (&se->pre, tmp);
1380
1381   /* Free the temporary afterwards, if necessary.  */
1382   cond = build2 (GT_EXPR, boolean_type_node, len,
1383                  build_int_cst (TREE_TYPE (len), 0));
1384   tmp = gfc_call_free (var);
1385   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1386   gfc_add_expr_to_block (&se->post, tmp);
1387
1388   se->expr = var;
1389   se->string_length = len;
1390 }
1391
1392
1393 /* Return a character string containing the tty name.  */
1394
1395 static void
1396 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1397 {
1398   tree var;
1399   tree len;
1400   tree tmp;
1401   tree type;
1402   tree cond;
1403   tree fndecl;
1404   tree gfc_int4_type_node = gfc_get_int_type (4);
1405   tree *args;
1406   unsigned int num_args;
1407
1408   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1409   args = alloca (sizeof (tree) * num_args);
1410
1411   type = build_pointer_type (gfc_character1_type_node);
1412   var = gfc_create_var (type, "pstr");
1413   len = gfc_create_var (gfc_int4_type_node, "len");
1414
1415   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416   args[0] = build_fold_addr_expr (var);
1417   args[1] = build_fold_addr_expr (len);
1418
1419   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1420   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1421                           fndecl, num_args, args);
1422   gfc_add_expr_to_block (&se->pre, tmp);
1423
1424   /* Free the temporary afterwards, if necessary.  */
1425   cond = build2 (GT_EXPR, boolean_type_node, len,
1426                  build_int_cst (TREE_TYPE (len), 0));
1427   tmp = gfc_call_free (var);
1428   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429   gfc_add_expr_to_block (&se->post, tmp);
1430
1431   se->expr = var;
1432   se->string_length = len;
1433 }
1434
1435
1436 /* Get the minimum/maximum value of all the parameters.
1437     minmax (a1, a2, a3, ...)
1438     {
1439       if (a2 .op. a1 || isnan(a1))
1440         mvar = a2;
1441       else
1442         mvar = a1;
1443       if (a3 .op. mvar || isnan(mvar))
1444         mvar = a3;
1445       ...
1446       return mvar
1447     }
1448  */
1449
1450 /* TODO: Mismatching types can occur when specific names are used.
1451    These should be handled during resolution.  */
1452 static void
1453 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1454 {
1455   tree limit;
1456   tree tmp;
1457   tree mvar;
1458   tree val;
1459   tree thencase;
1460   tree elsecase;
1461   tree *args;
1462   tree type;
1463   gfc_actual_arglist *argexpr;
1464   unsigned int i;
1465   unsigned int nargs;
1466
1467   nargs = gfc_intrinsic_argument_list_length (expr);
1468   args = alloca (sizeof (tree) * nargs);
1469
1470   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1471   type = gfc_typenode_for_spec (&expr->ts);
1472
1473   /* The first and second arguments should be present, if they are
1474      optional dummy arguments.  */
1475   argexpr = expr->value.function.actual;
1476   if (argexpr->expr->expr_type == EXPR_VARIABLE
1477       && argexpr->expr->symtree->n.sym->attr.optional
1478       && TREE_CODE (args[0]) == INDIRECT_REF)
1479     {
1480       /* Check the first argument.  */
1481       tree cond;
1482       char *msg;
1483
1484       asprintf (&msg, "First argument of '%s' intrinsic should be present",
1485                 expr->symtree->n.sym->name);
1486       cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
1487                      build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
1488       gfc_trans_runtime_check (cond, &se->pre, &expr->where, msg);
1489       gfc_free (msg);
1490     }
1491
1492   if (argexpr->next->expr->expr_type == EXPR_VARIABLE
1493       && argexpr->next->expr->symtree->n.sym->attr.optional
1494       && TREE_CODE (args[1]) == INDIRECT_REF)
1495     {
1496       /* Check the second argument.  */
1497       tree cond;
1498       char *msg;
1499
1500       asprintf (&msg, "Second argument of '%s' intrinsic should be present",
1501                 expr->symtree->n.sym->name);
1502       cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
1503                      build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
1504       gfc_trans_runtime_check (cond, &se->pre, &expr->where, msg);
1505       gfc_free (msg);
1506     }
1507
1508   limit = args[0];
1509   if (TREE_TYPE (limit) != type)
1510     limit = convert (type, limit);
1511   /* Only evaluate the argument once.  */
1512   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1513     limit = gfc_evaluate_now (limit, &se->pre);
1514
1515   mvar = gfc_create_var (type, "M");
1516   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1517   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1518     {
1519       tree cond, isnan;
1520
1521       val = args[i];
1522
1523       /* Handle absent optional arguments by ignoring the comparison.  */
1524       if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
1525           && argexpr->expr->symtree->n.sym->attr.optional
1526           && TREE_CODE (val) == INDIRECT_REF)
1527         cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1528                        build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1529       else
1530       {
1531         cond = NULL_TREE;
1532
1533         /* Only evaluate the argument once.  */
1534         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1535           val = gfc_evaluate_now (val, &se->pre);
1536       }
1537
1538       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1539
1540       tmp = build2 (op, boolean_type_node, convert (type, val), limit);
1541
1542       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1543          __builtin_isnan might be made dependent on that module being loaded,
1544          to help performance of programs that don't rely on IEEE semantics.  */
1545       if (FLOAT_TYPE_P (TREE_TYPE (limit)))
1546         {
1547           isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
1548           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1549                              fold_convert (boolean_type_node, isnan));
1550         }
1551       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1552
1553       if (cond != NULL_TREE)
1554         tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1555
1556       gfc_add_expr_to_block (&se->pre, tmp);
1557       elsecase = build_empty_stmt ();
1558       limit = mvar;
1559       argexpr = argexpr->next;
1560     }
1561   se->expr = mvar;
1562 }
1563
1564
1565 /* Generate library calls for MIN and MAX intrinsics for character
1566    variables.  */
1567 static void
1568 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1569 {
1570   tree *args;
1571   tree var, len, fndecl, tmp, cond;
1572   unsigned int nargs;
1573
1574   nargs = gfc_intrinsic_argument_list_length (expr);
1575   args = alloca (sizeof (tree) * (nargs + 4));
1576   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1577
1578   /* Create the result variables.  */
1579   len = gfc_create_var (gfc_charlen_type_node, "len");
1580   args[0] = build_fold_addr_expr (len);
1581   var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
1582   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1583   args[2] = build_int_cst (NULL_TREE, op);
1584   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1585
1586   /* Make the function call.  */
1587   fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
1588   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
1589                           fndecl, nargs + 4, args);
1590   gfc_add_expr_to_block (&se->pre, tmp);
1591
1592   /* Free the temporary afterwards, if necessary.  */
1593   cond = build2 (GT_EXPR, boolean_type_node, len,
1594                  build_int_cst (TREE_TYPE (len), 0));
1595   tmp = gfc_call_free (var);
1596   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1597   gfc_add_expr_to_block (&se->post, tmp);
1598
1599   se->expr = var;
1600   se->string_length = len;
1601 }
1602
1603
1604 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1605    has the generic name.  */
1606
1607 static gfc_symbol *
1608 gfc_get_symbol_for_expr (gfc_expr * expr)
1609 {
1610   gfc_symbol *sym;
1611
1612   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1613   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1614   sym = gfc_new_symbol (expr->value.function.name, NULL);
1615
1616   sym->ts = expr->ts;
1617   sym->attr.external = 1;
1618   sym->attr.function = 1;
1619   sym->attr.always_explicit = 1;
1620   sym->attr.proc = PROC_INTRINSIC;
1621   sym->attr.flavor = FL_PROCEDURE;
1622   sym->result = sym;
1623   if (expr->rank > 0)
1624     {
1625       sym->attr.dimension = 1;
1626       sym->as = gfc_get_array_spec ();
1627       sym->as->type = AS_ASSUMED_SHAPE;
1628       sym->as->rank = expr->rank;
1629     }
1630
1631   /* TODO: proper argument lists for external intrinsics.  */
1632   return sym;
1633 }
1634
1635 /* Generate a call to an external intrinsic function.  */
1636 static void
1637 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1638 {
1639   gfc_symbol *sym;
1640   tree append_args;
1641
1642   gcc_assert (!se->ss || se->ss->expr == expr);
1643
1644   if (se->ss)
1645     gcc_assert (expr->rank > 0);
1646   else
1647     gcc_assert (expr->rank == 0);
1648
1649   sym = gfc_get_symbol_for_expr (expr);
1650
1651   /* Calls to libgfortran_matmul need to be appended special arguments,
1652      to be able to call the BLAS ?gemm functions if required and possible.  */
1653   append_args = NULL_TREE;
1654   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1655       && sym->ts.type != BT_LOGICAL)
1656     {
1657       tree cint = gfc_get_int_type (gfc_c_int_kind);
1658
1659       if (gfc_option.flag_external_blas
1660           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1661           && (sym->ts.kind == gfc_default_real_kind
1662               || sym->ts.kind == gfc_default_double_kind))
1663         {
1664           tree gemm_fndecl;
1665
1666           if (sym->ts.type == BT_REAL)
1667             {
1668               if (sym->ts.kind == gfc_default_real_kind)
1669                 gemm_fndecl = gfor_fndecl_sgemm;
1670               else
1671                 gemm_fndecl = gfor_fndecl_dgemm;
1672             }
1673           else
1674             {
1675               if (sym->ts.kind == gfc_default_real_kind)
1676                 gemm_fndecl = gfor_fndecl_cgemm;
1677               else
1678                 gemm_fndecl = gfor_fndecl_zgemm;
1679             }
1680
1681           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1682           append_args = gfc_chainon_list
1683                           (append_args, build_int_cst
1684                                           (cint, gfc_option.blas_matmul_limit));
1685           append_args = gfc_chainon_list (append_args,
1686                                           gfc_build_addr_expr (NULL_TREE,
1687                                                                gemm_fndecl));
1688         }
1689       else
1690         {
1691           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1692           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1693           append_args = gfc_chainon_list (append_args, null_pointer_node);
1694         }
1695     }
1696
1697   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1698   gfc_free (sym);
1699 }
1700
1701 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1702    Implemented as
1703     any(a)
1704     {
1705       forall (i=...)
1706         if (a[i] != 0)
1707           return 1
1708       end forall
1709       return 0
1710     }
1711     all(a)
1712     {
1713       forall (i=...)
1714         if (a[i] == 0)
1715           return 0
1716       end forall
1717       return 1
1718     }
1719  */
1720 static void
1721 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1722 {
1723   tree resvar;
1724   stmtblock_t block;
1725   stmtblock_t body;
1726   tree type;
1727   tree tmp;
1728   tree found;
1729   gfc_loopinfo loop;
1730   gfc_actual_arglist *actual;
1731   gfc_ss *arrayss;
1732   gfc_se arrayse;
1733   tree exit_label;
1734
1735   if (se->ss)
1736     {
1737       gfc_conv_intrinsic_funcall (se, expr);
1738       return;
1739     }
1740
1741   actual = expr->value.function.actual;
1742   type = gfc_typenode_for_spec (&expr->ts);
1743   /* Initialize the result.  */
1744   resvar = gfc_create_var (type, "test");
1745   if (op == EQ_EXPR)
1746     tmp = convert (type, boolean_true_node);
1747   else
1748     tmp = convert (type, boolean_false_node);
1749   gfc_add_modify_expr (&se->pre, resvar, tmp);
1750
1751   /* Walk the arguments.  */
1752   arrayss = gfc_walk_expr (actual->expr);
1753   gcc_assert (arrayss != gfc_ss_terminator);
1754
1755   /* Initialize the scalarizer.  */
1756   gfc_init_loopinfo (&loop);
1757   exit_label = gfc_build_label_decl (NULL_TREE);
1758   TREE_USED (exit_label) = 1;
1759   gfc_add_ss_to_loop (&loop, arrayss);
1760
1761   /* Initialize the loop.  */
1762   gfc_conv_ss_startstride (&loop);
1763   gfc_conv_loop_setup (&loop);
1764
1765   gfc_mark_ss_chain_used (arrayss, 1);
1766   /* Generate the loop body.  */
1767   gfc_start_scalarized_body (&loop, &body);
1768
1769   /* If the condition matches then set the return value.  */
1770   gfc_start_block (&block);
1771   if (op == EQ_EXPR)
1772     tmp = convert (type, boolean_false_node);
1773   else
1774     tmp = convert (type, boolean_true_node);
1775   gfc_add_modify_expr (&block, resvar, tmp);
1776
1777   /* And break out of the loop.  */
1778   tmp = build1_v (GOTO_EXPR, exit_label);
1779   gfc_add_expr_to_block (&block, tmp);
1780
1781   found = gfc_finish_block (&block);
1782
1783   /* Check this element.  */
1784   gfc_init_se (&arrayse, NULL);
1785   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1786   arrayse.ss = arrayss;
1787   gfc_conv_expr_val (&arrayse, actual->expr);
1788
1789   gfc_add_block_to_block (&body, &arrayse.pre);
1790   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1791                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1792   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1793   gfc_add_expr_to_block (&body, tmp);
1794   gfc_add_block_to_block (&body, &arrayse.post);
1795
1796   gfc_trans_scalarizing_loops (&loop, &body);
1797
1798   /* Add the exit label.  */
1799   tmp = build1_v (LABEL_EXPR, exit_label);
1800   gfc_add_expr_to_block (&loop.pre, tmp);
1801
1802   gfc_add_block_to_block (&se->pre, &loop.pre);
1803   gfc_add_block_to_block (&se->pre, &loop.post);
1804   gfc_cleanup_loop (&loop);
1805
1806   se->expr = resvar;
1807 }
1808
1809 /* COUNT(A) = Number of true elements in A.  */
1810 static void
1811 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1812 {
1813   tree resvar;
1814   tree type;
1815   stmtblock_t body;
1816   tree tmp;
1817   gfc_loopinfo loop;
1818   gfc_actual_arglist *actual;
1819   gfc_ss *arrayss;
1820   gfc_se arrayse;
1821
1822   if (se->ss)
1823     {
1824       gfc_conv_intrinsic_funcall (se, expr);
1825       return;
1826     }
1827
1828   actual = expr->value.function.actual;
1829
1830   type = gfc_typenode_for_spec (&expr->ts);
1831   /* Initialize the result.  */
1832   resvar = gfc_create_var (type, "count");
1833   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1834
1835   /* Walk the arguments.  */
1836   arrayss = gfc_walk_expr (actual->expr);
1837   gcc_assert (arrayss != gfc_ss_terminator);
1838
1839   /* Initialize the scalarizer.  */
1840   gfc_init_loopinfo (&loop);
1841   gfc_add_ss_to_loop (&loop, arrayss);
1842
1843   /* Initialize the loop.  */
1844   gfc_conv_ss_startstride (&loop);
1845   gfc_conv_loop_setup (&loop);
1846
1847   gfc_mark_ss_chain_used (arrayss, 1);
1848   /* Generate the loop body.  */
1849   gfc_start_scalarized_body (&loop, &body);
1850
1851   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1852                 build_int_cst (TREE_TYPE (resvar), 1));
1853   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1854
1855   gfc_init_se (&arrayse, NULL);
1856   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1857   arrayse.ss = arrayss;
1858   gfc_conv_expr_val (&arrayse, actual->expr);
1859   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1860
1861   gfc_add_block_to_block (&body, &arrayse.pre);
1862   gfc_add_expr_to_block (&body, tmp);
1863   gfc_add_block_to_block (&body, &arrayse.post);
1864
1865   gfc_trans_scalarizing_loops (&loop, &body);
1866
1867   gfc_add_block_to_block (&se->pre, &loop.pre);
1868   gfc_add_block_to_block (&se->pre, &loop.post);
1869   gfc_cleanup_loop (&loop);
1870
1871   se->expr = resvar;
1872 }
1873
1874 /* Inline implementation of the sum and product intrinsics.  */
1875 static void
1876 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1877 {
1878   tree resvar;
1879   tree type;
1880   stmtblock_t body;
1881   stmtblock_t block;
1882   tree tmp;
1883   gfc_loopinfo loop;
1884   gfc_actual_arglist *actual;
1885   gfc_ss *arrayss;
1886   gfc_ss *maskss;
1887   gfc_se arrayse;
1888   gfc_se maskse;
1889   gfc_expr *arrayexpr;
1890   gfc_expr *maskexpr;
1891
1892   if (se->ss)
1893     {
1894       gfc_conv_intrinsic_funcall (se, expr);
1895       return;
1896     }
1897
1898   type = gfc_typenode_for_spec (&expr->ts);
1899   /* Initialize the result.  */
1900   resvar = gfc_create_var (type, "val");
1901   if (op == PLUS_EXPR)
1902     tmp = gfc_build_const (type, integer_zero_node);
1903   else
1904     tmp = gfc_build_const (type, integer_one_node);
1905
1906   gfc_add_modify_expr (&se->pre, resvar, tmp);
1907
1908   /* Walk the arguments.  */
1909   actual = expr->value.function.actual;
1910   arrayexpr = actual->expr;
1911   arrayss = gfc_walk_expr (arrayexpr);
1912   gcc_assert (arrayss != gfc_ss_terminator);
1913
1914   actual = actual->next->next;
1915   gcc_assert (actual);
1916   maskexpr = actual->expr;
1917   if (maskexpr && maskexpr->rank != 0)
1918     {
1919       maskss = gfc_walk_expr (maskexpr);
1920       gcc_assert (maskss != gfc_ss_terminator);
1921     }
1922   else
1923     maskss = NULL;
1924
1925   /* Initialize the scalarizer.  */
1926   gfc_init_loopinfo (&loop);
1927   gfc_add_ss_to_loop (&loop, arrayss);
1928   if (maskss)
1929     gfc_add_ss_to_loop (&loop, maskss);
1930
1931   /* Initialize the loop.  */
1932   gfc_conv_ss_startstride (&loop);
1933   gfc_conv_loop_setup (&loop);
1934
1935   gfc_mark_ss_chain_used (arrayss, 1);
1936   if (maskss)
1937     gfc_mark_ss_chain_used (maskss, 1);
1938   /* Generate the loop body.  */
1939   gfc_start_scalarized_body (&loop, &body);
1940
1941   /* If we have a mask, only add this element if the mask is set.  */
1942   if (maskss)
1943     {
1944       gfc_init_se (&maskse, NULL);
1945       gfc_copy_loopinfo_to_se (&maskse, &loop);
1946       maskse.ss = maskss;
1947       gfc_conv_expr_val (&maskse, maskexpr);
1948       gfc_add_block_to_block (&body, &maskse.pre);
1949
1950       gfc_start_block (&block);
1951     }
1952   else
1953     gfc_init_block (&block);
1954
1955   /* Do the actual summation/product.  */
1956   gfc_init_se (&arrayse, NULL);
1957   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1958   arrayse.ss = arrayss;
1959   gfc_conv_expr_val (&arrayse, arrayexpr);
1960   gfc_add_block_to_block (&block, &arrayse.pre);
1961
1962   tmp = build2 (op, type, resvar, arrayse.expr);
1963   gfc_add_modify_expr (&block, resvar, tmp);
1964   gfc_add_block_to_block (&block, &arrayse.post);
1965
1966   if (maskss)
1967     {
1968       /* We enclose the above in if (mask) {...} .  */
1969       tmp = gfc_finish_block (&block);
1970
1971       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1972     }
1973   else
1974     tmp = gfc_finish_block (&block);
1975   gfc_add_expr_to_block (&body, tmp);
1976
1977   gfc_trans_scalarizing_loops (&loop, &body);
1978
1979   /* For a scalar mask, enclose the loop in an if statement.  */
1980   if (maskexpr && maskss == NULL)
1981     {
1982       gfc_init_se (&maskse, NULL);
1983       gfc_conv_expr_val (&maskse, maskexpr);
1984       gfc_init_block (&block);
1985       gfc_add_block_to_block (&block, &loop.pre);
1986       gfc_add_block_to_block (&block, &loop.post);
1987       tmp = gfc_finish_block (&block);
1988
1989       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1990       gfc_add_expr_to_block (&block, tmp);
1991       gfc_add_block_to_block (&se->pre, &block);
1992     }
1993   else
1994     {
1995       gfc_add_block_to_block (&se->pre, &loop.pre);
1996       gfc_add_block_to_block (&se->pre, &loop.post);
1997     }
1998
1999   gfc_cleanup_loop (&loop);
2000
2001   se->expr = resvar;
2002 }
2003
2004
2005 /* Inline implementation of the dot_product intrinsic. This function
2006    is based on gfc_conv_intrinsic_arith (the previous function).  */
2007 static void
2008 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2009 {
2010   tree resvar;
2011   tree type;
2012   stmtblock_t body;
2013   stmtblock_t block;
2014   tree tmp;
2015   gfc_loopinfo loop;
2016   gfc_actual_arglist *actual;
2017   gfc_ss *arrayss1, *arrayss2;
2018   gfc_se arrayse1, arrayse2;
2019   gfc_expr *arrayexpr1, *arrayexpr2;
2020
2021   type = gfc_typenode_for_spec (&expr->ts);
2022
2023   /* Initialize the result.  */
2024   resvar = gfc_create_var (type, "val");
2025   if (expr->ts.type == BT_LOGICAL)
2026     tmp = build_int_cst (type, 0);
2027   else
2028     tmp = gfc_build_const (type, integer_zero_node);
2029
2030   gfc_add_modify_expr (&se->pre, resvar, tmp);
2031
2032   /* Walk argument #1.  */
2033   actual = expr->value.function.actual;
2034   arrayexpr1 = actual->expr;
2035   arrayss1 = gfc_walk_expr (arrayexpr1);
2036   gcc_assert (arrayss1 != gfc_ss_terminator);
2037
2038   /* Walk argument #2.  */
2039   actual = actual->next;
2040   arrayexpr2 = actual->expr;
2041   arrayss2 = gfc_walk_expr (arrayexpr2);
2042   gcc_assert (arrayss2 != gfc_ss_terminator);
2043
2044   /* Initialize the scalarizer.  */
2045   gfc_init_loopinfo (&loop);
2046   gfc_add_ss_to_loop (&loop, arrayss1);
2047   gfc_add_ss_to_loop (&loop, arrayss2);
2048
2049   /* Initialize the loop.  */
2050   gfc_conv_ss_startstride (&loop);
2051   gfc_conv_loop_setup (&loop);
2052
2053   gfc_mark_ss_chain_used (arrayss1, 1);
2054   gfc_mark_ss_chain_used (arrayss2, 1);
2055
2056   /* Generate the loop body.  */
2057   gfc_start_scalarized_body (&loop, &body);
2058   gfc_init_block (&block);
2059
2060   /* Make the tree expression for [conjg(]array1[)].  */
2061   gfc_init_se (&arrayse1, NULL);
2062   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2063   arrayse1.ss = arrayss1;
2064   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2065   if (expr->ts.type == BT_COMPLEX)
2066     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
2067   gfc_add_block_to_block (&block, &arrayse1.pre);
2068
2069   /* Make the tree expression for array2.  */
2070   gfc_init_se (&arrayse2, NULL);
2071   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2072   arrayse2.ss = arrayss2;
2073   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2074   gfc_add_block_to_block (&block, &arrayse2.pre);
2075
2076   /* Do the actual product and sum.  */
2077   if (expr->ts.type == BT_LOGICAL)
2078     {
2079       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2080       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2081     }
2082   else
2083     {
2084       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2085       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
2086     }
2087   gfc_add_modify_expr (&block, resvar, tmp);
2088
2089   /* Finish up the loop block and the loop.  */
2090   tmp = gfc_finish_block (&block);
2091   gfc_add_expr_to_block (&body, tmp);
2092
2093   gfc_trans_scalarizing_loops (&loop, &body);
2094   gfc_add_block_to_block (&se->pre, &loop.pre);
2095   gfc_add_block_to_block (&se->pre, &loop.post);
2096   gfc_cleanup_loop (&loop);
2097
2098   se->expr = resvar;
2099 }
2100
2101
2102 static void
2103 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2104 {
2105   stmtblock_t body;
2106   stmtblock_t block;
2107   stmtblock_t ifblock;
2108   stmtblock_t elseblock;
2109   tree limit;
2110   tree type;
2111   tree tmp;
2112   tree elsetmp;
2113   tree ifbody;
2114   tree offset;
2115   gfc_loopinfo loop;
2116   gfc_actual_arglist *actual;
2117   gfc_ss *arrayss;
2118   gfc_ss *maskss;
2119   gfc_se arrayse;
2120   gfc_se maskse;
2121   gfc_expr *arrayexpr;
2122   gfc_expr *maskexpr;
2123   tree pos;
2124   int n;
2125
2126   if (se->ss)
2127     {
2128       gfc_conv_intrinsic_funcall (se, expr);
2129       return;
2130     }
2131
2132   /* Initialize the result.  */
2133   pos = gfc_create_var (gfc_array_index_type, "pos");
2134   offset = gfc_create_var (gfc_array_index_type, "offset");
2135   type = gfc_typenode_for_spec (&expr->ts);
2136
2137   /* Walk the arguments.  */
2138   actual = expr->value.function.actual;
2139   arrayexpr = actual->expr;
2140   arrayss = gfc_walk_expr (arrayexpr);
2141   gcc_assert (arrayss != gfc_ss_terminator);
2142
2143   actual = actual->next->next;
2144   gcc_assert (actual);
2145   maskexpr = actual->expr;
2146   if (maskexpr && maskexpr->rank != 0)
2147     {
2148       maskss = gfc_walk_expr (maskexpr);
2149       gcc_assert (maskss != gfc_ss_terminator);
2150     }
2151   else
2152     maskss = NULL;
2153
2154   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2155   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2156   switch (arrayexpr->ts.type)
2157     {
2158     case BT_REAL:
2159       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2160       break;
2161
2162     case BT_INTEGER:
2163       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2164                                   arrayexpr->ts.kind);
2165       break;
2166
2167     default:
2168       gcc_unreachable ();
2169     }
2170
2171   /* We start with the most negative possible value for MAXLOC, and the most
2172      positive possible value for MINLOC. The most negative possible value is
2173      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2174      possible value is HUGE in both cases.  */
2175   if (op == GT_EXPR)
2176     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2177   gfc_add_modify_expr (&se->pre, limit, tmp);
2178
2179   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2180     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2181                   build_int_cst (type, 1));
2182
2183   /* Initialize the scalarizer.  */
2184   gfc_init_loopinfo (&loop);
2185   gfc_add_ss_to_loop (&loop, arrayss);
2186   if (maskss)
2187     gfc_add_ss_to_loop (&loop, maskss);
2188
2189   /* Initialize the loop.  */
2190   gfc_conv_ss_startstride (&loop);
2191   gfc_conv_loop_setup (&loop);
2192
2193   gcc_assert (loop.dimen == 1);
2194
2195   /* Initialize the position to zero, following Fortran 2003.  We are free
2196      to do this because Fortran 95 allows the result of an entirely false
2197      mask to be processor dependent.  */
2198   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2199
2200   gfc_mark_ss_chain_used (arrayss, 1);
2201   if (maskss)
2202     gfc_mark_ss_chain_used (maskss, 1);
2203   /* Generate the loop body.  */
2204   gfc_start_scalarized_body (&loop, &body);
2205
2206   /* If we have a mask, only check this element if the mask is set.  */
2207   if (maskss)
2208     {
2209       gfc_init_se (&maskse, NULL);
2210       gfc_copy_loopinfo_to_se (&maskse, &loop);
2211       maskse.ss = maskss;
2212       gfc_conv_expr_val (&maskse, maskexpr);
2213       gfc_add_block_to_block (&body, &maskse.pre);
2214
2215       gfc_start_block (&block);
2216     }
2217   else
2218     gfc_init_block (&block);
2219
2220   /* Compare with the current limit.  */
2221   gfc_init_se (&arrayse, NULL);
2222   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2223   arrayse.ss = arrayss;
2224   gfc_conv_expr_val (&arrayse, arrayexpr);
2225   gfc_add_block_to_block (&block, &arrayse.pre);
2226
2227   /* We do the following if this is a more extreme value.  */
2228   gfc_start_block (&ifblock);
2229
2230   /* Assign the value to the limit...  */
2231   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2232
2233   /* Remember where we are.  An offset must be added to the loop
2234      counter to obtain the required position.  */
2235   if (loop.temp_dim)
2236     tmp = build_int_cst (gfc_array_index_type, 1);
2237   else
2238     tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2239                          gfc_index_one_node, loop.from[0]);
2240   gfc_add_modify_expr (&block, offset, tmp);
2241
2242   tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2243                 loop.loopvar[0], offset);
2244   gfc_add_modify_expr (&ifblock, pos, tmp);
2245
2246   ifbody = gfc_finish_block (&ifblock);
2247
2248   /* If it is a more extreme value or pos is still zero and the value
2249      equal to the limit.  */
2250   tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2251                 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2252                 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2253   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2254                 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2255   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2256   gfc_add_expr_to_block (&block, tmp);
2257
2258   if (maskss)
2259     {
2260       /* We enclose the above in if (mask) {...}.  */
2261       tmp = gfc_finish_block (&block);
2262
2263       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2264     }
2265   else
2266     tmp = gfc_finish_block (&block);
2267   gfc_add_expr_to_block (&body, tmp);
2268
2269   gfc_trans_scalarizing_loops (&loop, &body);
2270
2271   /* For a scalar mask, enclose the loop in an if statement.  */
2272   if (maskexpr && maskss == NULL)
2273     {
2274       gfc_init_se (&maskse, NULL);
2275       gfc_conv_expr_val (&maskse, maskexpr);
2276       gfc_init_block (&block);
2277       gfc_add_block_to_block (&block, &loop.pre);
2278       gfc_add_block_to_block (&block, &loop.post);
2279       tmp = gfc_finish_block (&block);
2280
2281       /* For the else part of the scalar mask, just initialize
2282          the pos variable the same way as above.  */
2283
2284       gfc_init_block (&elseblock);
2285       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2286       elsetmp = gfc_finish_block (&elseblock);
2287
2288       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2289       gfc_add_expr_to_block (&block, tmp);
2290       gfc_add_block_to_block (&se->pre, &block);
2291     }
2292   else
2293     {
2294       gfc_add_block_to_block (&se->pre, &loop.pre);
2295       gfc_add_block_to_block (&se->pre, &loop.post);
2296     }
2297   gfc_cleanup_loop (&loop);
2298
2299   se->expr = convert (type, pos);
2300 }
2301
2302 static void
2303 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2304 {
2305   tree limit;
2306   tree type;
2307   tree tmp;
2308   tree ifbody;
2309   stmtblock_t body;
2310   stmtblock_t block;
2311   gfc_loopinfo loop;
2312   gfc_actual_arglist *actual;
2313   gfc_ss *arrayss;
2314   gfc_ss *maskss;
2315   gfc_se arrayse;
2316   gfc_se maskse;
2317   gfc_expr *arrayexpr;
2318   gfc_expr *maskexpr;
2319   int n;
2320
2321   if (se->ss)
2322     {
2323       gfc_conv_intrinsic_funcall (se, expr);
2324       return;
2325     }
2326
2327   type = gfc_typenode_for_spec (&expr->ts);
2328   /* Initialize the result.  */
2329   limit = gfc_create_var (type, "limit");
2330   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2331   switch (expr->ts.type)
2332     {
2333     case BT_REAL:
2334       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2335       break;
2336
2337     case BT_INTEGER:
2338       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2339       break;
2340
2341     default:
2342       gcc_unreachable ();
2343     }
2344
2345   /* We start with the most negative possible value for MAXVAL, and the most
2346      positive possible value for MINVAL. The most negative possible value is
2347      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2348      possible value is HUGE in both cases.  */
2349   if (op == GT_EXPR)
2350     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2351
2352   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2353     tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2354                   build_int_cst (type, 1));
2355
2356   gfc_add_modify_expr (&se->pre, limit, tmp);
2357
2358   /* Walk the arguments.  */
2359   actual = expr->value.function.actual;
2360   arrayexpr = actual->expr;
2361   arrayss = gfc_walk_expr (arrayexpr);
2362   gcc_assert (arrayss != gfc_ss_terminator);
2363
2364   actual = actual->next->next;
2365   gcc_assert (actual);
2366   maskexpr = actual->expr;
2367   if (maskexpr && maskexpr->rank != 0)
2368     {
2369       maskss = gfc_walk_expr (maskexpr);
2370       gcc_assert (maskss != gfc_ss_terminator);
2371     }
2372   else
2373     maskss = NULL;
2374
2375   /* Initialize the scalarizer.  */
2376   gfc_init_loopinfo (&loop);
2377   gfc_add_ss_to_loop (&loop, arrayss);
2378   if (maskss)
2379     gfc_add_ss_to_loop (&loop, maskss);
2380
2381   /* Initialize the loop.  */
2382   gfc_conv_ss_startstride (&loop);
2383   gfc_conv_loop_setup (&loop);
2384
2385   gfc_mark_ss_chain_used (arrayss, 1);
2386   if (maskss)
2387     gfc_mark_ss_chain_used (maskss, 1);
2388   /* Generate the loop body.  */
2389   gfc_start_scalarized_body (&loop, &body);
2390
2391   /* If we have a mask, only add this element if the mask is set.  */
2392   if (maskss)
2393     {
2394       gfc_init_se (&maskse, NULL);
2395       gfc_copy_loopinfo_to_se (&maskse, &loop);
2396       maskse.ss = maskss;
2397       gfc_conv_expr_val (&maskse, maskexpr);
2398       gfc_add_block_to_block (&body, &maskse.pre);
2399
2400       gfc_start_block (&block);
2401     }
2402   else
2403     gfc_init_block (&block);
2404
2405   /* Compare with the current limit.  */
2406   gfc_init_se (&arrayse, NULL);
2407   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2408   arrayse.ss = arrayss;
2409   gfc_conv_expr_val (&arrayse, arrayexpr);
2410   gfc_add_block_to_block (&block, &arrayse.pre);
2411
2412   /* Assign the value to the limit...  */
2413   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2414
2415   /* If it is a more extreme value.  */
2416   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2417   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2418   gfc_add_expr_to_block (&block, tmp);
2419   gfc_add_block_to_block (&block, &arrayse.post);
2420
2421   tmp = gfc_finish_block (&block);
2422   if (maskss)
2423     /* We enclose the above in if (mask) {...}.  */
2424     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2425   gfc_add_expr_to_block (&body, tmp);
2426
2427   gfc_trans_scalarizing_loops (&loop, &body);
2428
2429   /* For a scalar mask, enclose the loop in an if statement.  */
2430   if (maskexpr && maskss == NULL)
2431     {
2432       gfc_init_se (&maskse, NULL);
2433       gfc_conv_expr_val (&maskse, maskexpr);
2434       gfc_init_block (&block);
2435       gfc_add_block_to_block (&block, &loop.pre);
2436       gfc_add_block_to_block (&block, &loop.post);
2437       tmp = gfc_finish_block (&block);
2438
2439       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2440       gfc_add_expr_to_block (&block, tmp);
2441       gfc_add_block_to_block (&se->pre, &block);
2442     }
2443   else
2444     {
2445       gfc_add_block_to_block (&se->pre, &loop.pre);
2446       gfc_add_block_to_block (&se->pre, &loop.post);
2447     }
2448
2449   gfc_cleanup_loop (&loop);
2450
2451   se->expr = limit;
2452 }
2453
2454 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2455 static void
2456 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2457 {
2458   tree args[2];
2459   tree type;
2460   tree tmp;
2461
2462   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2463   type = TREE_TYPE (args[0]);
2464
2465   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2466   tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
2467   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2468                      build_int_cst (type, 0));
2469   type = gfc_typenode_for_spec (&expr->ts);
2470   se->expr = convert (type, tmp);
2471 }
2472
2473 /* Generate code to perform the specified operation.  */
2474 static void
2475 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2476 {
2477   tree args[2];
2478
2479   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2480   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2481 }
2482
2483 /* Bitwise not.  */
2484 static void
2485 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2486 {
2487   tree arg;
2488
2489   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2490   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2491 }
2492
2493 /* Set or clear a single bit.  */
2494 static void
2495 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2496 {
2497   tree args[2];
2498   tree type;
2499   tree tmp;
2500   int op;
2501
2502   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2503   type = TREE_TYPE (args[0]);
2504
2505   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2506   if (set)
2507     op = BIT_IOR_EXPR;
2508   else
2509     {
2510       op = BIT_AND_EXPR;
2511       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2512     }
2513   se->expr = fold_build2 (op, type, args[0], tmp);
2514 }
2515
2516 /* Extract a sequence of bits.
2517     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2518 static void
2519 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2520 {
2521   tree args[3];
2522   tree type;
2523   tree tmp;
2524   tree mask;
2525
2526   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2527   type = TREE_TYPE (args[0]);
2528
2529   mask = build_int_cst (type, -1);
2530   mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
2531   mask = build1 (BIT_NOT_EXPR, type, mask);
2532
2533   tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
2534
2535   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2536 }
2537
2538 /* RSHIFT (I, SHIFT) = I >> SHIFT
2539    LSHIFT (I, SHIFT) = I << SHIFT  */
2540 static void
2541 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2542 {
2543   tree args[2];
2544
2545   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2546
2547   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2548                           TREE_TYPE (args[0]), args[0], args[1]);
2549 }
2550
2551 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2552                         ? 0
2553                         : ((shift >= 0) ? i << shift : i >> -shift)
2554    where all shifts are logical shifts.  */
2555 static void
2556 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2557 {
2558   tree args[2];
2559   tree type;
2560   tree utype;
2561   tree tmp;
2562   tree width;
2563   tree num_bits;
2564   tree cond;
2565   tree lshift;
2566   tree rshift;
2567
2568   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2569   type = TREE_TYPE (args[0]);
2570   utype = unsigned_type_for (type);
2571
2572   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2573
2574   /* Left shift if positive.  */
2575   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2576
2577   /* Right shift if negative.
2578      We convert to an unsigned type because we want a logical shift.
2579      The standard doesn't define the case of shifting negative
2580      numbers, and we try to be compatible with other compilers, most
2581      notably g77, here.  */
2582   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2583                                        convert (utype, args[0]), width));
2584
2585   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2586                      build_int_cst (TREE_TYPE (args[1]), 0));
2587   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2588
2589   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2590      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2591      special case.  */
2592   num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
2593   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2594
2595   se->expr = fold_build3 (COND_EXPR, type, cond,
2596                           build_int_cst (type, 0), tmp);
2597 }
2598
2599
2600 /* Circular shift.  AKA rotate or barrel shift.  */
2601
2602 static void
2603 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2604 {
2605   tree *args;
2606   tree type;
2607   tree tmp;
2608   tree lrot;
2609   tree rrot;
2610   tree zero;
2611   unsigned int num_args;
2612
2613   num_args = gfc_intrinsic_argument_list_length (expr);
2614   args = alloca (sizeof (tree) * num_args);
2615
2616   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2617
2618   if (num_args == 3)
2619     {
2620       /* Use a library function for the 3 parameter version.  */
2621       tree int4type = gfc_get_int_type (4);
2622
2623       type = TREE_TYPE (args[0]);
2624       /* We convert the first argument to at least 4 bytes, and
2625          convert back afterwards.  This removes the need for library
2626          functions for all argument sizes, and function will be
2627          aligned to at least 32 bits, so there's no loss.  */
2628       if (expr->ts.kind < 4)
2629         args[0] = convert (int4type, args[0]);
2630
2631       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2632          need loads of library  functions.  They cannot have values >
2633          BIT_SIZE (I) so the conversion is safe.  */
2634       args[1] = convert (int4type, args[1]);
2635       args[2] = convert (int4type, args[2]);
2636
2637       switch (expr->ts.kind)
2638         {
2639         case 1:
2640         case 2:
2641         case 4:
2642           tmp = gfor_fndecl_math_ishftc4;
2643           break;
2644         case 8:
2645           tmp = gfor_fndecl_math_ishftc8;
2646           break;
2647         case 16:
2648           tmp = gfor_fndecl_math_ishftc16;
2649           break;
2650         default:
2651           gcc_unreachable ();
2652         }
2653       se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2654       /* Convert the result back to the original type, if we extended
2655          the first argument's width above.  */
2656       if (expr->ts.kind < 4)
2657         se->expr = convert (type, se->expr);
2658
2659       return;
2660     }
2661   type = TREE_TYPE (args[0]);
2662
2663   /* Rotate left if positive.  */
2664   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2665
2666   /* Rotate right if negative.  */
2667   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2668   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2669
2670   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2671   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2672   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2673
2674   /* Do nothing if shift == 0.  */
2675   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2676   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2677 }
2678
2679 /* The length of a character string.  */
2680 static void
2681 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2682 {
2683   tree len;
2684   tree type;
2685   tree decl;
2686   gfc_symbol *sym;
2687   gfc_se argse;
2688   gfc_expr *arg;
2689   gfc_ss *ss;
2690
2691   gcc_assert (!se->ss);
2692
2693   arg = expr->value.function.actual->expr;
2694
2695   type = gfc_typenode_for_spec (&expr->ts);
2696   switch (arg->expr_type)
2697     {
2698     case EXPR_CONSTANT:
2699       len = build_int_cst (NULL_TREE, arg->value.character.length);
2700       break;
2701
2702     case EXPR_ARRAY:
2703       /* Obtain the string length from the function used by
2704          trans-array.c(gfc_trans_array_constructor).  */
2705       len = NULL_TREE;
2706       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2707       break;
2708
2709     case EXPR_VARIABLE:
2710       if (arg->ref == NULL
2711             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2712         {
2713           /* This doesn't catch all cases.
2714              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2715              and the surrounding thread.  */
2716           sym = arg->symtree->n.sym;
2717           decl = gfc_get_symbol_decl (sym);
2718           if (decl == current_function_decl && sym->attr.function
2719                 && (sym->result == sym))
2720             decl = gfc_get_fake_result_decl (sym, 0);
2721
2722           len = sym->ts.cl->backend_decl;
2723           gcc_assert (len);
2724           break;
2725         }
2726
2727       /* Otherwise fall through.  */
2728
2729     default:
2730       /* Anybody stupid enough to do this deserves inefficient code.  */
2731       ss = gfc_walk_expr (arg);
2732       gfc_init_se (&argse, se);
2733       if (ss == gfc_ss_terminator)
2734         gfc_conv_expr (&argse, arg);
2735       else
2736         gfc_conv_expr_descriptor (&argse, arg, ss);
2737       gfc_add_block_to_block (&se->pre, &argse.pre);
2738       gfc_add_block_to_block (&se->post, &argse.post);
2739       len = argse.string_length;
2740       break;
2741     }
2742   se->expr = convert (type, len);
2743 }
2744
2745 /* The length of a character string not including trailing blanks.  */
2746 static void
2747 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2748 {
2749   tree args[2];
2750   tree type;
2751
2752   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2753   type = gfc_typenode_for_spec (&expr->ts);
2754   se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2755   se->expr = convert (type, se->expr);
2756 }
2757
2758
2759 /* Returns the starting position of a substring within a string.  */
2760
2761 static void
2762 gfc_conv_intrinsic_index (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, &se->pre, &expr->where,
3669                            "Argument NCOPIES of REPEAT intrinsic is negative "
3670                            "(its value is %lld)",
3671                            fold_convert (long_integer_type_node, ncopies));
3672
3673   /* If the source length is zero, any non negative value of NCOPIES
3674      is valid, and nothing happens.  */
3675   n = gfc_create_var (ncopies_type, "ncopies");
3676   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3677                       build_int_cst (size_type_node, 0));
3678   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3679                      build_int_cst (ncopies_type, 0), ncopies);
3680   gfc_add_modify_expr (&se->pre, n, tmp);
3681   ncopies = n;
3682
3683   /* Check that ncopies is not too large: ncopies should be less than
3684      (or equal to) MAX / slen, where MAX is the maximal integer of
3685      the gfc_charlen_type_node type.  If slen == 0, we need a special
3686      case to avoid the division by zero.  */
3687   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3688   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3689   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3690                      fold_convert (size_type_node, max), slen);
3691   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3692               ? size_type_node : ncopies_type;
3693   cond = fold_build2 (GT_EXPR, boolean_type_node,
3694                       fold_convert (largest, ncopies),
3695                       fold_convert (largest, max));
3696   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3697                      build_int_cst (size_type_node, 0));
3698   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3699                       cond);
3700   gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3701                            "Argument NCOPIES of REPEAT intrinsic is too large");
3702
3703
3704   /* Compute the destination length.  */
3705   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3706                       fold_convert (gfc_charlen_type_node, slen),
3707                       fold_convert (gfc_charlen_type_node, ncopies));
3708   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3709   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3710
3711   /* Generate the code to do the repeat operation:
3712        for (i = 0; i < ncopies; i++)
3713          memmove (dest + (i * slen), src, slen);  */
3714   gfc_start_block (&block);
3715   count = gfc_create_var (ncopies_type, "count");
3716   gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3717   exit_label = gfc_build_label_decl (NULL_TREE);
3718
3719   /* Start the loop body.  */
3720   gfc_start_block (&body);
3721
3722   /* Exit the loop if count >= ncopies.  */
3723   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3724   tmp = build1_v (GOTO_EXPR, exit_label);
3725   TREE_USED (exit_label) = 1;
3726   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3727                      build_empty_stmt ());
3728   gfc_add_expr_to_block (&body, tmp);
3729
3730   /* Call memmove (dest + (i*slen), src, slen).  */
3731   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3732                      fold_convert (gfc_charlen_type_node, slen),
3733                      fold_convert (gfc_charlen_type_node, count));
3734   tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3735                      fold_convert (pchar_type_node, dest),
3736                      fold_convert (sizetype, tmp));
3737   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3738                          tmp, src, slen);
3739   gfc_add_expr_to_block (&body, tmp);
3740
3741   /* Increment count.  */
3742   tmp = build2 (PLUS_EXPR, ncopies_type, count,
3743                 build_int_cst (TREE_TYPE (count), 1));
3744   gfc_add_modify_expr (&body, count, tmp);
3745
3746   /* Build the loop.  */
3747   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3748   gfc_add_expr_to_block (&block, tmp);
3749
3750   /* Add the exit label.  */
3751   tmp = build1_v (LABEL_EXPR, exit_label);
3752   gfc_add_expr_to_block (&block, tmp);
3753
3754   /* Finish the block.  */
3755   tmp = gfc_finish_block (&block);
3756   gfc_add_expr_to_block (&se->pre, tmp);
3757
3758   /* Set the result value.  */
3759   se->expr = dest;
3760   se->string_length = dlen;
3761 }
3762
3763
3764 /* Generate code for the IARGC intrinsic.  */
3765
3766 static void
3767 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3768 {
3769   tree tmp;
3770   tree fndecl;
3771   tree type;
3772
3773   /* Call the library function.  This always returns an INTEGER(4).  */
3774   fndecl = gfor_fndecl_iargc;
3775   tmp = build_call_expr (fndecl, 0);
3776
3777   /* Convert it to the required type.  */
3778   type = gfc_typenode_for_spec (&expr->ts);
3779   tmp = fold_convert (type, tmp);
3780
3781   se->expr = tmp;
3782 }
3783
3784
3785 /* The loc intrinsic returns the address of its argument as
3786    gfc_index_integer_kind integer.  */
3787
3788 static void
3789 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3790 {
3791   tree temp_var;
3792   gfc_expr *arg_expr;
3793   gfc_ss *ss;
3794
3795   gcc_assert (!se->ss);
3796
3797   arg_expr = expr->value.function.actual->expr;
3798   ss = gfc_walk_expr (arg_expr);
3799   if (ss == gfc_ss_terminator)
3800     gfc_conv_expr_reference (se, arg_expr);
3801   else
3802     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3803   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3804
3805   /* Create a temporary variable for loc return value.  Without this,
3806      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3807   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3808   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3809   se->expr = temp_var;
3810 }
3811
3812 /* Generate code for an intrinsic function.  Some map directly to library
3813    calls, others get special handling.  In some cases the name of the function
3814    used depends on the type specifiers.  */
3815
3816 void
3817 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3818 {
3819   gfc_intrinsic_sym *isym;
3820   const char *name;
3821   int lib;
3822
3823   isym = expr->value.function.isym;
3824
3825   name = &expr->value.function.name[2];
3826
3827   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3828     {
3829       lib = gfc_is_intrinsic_libcall (expr);
3830       if (lib != 0)
3831         {
3832           if (lib == 1)
3833             se->ignore_optional = 1;
3834           gfc_conv_intrinsic_funcall (se, expr);
3835           return;
3836         }
3837     }
3838
3839   switch (expr->value.function.isym->id)
3840     {
3841     case GFC_ISYM_NONE:
3842       gcc_unreachable ();
3843
3844     case GFC_ISYM_REPEAT:
3845       gfc_conv_intrinsic_repeat (se, expr);
3846       break;
3847
3848     case GFC_ISYM_TRIM:
3849       gfc_conv_intrinsic_trim (se, expr);
3850       break;
3851
3852     case GFC_ISYM_SI_KIND:
3853       gfc_conv_intrinsic_si_kind (se, expr);
3854       break;
3855
3856     case GFC_ISYM_SR_KIND:
3857       gfc_conv_intrinsic_sr_kind (se, expr);
3858       break;
3859
3860     case GFC_ISYM_EXPONENT:
3861       gfc_conv_intrinsic_exponent (se, expr);
3862       break;
3863
3864     case GFC_ISYM_SCAN:
3865       gfc_conv_intrinsic_scan (se, expr);
3866       break;
3867
3868     case GFC_ISYM_VERIFY:
3869       gfc_conv_intrinsic_verify (se, expr);
3870       break;
3871
3872     case GFC_ISYM_ALLOCATED:
3873       gfc_conv_allocated (se, expr);
3874       break;
3875
3876     case GFC_ISYM_ASSOCIATED:
3877       gfc_conv_associated(se, expr);
3878       break;
3879
3880     case GFC_ISYM_ABS:
3881       gfc_conv_intrinsic_abs (se, expr);
3882       break;
3883
3884     case GFC_ISYM_ADJUSTL:
3885       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3886       break;
3887
3888     case GFC_ISYM_ADJUSTR:
3889       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3890       break;
3891
3892     case GFC_ISYM_AIMAG:
3893       gfc_conv_intrinsic_imagpart (se, expr);
3894       break;
3895
3896     case GFC_ISYM_AINT:
3897       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3898       break;
3899
3900     case GFC_ISYM_ALL:
3901       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3902       break;
3903
3904     case GFC_ISYM_ANINT:
3905       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3906       break;
3907
3908     case GFC_ISYM_AND:
3909       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3910       break;
3911
3912     case GFC_ISYM_ANY:
3913       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3914       break;
3915
3916     case GFC_ISYM_BTEST:
3917       gfc_conv_intrinsic_btest (se, expr);
3918       break;
3919
3920     case GFC_ISYM_ACHAR:
3921     case GFC_ISYM_CHAR:
3922       gfc_conv_intrinsic_char (se, expr);
3923       break;
3924
3925     case GFC_ISYM_CONVERSION:
3926     case GFC_ISYM_REAL:
3927     case GFC_ISYM_LOGICAL:
3928     case GFC_ISYM_DBLE:
3929       gfc_conv_intrinsic_conversion (se, expr);
3930       break;
3931
3932       /* Integer conversions are handled separately to make sure we get the
3933          correct rounding mode.  */
3934     case GFC_ISYM_INT:
3935     case GFC_ISYM_INT2:
3936     case GFC_ISYM_INT8:
3937     case GFC_ISYM_LONG:
3938       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3939       break;
3940
3941     case GFC_ISYM_NINT:
3942       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3943       break;
3944
3945     case GFC_ISYM_CEILING:
3946       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3947       break;
3948
3949     case GFC_ISYM_FLOOR:
3950       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3951       break;
3952
3953     case GFC_ISYM_MOD:
3954       gfc_conv_intrinsic_mod (se, expr, 0);
3955       break;
3956
3957     case GFC_ISYM_MODULO:
3958       gfc_conv_intrinsic_mod (se, expr, 1);
3959       break;
3960
3961     case GFC_ISYM_CMPLX:
3962       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3963       break;
3964
3965     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3966       gfc_conv_intrinsic_iargc (se, expr);
3967       break;
3968
3969     case GFC_ISYM_COMPLEX:
3970       gfc_conv_intrinsic_cmplx (se, expr, 1);
3971       break;
3972
3973     case GFC_ISYM_CONJG:
3974       gfc_conv_intrinsic_conjg (se, expr);
3975       break;
3976
3977     case GFC_ISYM_COUNT:
3978       gfc_conv_intrinsic_count (se, expr);
3979       break;
3980
3981     case GFC_ISYM_CTIME:
3982       gfc_conv_intrinsic_ctime (se, expr);
3983       break;
3984
3985     case GFC_ISYM_DIM:
3986       gfc_conv_intrinsic_dim (se, expr);
3987       break;
3988
3989     case GFC_ISYM_DOT_PRODUCT:
3990       gfc_conv_intrinsic_dot_product (se, expr);
3991       break;
3992
3993     case GFC_ISYM_DPROD:
3994       gfc_conv_intrinsic_dprod (se, expr);
3995       break;
3996
3997     case GFC_ISYM_FDATE:
3998       gfc_conv_intrinsic_fdate (se, expr);
3999       break;
4000
4001     case GFC_ISYM_IAND:
4002       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4003       break;
4004
4005     case GFC_ISYM_IBCLR:
4006       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4007       break;
4008
4009     case GFC_ISYM_IBITS:
4010       gfc_conv_intrinsic_ibits (se, expr);
4011       break;
4012
4013     case GFC_ISYM_IBSET:
4014       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4015       break;
4016
4017     case GFC_ISYM_IACHAR:
4018     case GFC_ISYM_ICHAR:
4019       /* We assume ASCII character sequence.  */
4020       gfc_conv_intrinsic_ichar (se, expr);
4021       break;
4022
4023     case GFC_ISYM_IARGC:
4024       gfc_conv_intrinsic_iargc (se, expr);
4025       break;
4026
4027     case GFC_ISYM_IEOR:
4028       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4029       break;
4030
4031     case GFC_ISYM_INDEX:
4032       gfc_conv_intrinsic_index (se, expr);
4033       break;
4034
4035     case GFC_ISYM_IOR:
4036       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4037       break;
4038
4039     case GFC_ISYM_ISNAN:
4040       gfc_conv_intrinsic_isnan (se, expr);
4041       break;
4042
4043     case GFC_ISYM_LSHIFT:
4044       gfc_conv_intrinsic_rlshift (se, expr, 0);
4045       break;
4046
4047     case GFC_ISYM_RSHIFT:
4048       gfc_conv_intrinsic_rlshift (se, expr, 1);
4049       break;
4050
4051     case GFC_ISYM_ISHFT:
4052       gfc_conv_intrinsic_ishft (se, expr);
4053       break;
4054
4055     case GFC_ISYM_ISHFTC:
4056       gfc_conv_intrinsic_ishftc (se, expr);
4057       break;
4058
4059     case GFC_ISYM_LBOUND:
4060       gfc_conv_intrinsic_bound (se, expr, 0);
4061       break;
4062
4063     case GFC_ISYM_TRANSPOSE:
4064       if (se->ss && se->ss->useflags)
4065         {
4066           gfc_conv_tmp_array_ref (se);
4067           gfc_advance_se_ss_chain (se);
4068         }
4069       else
4070         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4071       break;
4072
4073     case GFC_ISYM_LEN:
4074       gfc_conv_intrinsic_len (se, expr);
4075       break;
4076
4077     case GFC_ISYM_LEN_TRIM:
4078       gfc_conv_intrinsic_len_trim (se, expr);
4079       break;
4080
4081     case GFC_ISYM_LGE:
4082       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4083       break;
4084
4085     case GFC_ISYM_LGT:
4086       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4087       break;
4088
4089     case GFC_ISYM_LLE:
4090       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4091       break;
4092
4093     case GFC_ISYM_LLT:
4094       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4095       break;
4096
4097     case GFC_ISYM_MAX:
4098       if (expr->ts.type == BT_CHARACTER)
4099         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4100       else
4101         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4102       break;
4103
4104     case GFC_ISYM_MAXLOC:
4105       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4106       break;
4107
4108     case GFC_ISYM_MAXVAL:
4109       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4110       break;
4111
4112     case GFC_ISYM_MERGE:
4113       gfc_conv_intrinsic_merge (se, expr);
4114       break;
4115
4116     case GFC_ISYM_MIN:
4117       if (expr->ts.type == BT_CHARACTER)
4118         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4119       else
4120         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4121       break;
4122
4123     case GFC_ISYM_MINLOC:
4124       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4125       break;
4126
4127     case GFC_ISYM_MINVAL:
4128       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4129       break;
4130
4131     case GFC_ISYM_NOT:
4132       gfc_conv_intrinsic_not (se, expr);
4133       break;
4134
4135     case GFC_ISYM_OR:
4136       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4137       break;
4138
4139     case GFC_ISYM_PRESENT:
4140       gfc_conv_intrinsic_present (se, expr);
4141       break;
4142
4143     case GFC_ISYM_PRODUCT:
4144       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4145       break;
4146
4147     case GFC_ISYM_SIGN:
4148       gfc_conv_intrinsic_sign (se, expr);
4149       break;
4150
4151     case GFC_ISYM_SIZE:
4152       gfc_conv_intrinsic_size (se, expr);
4153       break;
4154
4155     case GFC_ISYM_SIZEOF:
4156       gfc_conv_intrinsic_sizeof (se, expr);
4157       break;
4158
4159     case GFC_ISYM_SUM:
4160       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4161       break;
4162
4163     case GFC_ISYM_TRANSFER:
4164       if (se->ss)
4165         {
4166           if (se->ss->useflags)
4167             {
4168               /* Access the previously obtained result.  */
4169               gfc_conv_tmp_array_ref (se);
4170               gfc_advance_se_ss_chain (se);
4171               break;
4172             }
4173           else
4174             gfc_conv_intrinsic_array_transfer (se, expr);
4175         }
4176       else
4177         gfc_conv_intrinsic_transfer (se, expr);
4178       break;
4179
4180     case GFC_ISYM_TTYNAM:
4181       gfc_conv_intrinsic_ttynam (se, expr);
4182       break;
4183
4184     case GFC_ISYM_UBOUND:
4185       gfc_conv_intrinsic_bound (se, expr, 1);
4186       break;
4187
4188     case GFC_ISYM_XOR:
4189       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4190       break;
4191
4192     case GFC_ISYM_LOC:
4193       gfc_conv_intrinsic_loc (se, expr);
4194       break;
4195
4196     case GFC_ISYM_ACCESS:
4197     case GFC_ISYM_CHDIR:
4198     case GFC_ISYM_CHMOD:
4199     case GFC_ISYM_ETIME:
4200     case GFC_ISYM_FGET:
4201     case GFC_ISYM_FGETC:
4202     case GFC_ISYM_FNUM:
4203     case GFC_ISYM_FPUT:
4204     case GFC_ISYM_FPUTC:
4205     case GFC_ISYM_FSTAT:
4206     case GFC_ISYM_FTELL:
4207     case GFC_ISYM_GETCWD:
4208     case GFC_ISYM_GETGID:
4209     case GFC_ISYM_GETPID:
4210     case GFC_ISYM_GETUID:
4211     case GFC_ISYM_HOSTNM:
4212     case GFC_ISYM_KILL:
4213     case GFC_ISYM_IERRNO:
4214     case GFC_ISYM_IRAND:
4215     case GFC_ISYM_ISATTY:
4216     case GFC_ISYM_LINK:
4217     case GFC_ISYM_LSTAT:
4218     case GFC_ISYM_MALLOC:
4219     case GFC_ISYM_MATMUL:
4220     case GFC_ISYM_MCLOCK:
4221     case GFC_ISYM_MCLOCK8:
4222     case GFC_ISYM_RAND:
4223     case GFC_ISYM_RENAME:
4224     case GFC_ISYM_SECOND:
4225     case GFC_ISYM_SECNDS:
4226     case GFC_ISYM_SIGNAL:
4227     case GFC_ISYM_STAT:
4228     case GFC_ISYM_SYMLNK:
4229     case GFC_ISYM_SYSTEM:
4230     case GFC_ISYM_TIME:
4231     case GFC_ISYM_TIME8:
4232     case GFC_ISYM_UMASK:
4233     case GFC_ISYM_UNLINK:
4234       gfc_conv_intrinsic_funcall (se, expr);
4235       break;
4236
4237     default:
4238       gfc_conv_intrinsic_lib_function (se, expr);
4239       break;
4240     }
4241 }
4242
4243
4244 /* This generates code to execute before entering the scalarization loop.
4245    Currently does nothing.  */
4246
4247 void
4248 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4249 {
4250   switch (ss->expr->value.function.isym->id)
4251     {
4252     case GFC_ISYM_UBOUND:
4253     case GFC_ISYM_LBOUND:
4254       break;
4255
4256     default:
4257       gcc_unreachable ();
4258     }
4259 }
4260
4261
4262 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4263    inside the scalarization loop.  */
4264
4265 static gfc_ss *
4266 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4267 {
4268   gfc_ss *newss;
4269
4270   /* The two argument version returns a scalar.  */
4271   if (expr->value.function.actual->next->expr)
4272     return ss;
4273
4274   newss = gfc_get_ss ();
4275   newss->type = GFC_SS_INTRINSIC;
4276   newss->expr = expr;
4277   newss->next = ss;
4278   newss->data.info.dimen = 1;
4279
4280   return newss;
4281 }
4282
4283
4284 /* Walk an intrinsic array libcall.  */
4285
4286 static gfc_ss *
4287 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4288 {
4289   gfc_ss *newss;
4290
4291   gcc_assert (expr->rank > 0);
4292
4293   newss = gfc_get_ss ();
4294   newss->type = GFC_SS_FUNCTION;
4295   newss->expr = expr;
4296   newss->next = ss;
4297   newss->data.info.dimen = expr->rank;
4298
4299   return newss;
4300 }
4301
4302
4303 /* Returns nonzero if the specified intrinsic function call maps directly to a
4304    an external library call.  Should only be used for functions that return
4305    arrays.  */
4306
4307 int
4308 gfc_is_intrinsic_libcall (gfc_expr * expr)
4309 {
4310   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4311   gcc_assert (expr->rank > 0);
4312
4313   switch (expr->value.function.isym->id)
4314     {
4315     case GFC_ISYM_ALL:
4316     case GFC_ISYM_ANY:
4317     case GFC_ISYM_COUNT:
4318     case GFC_ISYM_MATMUL:
4319     case GFC_ISYM_MAXLOC:
4320     case GFC_ISYM_MAXVAL:
4321     case GFC_ISYM_MINLOC:
4322     case GFC_ISYM_MINVAL:
4323     case GFC_ISYM_PRODUCT:
4324     case GFC_ISYM_SUM:
4325     case GFC_ISYM_SHAPE:
4326     case GFC_ISYM_SPREAD:
4327     case GFC_ISYM_TRANSPOSE:
4328       /* Ignore absent optional parameters.  */
4329       return 1;
4330
4331     case GFC_ISYM_RESHAPE:
4332     case GFC_ISYM_CSHIFT:
4333     case GFC_ISYM_EOSHIFT:
4334     case GFC_ISYM_PACK:
4335     case GFC_ISYM_UNPACK:
4336       /* Pass absent optional parameters.  */
4337       return 2;
4338
4339     default:
4340       return 0;
4341     }
4342 }
4343
4344 /* Walk an intrinsic function.  */
4345 gfc_ss *
4346 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4347                              gfc_intrinsic_sym * isym)
4348 {
4349   gcc_assert (isym);
4350
4351   if (isym->elemental)
4352     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4353
4354   if (expr->rank == 0)
4355     return ss;
4356
4357   if (gfc_is_intrinsic_libcall (expr))
4358     return gfc_walk_intrinsic_libfunc (ss, expr);
4359
4360   /* Special cases.  */
4361   switch (isym->id)
4362     {
4363     case GFC_ISYM_LBOUND:
4364     case GFC_ISYM_UBOUND:
4365       return gfc_walk_intrinsic_bound (ss, expr);
4366
4367     case GFC_ISYM_TRANSFER:
4368       return gfc_walk_intrinsic_libfunc (ss, expr);
4369
4370     default:
4371       /* This probably meant someone forgot to add an intrinsic to the above
4372          list(s) when they implemented it, or something's gone horribly wrong.
4373        */
4374       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4375                       expr->value.function.name);
4376     }
4377 }
4378
4379 #include "gt-fortran-trans-intrinsic.h"