gcc/fortran/trans-intrinsic.c

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