gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
   3    Contributed by Paul Brook <paul@nowt.org>
   4    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.  */
  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 "tree.h"
  29 #include <stdio.h>
  30 #include <string.h>
  31 #include "ggc.h"
  32 #include "toplev.h"
  33 #include "real.h"
  34 #include "tree-gimple.h"
  35 #include "flags.h"
  36 #include "gfortran.h"
  37 #include "arith.h"
  38 #include "intrinsic.h"
  39 #include "trans.h"
  40 #include "trans-const.h"
  41 #include "trans-types.h"
  42 #include "trans-array.h"
  43 #include "defaults.h"
  44 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  45 #include "trans-stmt.h"
  46
  47 /* This maps fortran intrinsic math functions to external library or GCC
  48    builtin functions.  */
  49 typedef struct gfc_intrinsic_map_t      GTY(())
  50 {
  51   /* The explicit enum is required to work around inadequacies in the
  52      garbage collection/gengtype parsing mechanism.  */
  53   enum gfc_generic_isym_id id;
  54
  55   /* Enum value from the "language-independent", aka C-centric, part
  56      of gcc, or END_BUILTINS of no such value set.  */
  57   /* ??? There are now complex variants in builtins.def, though we
  58      don't currently do anything with them.  */
  59   enum built_in_function code4;
  60   enum built_in_function code8;
  61
  62   /* True if the naming pattern is to prepend "c" for complex and
  63      append "f" for kind=4.  False if the naming pattern is to
  64      prepend "_gfortran_" and append "[rc][48]".  */
  65   bool libm_name;
  66
  67   /* True if a complex version of the function exists.  */
  68   bool complex_available;
  69
  70   /* True if the function should be marked const.  */
  71   bool is_constant;
  72
  73   /* The base library name of this function.  */
  74   const char *name;
  75
  76   /* Cache decls created for the various operand types.  */
  77   tree real4_decl;
  78   tree real8_decl;
  79   tree complex4_decl;
  80   tree complex8_decl;
  81 }
  82 gfc_intrinsic_map_t;
  83
  84 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  85    defines complex variants of all of the entries in mathbuiltins.def
  86    except for atan2.  */
  87 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  88   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
  89     HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  90
  91 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
  92   BUILT_IN_FUNCTION (id, name, false)
  93
  94 /* TODO: Use builtin function for complex intrinsics.  */
  95 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
  96   BUILT_IN_FUNCTION (id, name, true)
  97
  98 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  99   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
 100     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 101
 102 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 103   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
 104     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 105
 106 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 107 {
 108   /* Functions built into gcc itself.  */
 109 #include "mathbuiltins.def"
 110
 111   /* Functions in libm.  */
 112   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 113      pattern for other mathbuiltins.def entries.  At present we have no
 114      optimizations for this in the common sources.  */
 115   LIBM_FUNCTION (SCALE, "scalbn", false),
 116
 117   /* Functions in libgfortran.  */
 118   LIBF_FUNCTION (FRACTION, "fraction", false),
 119   LIBF_FUNCTION (NEAREST, "nearest", false),
 120   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 121
 122   /* End the list.  */
 123   LIBF_FUNCTION (NONE, NULL, false)
 124 };
 125 #undef DEFINE_MATH_BUILTIN
 126 #undef DEFINE_MATH_BUILTIN_C
 127 #undef BUILT_IN_FUNCTION
 128 #undef LIBM_FUNCTION
 129 #undef LIBF_FUNCTION
 130
 131 /* Structure for storing components of a floating number to be used by
 132    elemental functions to manipulate reals.  */
 133 typedef struct
 134 {
 135   tree arg;     /* Variable tree to view convert to integer.   */
 136   tree expn;    /* Variable tree to save exponent.  */
 137   tree frac;    /* Variable tree to save fraction.  */
 138   tree smask;   /* Constant tree of sign's mask.  */
 139   tree emask;   /* Constant tree of exponent's mask.  */
 140   tree fmask;   /* Constant tree of fraction's mask.  */
 141   tree edigits; /* Constant tree of bit numbers of exponent.  */
 142   tree fdigits; /* Constant tree of bit numbers of fraction.  */
 143   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 144   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 145   tree type;    /* Type tree of arg1.  */
 146   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 147 }
 148 real_compnt_info;
 149
 150
 151 /* Evaluate the arguments to an intrinsic function.  */
 152
 153 static tree
 154 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 155 {
 156   gfc_actual_arglist *actual;
 157   tree args;
 158   gfc_se argse;
 159
 160   args = NULL_TREE;
 161   for (actual = expr->value.function.actual; actual; actual = actual->next)
 162     {
 163       /* Skip ommitted optional arguments.  */
 164       if (!actual->expr)
 165         continue;
 166
 167       /* Evaluate the parameter.  This will substitute scalarized
 168          references automatically. */
 169       gfc_init_se (&argse, se);
 170
 171       if (actual->expr->ts.type == BT_CHARACTER)
 172         {
 173           gfc_conv_expr (&argse, actual->expr);
 174           gfc_conv_string_parameter (&argse);
 175           args = gfc_chainon_list (args, argse.string_length);
 176         }
 177       else
 178         gfc_conv_expr_val (&argse, actual->expr);
 179
 180       gfc_add_block_to_block (&se->pre, &argse.pre);
 181       gfc_add_block_to_block (&se->post, &argse.post);
 182       args = gfc_chainon_list (args, argse.expr);
 183     }
 184   return args;
 185 }
 186
 187
 188 /* Conversions between different types are output by the frontend as
 189    intrinsic functions.  We implement these directly with inline code.  */
 190
 191 static void
 192 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 193 {
 194   tree type;
 195   tree arg;
 196
 197   /* Evaluate the argument.  */
 198   type = gfc_typenode_for_spec (&expr->ts);
 199   gcc_assert (expr->value.function.actual->expr);
 200   arg = gfc_conv_intrinsic_function_args (se, expr);
 201   arg = TREE_VALUE (arg);
 202
 203   /* Conversion from complex to non-complex involves taking the real
 204      component of the value.  */
 205   if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 206       && expr->ts.type != BT_COMPLEX)
 207     {
 208       tree artype;
 209
 210       artype = TREE_TYPE (TREE_TYPE (arg));
 211       arg = build1 (REALPART_EXPR, artype, arg);
 212     }
 213
 214   se->expr = convert (type, arg);
 215 }
 216
 217
 218 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 219    TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 220    Similarly for CEILING.  */
 221
 222 static tree
 223 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 224 {
 225   tree tmp;
 226   tree cond;
 227   tree argtype;
 228   tree intval;
 229
 230   argtype = TREE_TYPE (arg);
 231   arg = gfc_evaluate_now (arg, pblock);
 232
 233   intval = convert (type, arg);
 234   intval = gfc_evaluate_now (intval, pblock);
 235
 236   tmp = convert (argtype, intval);
 237   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 238
 239   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 240                 convert (type, integer_one_node));
 241   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 242   return tmp;
 243 }
 244
 245
 246 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 247    NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
 248
 249 static tree
 250 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 251 {
 252   tree tmp;
 253   tree cond;
 254   tree neg;
 255   tree pos;
 256   tree argtype;
 257   REAL_VALUE_TYPE r;
 258
 259   argtype = TREE_TYPE (arg);
 260   arg = gfc_evaluate_now (arg, pblock);
 261
 262   real_from_string (&r, "0.5");
 263   pos = build_real (argtype, r);
 264
 265   real_from_string (&r, "-0.5");
 266   neg = build_real (argtype, r);
 267
 268   tmp = gfc_build_const (argtype, integer_zero_node);
 269   cond = fold (build2 (GT_EXPR, boolean_type_node, arg, tmp));
 270
 271   tmp = fold (build3 (COND_EXPR, argtype, cond, pos, neg));
 272   tmp = fold (build2 (PLUS_EXPR, argtype, arg, tmp));
 273   return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
 274 }
 275
 276
 277 /* Convert a real to an integer using a specific rounding mode.
 278    Ideally we would just build the corresponding GENERIC node,
 279    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 280
 281 static tree
 282 build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
 283 {
 284   switch (op)
 285     {
 286     case FIX_FLOOR_EXPR:
 287       return build_fixbound_expr (pblock, arg, type, 0);
 288       break;
 289
 290     case FIX_CEIL_EXPR:
 291       return build_fixbound_expr (pblock, arg, type, 1);
 292       break;
 293
 294     case FIX_ROUND_EXPR:
 295       return build_round_expr (pblock, arg, type);
 296
 297     default:
 298       return build1 (op, type, arg);
 299     }
 300 }
 301
 302
 303 /* Round a real value using the specified rounding mode.
 304    We use a temporary integer of that same kind size as the result.
 305    Values larger than can be represented by this kind are unchanged, as
 306    will not be accurate enough to represent the rounding.
 307     huge = HUGE (KIND (a))
 308     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 309    */
 310
 311 static void
 312 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
 313 {
 314   tree type;
 315   tree itype;
 316   tree arg;
 317   tree tmp;
 318   tree cond;
 319   mpfr_t huge;
 320   int n;
 321   int kind;
 322
 323   kind = expr->ts.kind;
 324
 325   n = END_BUILTINS;
 326   /* We have builtin functions for some cases.  */
 327   switch (op)
 328     {
 329     case FIX_ROUND_EXPR:
 330       switch (kind)
 331         {
 332         case 4:
 333           n = BUILT_IN_ROUNDF;
 334           break;
 335
 336         case 8:
 337           n = BUILT_IN_ROUND;
 338           break;
 339         }
 340       break;
 341
 342     case FIX_FLOOR_EXPR:
 343       switch (kind)
 344         {
 345         case 4:
 346           n = BUILT_IN_FLOORF;
 347           break;
 348
 349         case 8:
 350           n = BUILT_IN_FLOOR;
 351           break;
 352         }
 353     }
 354
 355   /* Evaluate the argument.  */
 356   gcc_assert (expr->value.function.actual->expr);
 357   arg = gfc_conv_intrinsic_function_args (se, expr);
 358
 359   /* Use a builtin function if one exists.  */
 360   if (n != END_BUILTINS)
 361     {
 362       tmp = built_in_decls[n];
 363       se->expr = gfc_build_function_call (tmp, arg);
 364       return;
 365     }
 366
 367   /* This code is probably redundant, but we'll keep it lying around just
 368      in case.  */
 369   type = gfc_typenode_for_spec (&expr->ts);
 370   arg = TREE_VALUE (arg);
 371   arg = gfc_evaluate_now (arg, &se->pre);
 372
 373   /* Test if the value is too large to handle sensibly.  */
 374   gfc_set_model_kind (kind);
 375   mpfr_init (huge);
 376   n = gfc_validate_kind (BT_INTEGER, kind, false);
 377   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 378   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 379   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
 380
 381   mpfr_neg (huge, huge, GFC_RND_MODE);
 382   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 383   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
 384   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 385   itype = gfc_get_int_type (kind);
 386
 387   tmp = build_fix_expr (&se->pre, arg, itype, op);
 388   tmp = convert (type, tmp);
 389   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
 390   mpfr_clear (huge);
 391 }
 392
 393
 394 /* Convert to an integer using the specified rounding mode.  */
 395
 396 static void
 397 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
 398 {
 399   tree type;
 400   tree arg;
 401
 402   /* Evaluate the argument.  */
 403   type = gfc_typenode_for_spec (&expr->ts);
 404   gcc_assert (expr->value.function.actual->expr);
 405   arg = gfc_conv_intrinsic_function_args (se, expr);
 406   arg = TREE_VALUE (arg);
 407
 408   if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
 409     {
 410       /* Conversion to a different integer kind.  */
 411       se->expr = convert (type, arg);
 412     }
 413   else
 414     {
 415       /* Conversion from complex to non-complex involves taking the real
 416          component of the value.  */
 417       if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 418           && expr->ts.type != BT_COMPLEX)
 419         {
 420           tree artype;
 421
 422           artype = TREE_TYPE (TREE_TYPE (arg));
 423           arg = build1 (REALPART_EXPR, artype, arg);
 424         }
 425
 426       se->expr = build_fix_expr (&se->pre, arg, type, op);
 427     }
 428 }
 429
 430
 431 /* Get the imaginary component of a value.  */
 432
 433 static void
 434 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 435 {
 436   tree arg;
 437
 438   arg = gfc_conv_intrinsic_function_args (se, expr);
 439   arg = TREE_VALUE (arg);
 440   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 441 }
 442
 443
 444 /* Get the complex conjugate of a value.  */
 445
 446 static void
 447 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 448 {
 449   tree arg;
 450
 451   arg = gfc_conv_intrinsic_function_args (se, expr);
 452   arg = TREE_VALUE (arg);
 453   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 454 }
 455
 456
 457 /* Initialize function decls for library functions.  The external functions
 458    are created as required.  Builtin functions are added here.  */
 459
 460 void
 461 gfc_build_intrinsic_lib_fndecls (void)
 462 {
 463   gfc_intrinsic_map_t *m;
 464
 465   /* Add GCC builtin functions.  */
 466   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 467     {
 468       if (m->code4 != END_BUILTINS)
 469         m->real4_decl = built_in_decls[m->code4];
 470       if (m->code8 != END_BUILTINS)
 471         m->real8_decl = built_in_decls[m->code8];
 472     }
 473 }
 474
 475
 476 /* Create a fndecl for a simple intrinsic library function.  */
 477
 478 static tree
 479 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 480 {
 481   tree type;
 482   tree argtypes;
 483   tree fndecl;
 484   gfc_actual_arglist *actual;
 485   tree *pdecl;
 486   gfc_typespec *ts;
 487   char name[GFC_MAX_SYMBOL_LEN + 3];
 488
 489   ts = &expr->ts;
 490   if (ts->type == BT_REAL)
 491     {
 492       switch (ts->kind)
 493         {
 494         case 4:
 495           pdecl = &m->real4_decl;
 496           break;
 497         case 8:
 498           pdecl = &m->real8_decl;
 499           break;
 500         default:
 501           gcc_unreachable ();
 502         }
 503     }
 504   else if (ts->type == BT_COMPLEX)
 505     {
 506       gcc_assert (m->complex_available);
 507
 508       switch (ts->kind)
 509         {
 510         case 4:
 511           pdecl = &m->complex4_decl;
 512           break;
 513         case 8:
 514           pdecl = &m->complex8_decl;
 515           break;
 516         default:
 517           gcc_unreachable ();
 518         }
 519     }
 520   else
 521     gcc_unreachable ();
 522
 523   if (*pdecl)
 524     return *pdecl;
 525
 526   if (m->libm_name)
 527     {
 528       gcc_assert (ts->kind == 4 || ts->kind == 8);
 529       snprintf (name, sizeof (name), "%s%s%s",
 530                 ts->type == BT_COMPLEX ? "c" : "",
 531                 m->name,
 532                 ts->kind == 4 ? "f" : "");
 533     }
 534   else
 535     {
 536       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 537                 ts->type == BT_COMPLEX ? 'c' : 'r',
 538                 ts->kind);
 539     }
 540
 541   argtypes = NULL_TREE;
 542   for (actual = expr->value.function.actual; actual; actual = actual->next)
 543     {
 544       type = gfc_typenode_for_spec (&actual->expr->ts);
 545       argtypes = gfc_chainon_list (argtypes, type);
 546     }
 547   argtypes = gfc_chainon_list (argtypes, void_type_node);
 548   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 549   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 550
 551   /* Mark the decl as external.  */
 552   DECL_EXTERNAL (fndecl) = 1;
 553   TREE_PUBLIC (fndecl) = 1;
 554
 555   /* Mark it __attribute__((const)), if possible.  */
 556   TREE_READONLY (fndecl) = m->is_constant;
 557
 558   rest_of_decl_compilation (fndecl, 1, 0);
 559
 560   (*pdecl) = fndecl;
 561   return fndecl;
 562 }
 563
 564
 565 /* Convert an intrinsic function into an external or builtin call.  */
 566
 567 static void
 568 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 569 {
 570   gfc_intrinsic_map_t *m;
 571   tree args;
 572   tree fndecl;
 573   gfc_generic_isym_id id;
 574
 575   id = expr->value.function.isym->generic_id;
 576   /* Find the entry for this function.  */
 577   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 578     {
 579       if (id == m->id)
 580         break;
 581     }
 582
 583   if (m->id == GFC_ISYM_NONE)
 584     {
 585       internal_error ("Intrinsic function %s(%d) not recognized",
 586                       expr->value.function.name, id);
 587     }
 588
 589   /* Get the decl and generate the call.  */
 590   args = gfc_conv_intrinsic_function_args (se, expr);
 591   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 592   se->expr = gfc_build_function_call (fndecl, args);
 593 }
 594
 595 /* Generate code for EXPONENT(X) intrinsic function.  */
 596
 597 static void
 598 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
 599 {
 600   tree args, fndecl;
 601   gfc_expr *a1;
 602
 603   args = gfc_conv_intrinsic_function_args (se, expr);
 604
 605   a1 = expr->value.function.actual->expr;
 606   switch (a1->ts.kind)
 607     {
 608     case 4:
 609       fndecl = gfor_fndecl_math_exponent4;
 610       break;
 611     case 8:
 612       fndecl = gfor_fndecl_math_exponent8;
 613       break;
 614     default:
 615       gcc_unreachable ();
 616     }
 617
 618   se->expr = gfc_build_function_call (fndecl, args);
 619 }
 620
 621 /* Evaluate a single upper or lower bound.  */
 622 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 623
 624 static void
 625 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 626 {
 627   gfc_actual_arglist *arg;
 628   gfc_actual_arglist *arg2;
 629   tree desc;
 630   tree type;
 631   tree bound;
 632   tree tmp;
 633   tree cond;
 634   gfc_se argse;
 635   gfc_ss *ss;
 636   int i;
 637
 638   gfc_init_se (&argse, NULL);
 639   arg = expr->value.function.actual;
 640   arg2 = arg->next;
 641
 642   if (se->ss)
 643     {
 644       /* Create an implicit second parameter from the loop variable.  */
 645       gcc_assert (!arg2->expr);
 646       gcc_assert (se->loop->dimen == 1);
 647       gcc_assert (se->ss->expr == expr);
 648       gfc_advance_se_ss_chain (se);
 649       bound = se->loop->loopvar[0];
 650       bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
 651                             se->loop->from[0]));
 652     }
 653   else
 654     {
 655       /* use the passed argument.  */
 656       gcc_assert (arg->next->expr);
 657       gfc_init_se (&argse, NULL);
 658       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 659       gfc_add_block_to_block (&se->pre, &argse.pre);
 660       bound = argse.expr;
 661       /* Convert from one based to zero based.  */
 662       bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
 663                             gfc_index_one_node));
 664     }
 665
 666   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 667   /* Get a descriptor for the first parameter.  */
 668   ss = gfc_walk_expr (arg->expr);
 669   gcc_assert (ss != gfc_ss_terminator);
 670   argse.want_pointer = 0;
 671   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 672   gfc_add_block_to_block (&se->pre, &argse.pre);
 673   gfc_add_block_to_block (&se->post, &argse.post);
 674
 675   desc = argse.expr;
 676
 677   if (INTEGER_CST_P (bound))
 678     {
 679       gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
 680       i = TREE_INT_CST_LOW (bound);
 681       gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
 682     }
 683   else
 684     {
 685       if (flag_bounds_check)
 686         {
 687           bound = gfc_evaluate_now (bound, &se->pre);
 688           cond = fold (build2 (LT_EXPR, boolean_type_node,
 689                                bound, convert (TREE_TYPE (bound),
 690                                                integer_zero_node)));
 691           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 692           tmp = fold (build2 (GE_EXPR, boolean_type_node, bound, tmp));
 693           cond = fold(build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
 694           gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
 695         }
 696     }
 697
 698   if (upper)
 699     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 700   else
 701     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 702
 703   type = gfc_typenode_for_spec (&expr->ts);
 704   se->expr = convert (type, se->expr);
 705 }
 706
 707
 708 static void
 709 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 710 {
 711   tree args;
 712   tree val;
 713   int n;
 714
 715   args = gfc_conv_intrinsic_function_args (se, expr);
 716   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
 717   val = TREE_VALUE (args);
 718
 719   switch (expr->value.function.actual->expr->ts.type)
 720     {
 721     case BT_INTEGER:
 722     case BT_REAL:
 723       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 724       break;
 725
 726     case BT_COMPLEX:
 727       switch (expr->ts.kind)
 728         {
 729         case 4:
 730           n = BUILT_IN_CABSF;
 731           break;
 732         case 8:
 733           n = BUILT_IN_CABS;
 734           break;
 735         default:
 736           gcc_unreachable ();
 737         }
 738       se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
 739       break;
 740
 741     default:
 742       gcc_unreachable ();
 743     }
 744 }
 745
 746
 747 /* Create a complex value from one or two real components.  */
 748
 749 static void
 750 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 751 {
 752   tree arg;
 753   tree real;
 754   tree imag;
 755   tree type;
 756
 757   type = gfc_typenode_for_spec (&expr->ts);
 758   arg = gfc_conv_intrinsic_function_args (se, expr);
 759   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 760   if (both)
 761     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 762   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 763     {
 764       arg = TREE_VALUE (arg);
 765       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 766       imag = convert (TREE_TYPE (type), imag);
 767     }
 768   else
 769     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 770
 771   se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
 772 }
 773
 774 /* Remainder function MOD(A, P) = A - INT(A / P) * P.
 775    MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P.  */
 776 /* TODO: MOD(x, 0)  */
 777
 778 static void
 779 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 780 {
 781   tree arg;
 782   tree arg2;
 783   tree type;
 784   tree itype;
 785   tree tmp;
 786   tree zero;
 787   tree test;
 788   tree test2;
 789   mpfr_t huge;
 790   int n;
 791
 792   arg = gfc_conv_intrinsic_function_args (se, expr);
 793   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 794   arg = TREE_VALUE (arg);
 795   type = TREE_TYPE (arg);
 796
 797   switch (expr->ts.type)
 798     {
 799     case BT_INTEGER:
 800       /* Integer case is easy, we've got a builtin op.  */
 801       se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
 802       break;
 803
 804     case BT_REAL:
 805       /* Real values we have to do the hard way.  */
 806       arg = gfc_evaluate_now (arg, &se->pre);
 807       arg2 = gfc_evaluate_now (arg2, &se->pre);
 808
 809       tmp = build2 (RDIV_EXPR, type, arg, arg2);
 810       /* Test if the value is too large to handle sensibly.  */
 811       gfc_set_model_kind (expr->ts.kind);
 812       mpfr_init (huge);
 813       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
 814       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 815       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 816       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 817
 818       mpfr_neg (huge, huge, GFC_RND_MODE);
 819       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 820       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 821       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 822
 823       itype = gfc_get_int_type (expr->ts.kind);
 824       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 825       tmp = convert (type, tmp);
 826       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 827       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 828       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 829       mpfr_clear (huge);
 830       break;
 831
 832     default:
 833       gcc_unreachable ();
 834     }
 835
 836   if (modulo)
 837     {
 838      zero = gfc_build_const (type, integer_zero_node);
 839      /* Build !(A > 0 .xor. P > 0).  */
 840      test = build2 (GT_EXPR, boolean_type_node, arg, zero);
 841      test2 = build2 (GT_EXPR, boolean_type_node, arg2, zero);
 842      test = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
 843      test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test);
 844      /* Build (A == 0) .or. !(A > 0 .xor. P > 0).  */
 845      test2 = build2 (EQ_EXPR, boolean_type_node, arg, zero);
 846      test = build2 (TRUTH_OR_EXPR, boolean_type_node, test, test2);
 847
 848      se->expr = build3 (COND_EXPR, type, test, se->expr,
 849                         build2 (PLUS_EXPR, type, se->expr, arg2));
 850     }
 851 }
 852
 853 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 854
 855 static void
 856 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 857 {
 858   tree arg;
 859   tree arg2;
 860   tree val;
 861   tree tmp;
 862   tree type;
 863   tree zero;
 864
 865   arg = gfc_conv_intrinsic_function_args (se, expr);
 866   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 867   arg = TREE_VALUE (arg);
 868   type = TREE_TYPE (arg);
 869
 870   val = build2 (MINUS_EXPR, type, arg, arg2);
 871   val = gfc_evaluate_now (val, &se->pre);
 872
 873   zero = gfc_build_const (type, integer_zero_node);
 874   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 875   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 876 }
 877
 878
 879 /* SIGN(A, B) is absolute value of A times sign of B.
 880    The real value versions use library functions to ensure the correct
 881    handling of negative zero.  Integer case implemented as:
 882    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 883   */
 884
 885 static void
 886 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 887 {
 888   tree tmp;
 889   tree arg;
 890   tree arg2;
 891   tree type;
 892   tree zero;
 893   tree testa;
 894   tree testb;
 895
 896
 897   arg = gfc_conv_intrinsic_function_args (se, expr);
 898   if (expr->ts.type == BT_REAL)
 899     {
 900       switch (expr->ts.kind)
 901         {
 902         case 4:
 903           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 904           break;
 905         case 8:
 906           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 907           break;
 908         default:
 909           gcc_unreachable ();
 910         }
 911       se->expr = fold (gfc_build_function_call (tmp, arg));
 912       return;
 913     }
 914
 915   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 916   arg = TREE_VALUE (arg);
 917   type = TREE_TYPE (arg);
 918   zero = gfc_build_const (type, integer_zero_node);
 919
 920   testa = fold (build2 (GE_EXPR, boolean_type_node, arg, zero));
 921   testb = fold (build2 (GE_EXPR, boolean_type_node, arg2, zero));
 922   tmp = fold (build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
 923   se->expr = fold (build3 (COND_EXPR, type, tmp,
 924                            build1 (NEGATE_EXPR, type, arg), arg));
 925 }
 926
 927
 928 /* Test for the presence of an optional argument.  */
 929
 930 static void
 931 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 932 {
 933   gfc_expr *arg;
 934
 935   arg = expr->value.function.actual->expr;
 936   gcc_assert (arg->expr_type == EXPR_VARIABLE);
 937   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
 938   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 939 }
 940
 941
 942 /* Calculate the double precision product of two single precision values.  */
 943
 944 static void
 945 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 946 {
 947   tree arg;
 948   tree arg2;
 949   tree type;
 950
 951   arg = gfc_conv_intrinsic_function_args (se, expr);
 952   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 953   arg = TREE_VALUE (arg);
 954
 955   /* Convert the args to double precision before multiplying.  */
 956   type = gfc_typenode_for_spec (&expr->ts);
 957   arg = convert (type, arg);
 958   arg2 = convert (type, arg2);
 959   se->expr = build2 (MULT_EXPR, type, arg, arg2);
 960 }
 961
 962
 963 /* Return a length one character string containing an ascii character.  */
 964
 965 static void
 966 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 967 {
 968   tree arg;
 969   tree var;
 970   tree type;
 971
 972   arg = gfc_conv_intrinsic_function_args (se, expr);
 973   arg = TREE_VALUE (arg);
 974
 975   /* We currently don't support character types != 1.  */
 976   gcc_assert (expr->ts.kind == 1);
 977   type = gfc_character1_type_node;
 978   var = gfc_create_var (type, "char");
 979
 980   arg = convert (type, arg);
 981   gfc_add_modify_expr (&se->pre, var, arg);
 982   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
 983   se->string_length = integer_one_node;
 984 }
 985
 986
 987 /* Get the minimum/maximum value of all the parameters.
 988     minmax (a1, a2, a3, ...)
 989     {
 990       if (a2 .op. a1)
 991         mvar = a2;
 992       else
 993         mvar = a1;
 994       if (a3 .op. mvar)
 995         mvar = a3;
 996       ...
 997       return mvar
 998     }
 999  */
1000
1001 /* TODO: Mismatching types can occur when specific names are used.
1002    These should be handled during resolution.  */
1003 static void
1004 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1005 {
1006   tree limit;
1007   tree tmp;
1008   tree mvar;
1009   tree val;
1010   tree thencase;
1011   tree elsecase;
1012   tree arg;
1013   tree type;
1014
1015   arg = gfc_conv_intrinsic_function_args (se, expr);
1016   type = gfc_typenode_for_spec (&expr->ts);
1017
1018   limit = TREE_VALUE (arg);
1019   if (TREE_TYPE (limit) != type)
1020     limit = convert (type, limit);
1021   /* Only evaluate the argument once.  */
1022   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1023     limit = gfc_evaluate_now(limit, &se->pre);
1024
1025   mvar = gfc_create_var (type, "M");
1026   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1027   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1028     {
1029       val = TREE_VALUE (arg);
1030       if (TREE_TYPE (val) != type)
1031         val = convert (type, val);
1032
1033       /* Only evaluate the argument once.  */
1034       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1035         val = gfc_evaluate_now(val, &se->pre);
1036
1037       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1038
1039       tmp = build2 (op, boolean_type_node, val, limit);
1040       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1041       gfc_add_expr_to_block (&se->pre, tmp);
1042       elsecase = build_empty_stmt ();
1043       limit = mvar;
1044     }
1045   se->expr = mvar;
1046 }
1047
1048
1049 /* Create a symbol node for this intrinsic.  The symbol form the frontend
1050    is for the generic name.  */
1051
1052 static gfc_symbol *
1053 gfc_get_symbol_for_expr (gfc_expr * expr)
1054 {
1055   gfc_symbol *sym;
1056
1057   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1058   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1059   sym = gfc_new_symbol (expr->value.function.name, NULL);
1060
1061   sym->ts = expr->ts;
1062   sym->attr.external = 1;
1063   sym->attr.function = 1;
1064   sym->attr.always_explicit = 1;
1065   sym->attr.proc = PROC_INTRINSIC;
1066   sym->attr.flavor = FL_PROCEDURE;
1067   sym->result = sym;
1068   if (expr->rank > 0)
1069     {
1070       sym->attr.dimension = 1;
1071       sym->as = gfc_get_array_spec ();
1072       sym->as->type = AS_ASSUMED_SHAPE;
1073       sym->as->rank = expr->rank;
1074     }
1075
1076   /* TODO: proper argument lists for external intrinsics.  */
1077   return sym;
1078 }
1079
1080 /* Generate a call to an external intrinsic function.  */
1081 static void
1082 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1083 {
1084   gfc_symbol *sym;
1085
1086   gcc_assert (!se->ss || se->ss->expr == expr);
1087
1088   if (se->ss)
1089     gcc_assert (expr->rank > 0);
1090   else
1091     gcc_assert (expr->rank == 0);
1092
1093   sym = gfc_get_symbol_for_expr (expr);
1094   gfc_conv_function_call (se, sym, expr->value.function.actual);
1095   gfc_free (sym);
1096 }
1097
1098 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1099    Implemented as
1100     any(a)
1101     {
1102       forall (i=...)
1103         if (a[i] != 0)
1104           return 1
1105       end forall
1106       return 0
1107     }
1108     all(a)
1109     {
1110       forall (i=...)
1111         if (a[i] == 0)
1112           return 0
1113       end forall
1114       return 1
1115     }
1116  */
1117 static void
1118 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1119 {
1120   tree resvar;
1121   stmtblock_t block;
1122   stmtblock_t body;
1123   tree type;
1124   tree tmp;
1125   tree found;
1126   gfc_loopinfo loop;
1127   gfc_actual_arglist *actual;
1128   gfc_ss *arrayss;
1129   gfc_se arrayse;
1130   tree exit_label;
1131
1132   if (se->ss)
1133     {
1134       gfc_conv_intrinsic_funcall (se, expr);
1135       return;
1136     }
1137
1138   actual = expr->value.function.actual;
1139   type = gfc_typenode_for_spec (&expr->ts);
1140   /* Initialize the result.  */
1141   resvar = gfc_create_var (type, "test");
1142   if (op == EQ_EXPR)
1143     tmp = convert (type, boolean_true_node);
1144   else
1145     tmp = convert (type, boolean_false_node);
1146   gfc_add_modify_expr (&se->pre, resvar, tmp);
1147
1148   /* Walk the arguments.  */
1149   arrayss = gfc_walk_expr (actual->expr);
1150   gcc_assert (arrayss != gfc_ss_terminator);
1151
1152   /* Initialize the scalarizer.  */
1153   gfc_init_loopinfo (&loop);
1154   exit_label = gfc_build_label_decl (NULL_TREE);
1155   TREE_USED (exit_label) = 1;
1156   gfc_add_ss_to_loop (&loop, arrayss);
1157
1158   /* Initialize the loop.  */
1159   gfc_conv_ss_startstride (&loop);
1160   gfc_conv_loop_setup (&loop);
1161
1162   gfc_mark_ss_chain_used (arrayss, 1);
1163   /* Generate the loop body.  */
1164   gfc_start_scalarized_body (&loop, &body);
1165
1166   /* If the condition matches then set the return value.  */
1167   gfc_start_block (&block);
1168   if (op == EQ_EXPR)
1169     tmp = convert (type, boolean_false_node);
1170   else
1171     tmp = convert (type, boolean_true_node);
1172   gfc_add_modify_expr (&block, resvar, tmp);
1173
1174   /* And break out of the loop.  */
1175   tmp = build1_v (GOTO_EXPR, exit_label);
1176   gfc_add_expr_to_block (&block, tmp);
1177
1178   found = gfc_finish_block (&block);
1179
1180   /* Check this element.  */
1181   gfc_init_se (&arrayse, NULL);
1182   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1183   arrayse.ss = arrayss;
1184   gfc_conv_expr_val (&arrayse, actual->expr);
1185
1186   gfc_add_block_to_block (&body, &arrayse.pre);
1187   tmp = build2 (op, boolean_type_node, arrayse.expr,
1188                 fold_convert (TREE_TYPE (arrayse.expr),
1189                               integer_zero_node));
1190   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1191   gfc_add_expr_to_block (&body, tmp);
1192   gfc_add_block_to_block (&body, &arrayse.post);
1193
1194   gfc_trans_scalarizing_loops (&loop, &body);
1195
1196   /* Add the exit label.  */
1197   tmp = build1_v (LABEL_EXPR, exit_label);
1198   gfc_add_expr_to_block (&loop.pre, tmp);
1199
1200   gfc_add_block_to_block (&se->pre, &loop.pre);
1201   gfc_add_block_to_block (&se->pre, &loop.post);
1202   gfc_cleanup_loop (&loop);
1203
1204   se->expr = resvar;
1205 }
1206
1207 /* COUNT(A) = Number of true elements in A.  */
1208 static void
1209 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1210 {
1211   tree resvar;
1212   tree type;
1213   stmtblock_t body;
1214   tree tmp;
1215   gfc_loopinfo loop;
1216   gfc_actual_arglist *actual;
1217   gfc_ss *arrayss;
1218   gfc_se arrayse;
1219
1220   if (se->ss)
1221     {
1222       gfc_conv_intrinsic_funcall (se, expr);
1223       return;
1224     }
1225
1226   actual = expr->value.function.actual;
1227
1228   type = gfc_typenode_for_spec (&expr->ts);
1229   /* Initialize the result.  */
1230   resvar = gfc_create_var (type, "count");
1231   gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
1232
1233   /* Walk the arguments.  */
1234   arrayss = gfc_walk_expr (actual->expr);
1235   gcc_assert (arrayss != gfc_ss_terminator);
1236
1237   /* Initialize the scalarizer.  */
1238   gfc_init_loopinfo (&loop);
1239   gfc_add_ss_to_loop (&loop, arrayss);
1240
1241   /* Initialize the loop.  */
1242   gfc_conv_ss_startstride (&loop);
1243   gfc_conv_loop_setup (&loop);
1244
1245   gfc_mark_ss_chain_used (arrayss, 1);
1246   /* Generate the loop body.  */
1247   gfc_start_scalarized_body (&loop, &body);
1248
1249   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1250                 convert (TREE_TYPE (resvar), integer_one_node));
1251   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1252
1253   gfc_init_se (&arrayse, NULL);
1254   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1255   arrayse.ss = arrayss;
1256   gfc_conv_expr_val (&arrayse, actual->expr);
1257   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1258
1259   gfc_add_block_to_block (&body, &arrayse.pre);
1260   gfc_add_expr_to_block (&body, tmp);
1261   gfc_add_block_to_block (&body, &arrayse.post);
1262
1263   gfc_trans_scalarizing_loops (&loop, &body);
1264
1265   gfc_add_block_to_block (&se->pre, &loop.pre);
1266   gfc_add_block_to_block (&se->pre, &loop.post);
1267   gfc_cleanup_loop (&loop);
1268
1269   se->expr = resvar;
1270 }
1271
1272 /* Inline implementation of the sum and product intrinsics.  */
1273 static void
1274 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1275 {
1276   tree resvar;
1277   tree type;
1278   stmtblock_t body;
1279   stmtblock_t block;
1280   tree tmp;
1281   gfc_loopinfo loop;
1282   gfc_actual_arglist *actual;
1283   gfc_ss *arrayss;
1284   gfc_ss *maskss;
1285   gfc_se arrayse;
1286   gfc_se maskse;
1287   gfc_expr *arrayexpr;
1288   gfc_expr *maskexpr;
1289
1290   if (se->ss)
1291     {
1292       gfc_conv_intrinsic_funcall (se, expr);
1293       return;
1294     }
1295
1296   type = gfc_typenode_for_spec (&expr->ts);
1297   /* Initialize the result.  */
1298   resvar = gfc_create_var (type, "val");
1299   if (op == PLUS_EXPR)
1300     tmp = gfc_build_const (type, integer_zero_node);
1301   else
1302     tmp = gfc_build_const (type, integer_one_node);
1303
1304   gfc_add_modify_expr (&se->pre, resvar, tmp);
1305
1306   /* Walk the arguments.  */
1307   actual = expr->value.function.actual;
1308   arrayexpr = actual->expr;
1309   arrayss = gfc_walk_expr (arrayexpr);
1310   gcc_assert (arrayss != gfc_ss_terminator);
1311
1312   actual = actual->next->next;
1313   gcc_assert (actual);
1314   maskexpr = actual->expr;
1315   if (maskexpr)
1316     {
1317       maskss = gfc_walk_expr (maskexpr);
1318       gcc_assert (maskss != gfc_ss_terminator);
1319     }
1320   else
1321     maskss = NULL;
1322
1323   /* Initialize the scalarizer.  */
1324   gfc_init_loopinfo (&loop);
1325   gfc_add_ss_to_loop (&loop, arrayss);
1326   if (maskss)
1327     gfc_add_ss_to_loop (&loop, maskss);
1328
1329   /* Initialize the loop.  */
1330   gfc_conv_ss_startstride (&loop);
1331   gfc_conv_loop_setup (&loop);
1332
1333   gfc_mark_ss_chain_used (arrayss, 1);
1334   if (maskss)
1335     gfc_mark_ss_chain_used (maskss, 1);
1336   /* Generate the loop body.  */
1337   gfc_start_scalarized_body (&loop, &body);
1338
1339   /* If we have a mask, only add this element if the mask is set.  */
1340   if (maskss)
1341     {
1342       gfc_init_se (&maskse, NULL);
1343       gfc_copy_loopinfo_to_se (&maskse, &loop);
1344       maskse.ss = maskss;
1345       gfc_conv_expr_val (&maskse, maskexpr);
1346       gfc_add_block_to_block (&body, &maskse.pre);
1347
1348       gfc_start_block (&block);
1349     }
1350   else
1351     gfc_init_block (&block);
1352
1353   /* Do the actual summation/product.  */
1354   gfc_init_se (&arrayse, NULL);
1355   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1356   arrayse.ss = arrayss;
1357   gfc_conv_expr_val (&arrayse, arrayexpr);
1358   gfc_add_block_to_block (&block, &arrayse.pre);
1359
1360   tmp = build2 (op, type, resvar, arrayse.expr);
1361   gfc_add_modify_expr (&block, resvar, tmp);
1362   gfc_add_block_to_block (&block, &arrayse.post);
1363
1364   if (maskss)
1365     {
1366       /* We enclose the above in if (mask) {...} .  */
1367       tmp = gfc_finish_block (&block);
1368
1369       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1370     }
1371   else
1372     tmp = gfc_finish_block (&block);
1373   gfc_add_expr_to_block (&body, tmp);
1374
1375   gfc_trans_scalarizing_loops (&loop, &body);
1376   gfc_add_block_to_block (&se->pre, &loop.pre);
1377   gfc_add_block_to_block (&se->pre, &loop.post);
1378   gfc_cleanup_loop (&loop);
1379
1380   se->expr = resvar;
1381 }
1382
1383 static void
1384 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1385 {
1386   stmtblock_t body;
1387   stmtblock_t block;
1388   stmtblock_t ifblock;
1389   tree limit;
1390   tree type;
1391   tree tmp;
1392   tree ifbody;
1393   tree cond;
1394   gfc_loopinfo loop;
1395   gfc_actual_arglist *actual;
1396   gfc_ss *arrayss;
1397   gfc_ss *maskss;
1398   gfc_se arrayse;
1399   gfc_se maskse;
1400   gfc_expr *arrayexpr;
1401   gfc_expr *maskexpr;
1402   tree pos;
1403   int n;
1404
1405   if (se->ss)
1406     {
1407       gfc_conv_intrinsic_funcall (se, expr);
1408       return;
1409     }
1410
1411   /* Initialize the result.  */
1412   pos = gfc_create_var (gfc_array_index_type, "pos");
1413   type = gfc_typenode_for_spec (&expr->ts);
1414
1415   /* Walk the arguments.  */
1416   actual = expr->value.function.actual;
1417   arrayexpr = actual->expr;
1418   arrayss = gfc_walk_expr (arrayexpr);
1419   gcc_assert (arrayss != gfc_ss_terminator);
1420
1421   actual = actual->next->next;
1422   gcc_assert (actual);
1423   maskexpr = actual->expr;
1424   if (maskexpr)
1425     {
1426       maskss = gfc_walk_expr (maskexpr);
1427       gcc_assert (maskss != gfc_ss_terminator);
1428     }
1429   else
1430     maskss = NULL;
1431
1432   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1433   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1434   switch (arrayexpr->ts.type)
1435     {
1436     case BT_REAL:
1437       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1438       break;
1439
1440     case BT_INTEGER:
1441       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1442                                   arrayexpr->ts.kind);
1443       break;
1444
1445     default:
1446       gcc_unreachable ();
1447     }
1448
1449   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1450   if (op == GT_EXPR)
1451     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1452   gfc_add_modify_expr (&se->pre, limit, tmp);
1453
1454   /* Initialize the scalarizer.  */
1455   gfc_init_loopinfo (&loop);
1456   gfc_add_ss_to_loop (&loop, arrayss);
1457   if (maskss)
1458     gfc_add_ss_to_loop (&loop, maskss);
1459
1460   /* Initialize the loop.  */
1461   gfc_conv_ss_startstride (&loop);
1462   gfc_conv_loop_setup (&loop);
1463
1464   gcc_assert (loop.dimen == 1);
1465
1466   /* Initialize the position to the first element.  If the array has zero
1467      size we need to return zero.  Otherwise use the first element of the
1468      array, in case all elements are equal to the limit.
1469      i.e. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1470   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1471                       loop.from[0], gfc_index_one_node));
1472   cond = fold (build2 (GE_EXPR, boolean_type_node,
1473                        loop.to[0], loop.from[0]));
1474   tmp = fold (build3 (COND_EXPR, gfc_array_index_type, cond,
1475                       loop.from[0], tmp));
1476   gfc_add_modify_expr (&loop.pre, pos, tmp);
1477
1478   gfc_mark_ss_chain_used (arrayss, 1);
1479   if (maskss)
1480     gfc_mark_ss_chain_used (maskss, 1);
1481   /* Generate the loop body.  */
1482   gfc_start_scalarized_body (&loop, &body);
1483
1484   /* If we have a mask, only check this element if the mask is set.  */
1485   if (maskss)
1486     {
1487       gfc_init_se (&maskse, NULL);
1488       gfc_copy_loopinfo_to_se (&maskse, &loop);
1489       maskse.ss = maskss;
1490       gfc_conv_expr_val (&maskse, maskexpr);
1491       gfc_add_block_to_block (&body, &maskse.pre);
1492
1493       gfc_start_block (&block);
1494     }
1495   else
1496     gfc_init_block (&block);
1497
1498   /* Compare with the current limit.  */
1499   gfc_init_se (&arrayse, NULL);
1500   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1501   arrayse.ss = arrayss;
1502   gfc_conv_expr_val (&arrayse, arrayexpr);
1503   gfc_add_block_to_block (&block, &arrayse.pre);
1504
1505   /* We do the following if this is a more extreme value.  */
1506   gfc_start_block (&ifblock);
1507
1508   /* Assign the value to the limit...  */
1509   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1510
1511   /* Remember where we are.  */
1512   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1513
1514   ifbody = gfc_finish_block (&ifblock);
1515
1516   /* If it is a more extreme value.  */
1517   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1518   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1519   gfc_add_expr_to_block (&block, tmp);
1520
1521   if (maskss)
1522     {
1523       /* We enclose the above in if (mask) {...}.  */
1524       tmp = gfc_finish_block (&block);
1525
1526       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1527     }
1528   else
1529     tmp = gfc_finish_block (&block);
1530   gfc_add_expr_to_block (&body, tmp);
1531
1532   gfc_trans_scalarizing_loops (&loop, &body);
1533
1534   gfc_add_block_to_block (&se->pre, &loop.pre);
1535   gfc_add_block_to_block (&se->pre, &loop.post);
1536   gfc_cleanup_loop (&loop);
1537
1538   /* Return a value in the range 1..SIZE(array).  */
1539   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1540                       gfc_index_one_node));
1541   tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1542   /* And convert to the required type.  */
1543   se->expr = convert (type, tmp);
1544 }
1545
1546 static void
1547 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1548 {
1549   tree limit;
1550   tree type;
1551   tree tmp;
1552   tree ifbody;
1553   stmtblock_t body;
1554   stmtblock_t block;
1555   gfc_loopinfo loop;
1556   gfc_actual_arglist *actual;
1557   gfc_ss *arrayss;
1558   gfc_ss *maskss;
1559   gfc_se arrayse;
1560   gfc_se maskse;
1561   gfc_expr *arrayexpr;
1562   gfc_expr *maskexpr;
1563   int n;
1564
1565   if (se->ss)
1566     {
1567       gfc_conv_intrinsic_funcall (se, expr);
1568       return;
1569     }
1570
1571   type = gfc_typenode_for_spec (&expr->ts);
1572   /* Initialize the result.  */
1573   limit = gfc_create_var (type, "limit");
1574   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1575   switch (expr->ts.type)
1576     {
1577     case BT_REAL:
1578       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1579       break;
1580
1581     case BT_INTEGER:
1582       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1583       break;
1584
1585     default:
1586       gcc_unreachable ();
1587     }
1588
1589   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1590   if (op == GT_EXPR)
1591     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1592   gfc_add_modify_expr (&se->pre, limit, tmp);
1593
1594   /* Walk the arguments.  */
1595   actual = expr->value.function.actual;
1596   arrayexpr = actual->expr;
1597   arrayss = gfc_walk_expr (arrayexpr);
1598   gcc_assert (arrayss != gfc_ss_terminator);
1599
1600   actual = actual->next->next;
1601   gcc_assert (actual);
1602   maskexpr = actual->expr;
1603   if (maskexpr)
1604     {
1605       maskss = gfc_walk_expr (maskexpr);
1606       gcc_assert (maskss != gfc_ss_terminator);
1607     }
1608   else
1609     maskss = NULL;
1610
1611   /* Initialize the scalarizer.  */
1612   gfc_init_loopinfo (&loop);
1613   gfc_add_ss_to_loop (&loop, arrayss);
1614   if (maskss)
1615     gfc_add_ss_to_loop (&loop, maskss);
1616
1617   /* Initialize the loop.  */
1618   gfc_conv_ss_startstride (&loop);
1619   gfc_conv_loop_setup (&loop);
1620
1621   gfc_mark_ss_chain_used (arrayss, 1);
1622   if (maskss)
1623     gfc_mark_ss_chain_used (maskss, 1);
1624   /* Generate the loop body.  */
1625   gfc_start_scalarized_body (&loop, &body);
1626
1627   /* If we have a mask, only add this element if the mask is set.  */
1628   if (maskss)
1629     {
1630       gfc_init_se (&maskse, NULL);
1631       gfc_copy_loopinfo_to_se (&maskse, &loop);
1632       maskse.ss = maskss;
1633       gfc_conv_expr_val (&maskse, maskexpr);
1634       gfc_add_block_to_block (&body, &maskse.pre);
1635
1636       gfc_start_block (&block);
1637     }
1638   else
1639     gfc_init_block (&block);
1640
1641   /* Compare with the current limit.  */
1642   gfc_init_se (&arrayse, NULL);
1643   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1644   arrayse.ss = arrayss;
1645   gfc_conv_expr_val (&arrayse, arrayexpr);
1646   gfc_add_block_to_block (&block, &arrayse.pre);
1647
1648   /* Assign the value to the limit...  */
1649   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1650
1651   /* If it is a more extreme value.  */
1652   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1653   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1654   gfc_add_expr_to_block (&block, tmp);
1655   gfc_add_block_to_block (&block, &arrayse.post);
1656
1657   tmp = gfc_finish_block (&block);
1658   if (maskss)
1659     /* We enclose the above in if (mask) {...}.  */
1660     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1661   gfc_add_expr_to_block (&body, tmp);
1662
1663   gfc_trans_scalarizing_loops (&loop, &body);
1664
1665   gfc_add_block_to_block (&se->pre, &loop.pre);
1666   gfc_add_block_to_block (&se->pre, &loop.post);
1667   gfc_cleanup_loop (&loop);
1668
1669   se->expr = limit;
1670 }
1671
1672 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1673 static void
1674 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1675 {
1676   tree arg;
1677   tree arg2;
1678   tree type;
1679   tree tmp;
1680
1681   arg = gfc_conv_intrinsic_function_args (se, expr);
1682   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1683   arg = TREE_VALUE (arg);
1684   type = TREE_TYPE (arg);
1685
1686   tmp = build2 (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
1687   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1688   tmp = fold (build2 (NE_EXPR, boolean_type_node, tmp,
1689                       convert (type, integer_zero_node)));
1690   type = gfc_typenode_for_spec (&expr->ts);
1691   se->expr = convert (type, tmp);
1692 }
1693
1694 /* Generate code to perform the specified operation.  */
1695 static void
1696 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1697 {
1698   tree arg;
1699   tree arg2;
1700   tree type;
1701
1702   arg = gfc_conv_intrinsic_function_args (se, expr);
1703   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1704   arg = TREE_VALUE (arg);
1705   type = TREE_TYPE (arg);
1706
1707   se->expr = fold (build2 (op, type, arg, arg2));
1708 }
1709
1710 /* Bitwise not.  */
1711 static void
1712 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1713 {
1714   tree arg;
1715
1716   arg = gfc_conv_intrinsic_function_args (se, expr);
1717   arg = TREE_VALUE (arg);
1718
1719   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1720 }
1721
1722 /* Set or clear a single bit.  */
1723 static void
1724 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1725 {
1726   tree arg;
1727   tree arg2;
1728   tree type;
1729   tree tmp;
1730   int op;
1731
1732   arg = gfc_conv_intrinsic_function_args (se, expr);
1733   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1734   arg = TREE_VALUE (arg);
1735   type = TREE_TYPE (arg);
1736
1737   tmp = fold (build2 (LSHIFT_EXPR, type,
1738                      convert (type, integer_one_node), arg2));
1739   if (set)
1740     op = BIT_IOR_EXPR;
1741   else
1742     {
1743       op = BIT_AND_EXPR;
1744       tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1745     }
1746   se->expr = fold (build2 (op, type, arg, tmp));
1747 }
1748
1749 /* Extract a sequence of bits.
1750     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1751 static void
1752 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1753 {
1754   tree arg;
1755   tree arg2;
1756   tree arg3;
1757   tree type;
1758   tree tmp;
1759   tree mask;
1760
1761   arg = gfc_conv_intrinsic_function_args (se, expr);
1762   arg2 = TREE_CHAIN (arg);
1763   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1764   arg = TREE_VALUE (arg);
1765   arg2 = TREE_VALUE (arg2);
1766   type = TREE_TYPE (arg);
1767
1768   mask = build_int_cst (NULL_TREE, -1);
1769   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1770   mask = build1 (BIT_NOT_EXPR, type, mask);
1771
1772   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1773
1774   se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
1775 }
1776
1777 /* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift.  */
1778 static void
1779 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1780 {
1781   tree arg;
1782   tree arg2;
1783   tree type;
1784   tree tmp;
1785   tree lshift;
1786   tree rshift;
1787
1788   arg = gfc_conv_intrinsic_function_args (se, expr);
1789   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1790   arg = TREE_VALUE (arg);
1791   type = TREE_TYPE (arg);
1792
1793   /* Left shift if positive.  */
1794   lshift = build2 (LSHIFT_EXPR, type, arg, arg2);
1795
1796   /* Right shift if negative.  This will perform an arithmetic shift as
1797      we are dealing with signed integers.  Section 13.5.7 allows this.  */
1798   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1799   rshift = build2 (RSHIFT_EXPR, type, arg, tmp);
1800
1801   tmp = build2 (GT_EXPR, boolean_type_node, arg2,
1802                 convert (TREE_TYPE (arg2), integer_zero_node));
1803   rshift = build3 (COND_EXPR, type, tmp, lshift, rshift);
1804
1805   /* Do nothing if shift == 0.  */
1806   tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
1807                 convert (TREE_TYPE (arg2), integer_zero_node));
1808   se->expr = build3 (COND_EXPR, type, tmp, arg, rshift);
1809 }
1810
1811 /* Circular shift.  AKA rotate or barrel shift.  */
1812 static void
1813 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1814 {
1815   tree arg;
1816   tree arg2;
1817   tree arg3;
1818   tree type;
1819   tree tmp;
1820   tree lrot;
1821   tree rrot;
1822
1823   arg = gfc_conv_intrinsic_function_args (se, expr);
1824   arg2 = TREE_CHAIN (arg);
1825   arg3 = TREE_CHAIN (arg2);
1826   if (arg3)
1827     {
1828       /* Use a library function for the 3 parameter version.  */
1829       type = TREE_TYPE (TREE_VALUE (arg));
1830       /* Convert all args to the same type otherwise we need loads of library
1831          functions.  SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
1832          conversion is safe.  */
1833       tmp = convert (type, TREE_VALUE (arg2));
1834       TREE_VALUE (arg2) = tmp;
1835       tmp = convert (type, TREE_VALUE (arg3));
1836       TREE_VALUE (arg3) = tmp;
1837
1838       switch (expr->ts.kind)
1839         {
1840         case 4:
1841           tmp = gfor_fndecl_math_ishftc4;
1842           break;
1843         case 8:
1844           tmp = gfor_fndecl_math_ishftc8;
1845           break;
1846         default:
1847           gcc_unreachable ();
1848         }
1849       se->expr = gfc_build_function_call (tmp, arg);
1850       return;
1851     }
1852   arg = TREE_VALUE (arg);
1853   arg2 = TREE_VALUE (arg2);
1854   type = TREE_TYPE (arg);
1855
1856   /* Rotate left if positive.  */
1857   lrot = build2 (LROTATE_EXPR, type, arg, arg2);
1858
1859   /* Rotate right if negative.  */
1860   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1861   rrot = build2 (RROTATE_EXPR, type, arg, tmp);
1862
1863   tmp = build2 (GT_EXPR, boolean_type_node, arg2,
1864                 convert (TREE_TYPE (arg2), integer_zero_node));
1865   rrot = build3 (COND_EXPR, type, tmp, lrot, rrot);
1866
1867   /* Do nothing if shift == 0.  */
1868   tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
1869                 convert (TREE_TYPE (arg2), integer_zero_node));
1870   se->expr = build3 (COND_EXPR, type, tmp, arg, rrot);
1871 }
1872
1873 /* The length of a character string.  */
1874 static void
1875 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1876 {
1877   tree len;
1878   tree type;
1879   tree decl;
1880   gfc_symbol *sym;
1881   gfc_se argse;
1882   gfc_expr *arg;
1883
1884   gcc_assert (!se->ss);
1885
1886   arg = expr->value.function.actual->expr;
1887
1888   type = gfc_typenode_for_spec (&expr->ts);
1889   switch (arg->expr_type)
1890     {
1891     case EXPR_CONSTANT:
1892       len = build_int_cst (NULL_TREE, arg->value.character.length);
1893       break;
1894
1895     default:
1896         if (arg->expr_type == EXPR_VARIABLE
1897             && (arg->ref == NULL || (arg->ref->next == NULL
1898                                      && arg->ref->type == REF_ARRAY)))
1899           {
1900             /* This doesn't catch all cases.
1901                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1902                and the surrounding thread.  */
1903             sym = arg->symtree->n.sym;
1904             decl = gfc_get_symbol_decl (sym);
1905             if (decl == current_function_decl && sym->attr.function
1906                 && (sym->result == sym))
1907               decl = gfc_get_fake_result_decl (sym);
1908
1909             len = sym->ts.cl->backend_decl;
1910             gcc_assert (len);
1911           }
1912         else
1913           {
1914             /* Anybody stupid enough to do this deserves inefficient code.  */
1915             gfc_init_se (&argse, se);
1916             gfc_conv_expr (&argse, arg);
1917             gfc_add_block_to_block (&se->pre, &argse.pre);
1918             gfc_add_block_to_block (&se->post, &argse.post);
1919             len = argse.string_length;
1920         }
1921       break;
1922     }
1923   se->expr = convert (type, len);
1924 }
1925
1926 /* The length of a character string not including trailing blanks.  */
1927 static void
1928 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1929 {
1930   tree args;
1931   tree type;
1932
1933   args = gfc_conv_intrinsic_function_args (se, expr);
1934   type = gfc_typenode_for_spec (&expr->ts);
1935   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1936   se->expr = convert (type, se->expr);
1937 }
1938
1939
1940 /* Returns the starting position of a substring within a string.  */
1941
1942 static void
1943 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1944 {
1945   tree gfc_logical4_type_node = gfc_get_logical_type (4);
1946   tree args;
1947   tree back;
1948   tree type;
1949   tree tmp;
1950
1951   args = gfc_conv_intrinsic_function_args (se, expr);
1952   type = gfc_typenode_for_spec (&expr->ts);
1953   tmp = gfc_advance_chain (args, 3);
1954   if (TREE_CHAIN (tmp) == NULL_TREE)
1955     {
1956       back = convert (gfc_logical4_type_node, integer_one_node);
1957       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1958       TREE_CHAIN (tmp) = back;
1959     }
1960   else
1961     {
1962       back = TREE_CHAIN (tmp);
1963       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1964     }
1965
1966   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1967   se->expr = convert (type, se->expr);
1968 }
1969
1970 /* The ascii value for a single character.  */
1971 static void
1972 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1973 {
1974   tree arg;
1975   tree type;
1976
1977   arg = gfc_conv_intrinsic_function_args (se, expr);
1978   arg = TREE_VALUE (TREE_CHAIN (arg));
1979   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
1980   arg = build1 (NOP_EXPR, pchar_type_node, arg);
1981   type = gfc_typenode_for_spec (&expr->ts);
1982
1983   se->expr = gfc_build_indirect_ref (arg);
1984   se->expr = convert (type, se->expr);
1985 }
1986
1987
1988 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
1989
1990 static void
1991 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
1992 {
1993   tree arg;
1994   tree tsource;
1995   tree fsource;
1996   tree mask;
1997   tree type;
1998   tree len;
1999
2000   arg = gfc_conv_intrinsic_function_args (se, expr);
2001   if (expr->ts.type != BT_CHARACTER)
2002     {
2003       tsource = TREE_VALUE (arg);
2004       arg = TREE_CHAIN (arg);
2005       fsource = TREE_VALUE (arg);
2006       mask = TREE_VALUE (TREE_CHAIN (arg));
2007     }
2008   else
2009     {
2010       /* We do the same as in the non-character case, but the argument
2011          list is different because of the string length arguments. We
2012          also have to set the string length for the result.  */
2013       len = TREE_VALUE (arg);
2014       arg = TREE_CHAIN (arg);
2015       tsource = TREE_VALUE (arg);
2016       arg = TREE_CHAIN (TREE_CHAIN (arg));
2017       fsource = TREE_VALUE (arg);
2018       mask = TREE_VALUE (TREE_CHAIN (arg));
2019
2020       se->string_length = len;
2021     }
2022   type = TREE_TYPE (tsource);
2023   se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
2024 }
2025
2026
2027 static void
2028 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2029 {
2030   gfc_actual_arglist *actual;
2031   tree args;
2032   tree type;
2033   tree fndecl;
2034   gfc_se argse;
2035   gfc_ss *ss;
2036
2037   gfc_init_se (&argse, NULL);
2038   actual = expr->value.function.actual;
2039
2040   ss = gfc_walk_expr (actual->expr);
2041   gcc_assert (ss != gfc_ss_terminator);
2042   argse.want_pointer = 1;
2043   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2044   gfc_add_block_to_block (&se->pre, &argse.pre);
2045   gfc_add_block_to_block (&se->post, &argse.post);
2046   args = gfc_chainon_list (NULL_TREE, argse.expr);
2047
2048   actual = actual->next;
2049   if (actual->expr)
2050     {
2051       gfc_init_se (&argse, NULL);
2052       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2053       gfc_add_block_to_block (&se->pre, &argse.pre);
2054       args = gfc_chainon_list (args, argse.expr);
2055       fndecl = gfor_fndecl_size1;
2056     }
2057   else
2058     fndecl = gfor_fndecl_size0;
2059
2060   se->expr = gfc_build_function_call (fndecl, args);
2061   type = gfc_typenode_for_spec (&expr->ts);
2062   se->expr = convert (type, se->expr);
2063 }
2064
2065
2066 /* Intrinsic string comparison functions.  */
2067
2068   static void
2069 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2070 {
2071   tree type;
2072   tree args;
2073
2074   args = gfc_conv_intrinsic_function_args (se, expr);
2075   /* Build a call for the comparison.  */
2076   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2077
2078   type = gfc_typenode_for_spec (&expr->ts);
2079   se->expr = build2 (op, type, se->expr,
2080                      convert (TREE_TYPE (se->expr), integer_zero_node));
2081 }
2082
2083 /* Generate a call to the adjustl/adjustr library function.  */
2084 static void
2085 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2086 {
2087   tree args;
2088   tree len;
2089   tree type;
2090   tree var;
2091   tree tmp;
2092
2093   args = gfc_conv_intrinsic_function_args (se, expr);
2094   len = TREE_VALUE (args);
2095
2096   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2097   var = gfc_conv_string_tmp (se, type, len);
2098   args = tree_cons (NULL_TREE, var, args);
2099
2100   tmp = gfc_build_function_call (fndecl, args);
2101   gfc_add_expr_to_block (&se->pre, tmp);
2102   se->expr = var;
2103   se->string_length = len;
2104 }
2105
2106
2107 /* Scalar transfer statement.
2108    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2109
2110 static void
2111 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2112 {
2113   gfc_actual_arglist *arg;
2114   gfc_se argse;
2115   tree type;
2116   tree ptr;
2117   gfc_ss *ss;
2118
2119   gcc_assert (!se->ss);
2120
2121   /* Get a pointer to the source.  */
2122   arg = expr->value.function.actual;
2123   ss = gfc_walk_expr (arg->expr);
2124   gfc_init_se (&argse, NULL);
2125   if (ss == gfc_ss_terminator)
2126     gfc_conv_expr_reference (&argse, arg->expr);
2127   else
2128     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2129   gfc_add_block_to_block (&se->pre, &argse.pre);
2130   gfc_add_block_to_block (&se->post, &argse.post);
2131   ptr = argse.expr;
2132
2133   arg = arg->next;
2134   type = gfc_typenode_for_spec (&expr->ts);
2135   ptr = convert (build_pointer_type (type), ptr);
2136   if (expr->ts.type == BT_CHARACTER)
2137     {
2138       gfc_init_se (&argse, NULL);
2139       gfc_conv_expr (&argse, arg->expr);
2140       gfc_add_block_to_block (&se->pre, &argse.pre);
2141       gfc_add_block_to_block (&se->post, &argse.post);
2142       se->expr = ptr;
2143       se->string_length = argse.string_length;
2144     }
2145   else
2146     {
2147       se->expr = gfc_build_indirect_ref (ptr);
2148     }
2149 }
2150
2151
2152 /* Generate code for the ALLOCATED intrinsic.
2153    Generate inline code that directly check the address of the argument.  */
2154
2155 static void
2156 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2157 {
2158   gfc_actual_arglist *arg1;
2159   gfc_se arg1se;
2160   gfc_ss *ss1;
2161   tree tmp;
2162
2163   gfc_init_se (&arg1se, NULL);
2164   arg1 = expr->value.function.actual;
2165   ss1 = gfc_walk_expr (arg1->expr);
2166   arg1se.descriptor_only = 1;
2167   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2168
2169   tmp = gfc_conv_descriptor_data (arg1se.expr);
2170   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2171                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2172   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2173 }
2174
2175
2176 /* Generate code for the ASSOCIATED intrinsic.
2177    If both POINTER and TARGET are arrays, generate a call to library function
2178    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2179    In other cases, generate inline code that directly compare the address of
2180    POINTER with the address of TARGET.  */
2181
2182 static void
2183 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2184 {
2185   gfc_actual_arglist *arg1;
2186   gfc_actual_arglist *arg2;
2187   gfc_se arg1se;
2188   gfc_se arg2se;
2189   tree tmp2;
2190   tree tmp;
2191   tree args, fndecl;
2192   gfc_ss *ss1, *ss2;
2193
2194   gfc_init_se (&arg1se, NULL);
2195   gfc_init_se (&arg2se, NULL);
2196   arg1 = expr->value.function.actual;
2197   arg2 = arg1->next;
2198   ss1 = gfc_walk_expr (arg1->expr);
2199
2200   if (!arg2->expr)
2201     {
2202       /* No optional target.  */
2203       if (ss1 == gfc_ss_terminator)
2204         {
2205           /* A pointer to a scalar.  */
2206           arg1se.want_pointer = 1;
2207           gfc_conv_expr (&arg1se, arg1->expr);
2208           tmp2 = arg1se.expr;
2209         }
2210       else
2211         {
2212           /* A pointer to an array.  */
2213           arg1se.descriptor_only = 1;
2214           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2215           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2216         }
2217       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2218                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2219       se->expr = tmp;
2220     }
2221   else
2222     {
2223       /* An optional target.  */
2224       ss2 = gfc_walk_expr (arg2->expr);
2225       if (ss1 == gfc_ss_terminator)
2226         {
2227           /* A pointer to a scalar.  */
2228           gcc_assert (ss2 == gfc_ss_terminator);
2229           arg1se.want_pointer = 1;
2230           gfc_conv_expr (&arg1se, arg1->expr);
2231           arg2se.want_pointer = 1;
2232           gfc_conv_expr (&arg2se, arg2->expr);
2233           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2234           se->expr = tmp;
2235         }
2236       else
2237         {
2238           /* A pointer to an array, call library function _gfor_associated.  */
2239           gcc_assert (ss2 != gfc_ss_terminator);
2240           args = NULL_TREE;
2241           arg1se.want_pointer = 1;
2242           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2243           args = gfc_chainon_list (args, arg1se.expr);
2244           arg2se.want_pointer = 1;
2245           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2246           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2247           gfc_add_block_to_block (&se->post, &arg2se.post);
2248           args = gfc_chainon_list (args, arg2se.expr);
2249           fndecl = gfor_fndecl_associated;
2250           se->expr = gfc_build_function_call (fndecl, args);
2251         }
2252      }
2253   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2254 }
2255
2256
2257 /* Scan a string for any one of the characters in a set of characters.   */
2258
2259 static void
2260 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2261 {
2262   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2263   tree args;
2264   tree back;
2265   tree type;
2266   tree tmp;
2267
2268   args = gfc_conv_intrinsic_function_args (se, expr);
2269   type = gfc_typenode_for_spec (&expr->ts);
2270   tmp = gfc_advance_chain (args, 3);
2271   if (TREE_CHAIN (tmp) == NULL_TREE)
2272     {
2273       back = convert (gfc_logical4_type_node, integer_one_node);
2274       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2275       TREE_CHAIN (tmp) = back;
2276     }
2277   else
2278     {
2279       back = TREE_CHAIN (tmp);
2280       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2281     }
2282
2283   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2284   se->expr = convert (type, se->expr);
2285 }
2286
2287
2288 /* Verify that a set of characters contains all the characters in a string
2289    by identifying the position of the first character in a string of
2290    characters that does not appear in a given set of characters.  */
2291
2292 static void
2293 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2294 {
2295   tree gfc_logical4_type_node = gfc_get_logical_type (4);
2296   tree args;
2297   tree back;
2298   tree type;
2299   tree tmp;
2300
2301   args = gfc_conv_intrinsic_function_args (se, expr);
2302   type = gfc_typenode_for_spec (&expr->ts);
2303   tmp = gfc_advance_chain (args, 3);
2304   if (TREE_CHAIN (tmp) == NULL_TREE)
2305     {
2306       back = convert (gfc_logical4_type_node, integer_one_node);
2307       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2308       TREE_CHAIN (tmp) = back;
2309     }
2310   else
2311     {
2312       back = TREE_CHAIN (tmp);
2313       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2314     }
2315
2316   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2317   se->expr = convert (type, se->expr);
2318 }
2319
2320 /* Prepare components and related information of a real number which is
2321    the first argument of a elemental functions to manipulate reals.  */
2322
2323 static
2324 void prepare_arg_info (gfc_se * se, gfc_expr * expr,
2325                        real_compnt_info * rcs, int all)
2326 {
2327    tree arg;
2328    tree masktype;
2329    tree tmp;
2330    tree wbits;
2331    tree one;
2332    tree exponent, fraction;
2333    int n;
2334    gfc_expr *a1;
2335
2336    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2337      gfc_todo_error ("Non-IEEE floating format");
2338
2339    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2340
2341    arg = gfc_conv_intrinsic_function_args (se, expr);
2342    arg = TREE_VALUE (arg);
2343    rcs->type = TREE_TYPE (arg);
2344
2345    /* Force arg'type to integer by unaffected convert  */
2346    a1 = expr->value.function.actual->expr;
2347    masktype = gfc_get_int_type (a1->ts.kind);
2348    rcs->mtype = masktype;
2349    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2350    arg = gfc_create_var (masktype, "arg");
2351    gfc_add_modify_expr(&se->pre, arg, tmp);
2352    rcs->arg = arg;
2353
2354    /* Caculate the numbers of bits of exponent, fraction and word  */
2355    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2356    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2357    rcs->fdigits = convert (masktype, tmp);
2358    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2359    wbits = convert (masktype, wbits);
2360    rcs->edigits = fold (build2 (MINUS_EXPR, masktype, wbits, tmp));
2361
2362    /* Form masks for exponent/fraction/sign  */
2363    one = gfc_build_const (masktype, integer_one_node);
2364    rcs->smask = fold (build2 (LSHIFT_EXPR, masktype, one, wbits));
2365    rcs->f1 = fold (build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2366    rcs->emask = fold (build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2367    rcs->fmask = fold (build2 (MINUS_EXPR, masktype, rcs->f1, one));
2368    /* Form bias.  */
2369    tmp = fold (build2 (MINUS_EXPR, masktype, rcs->edigits, one));
2370    tmp = fold (build2 (LSHIFT_EXPR, masktype, one, tmp));
2371    rcs->bias = fold (build2 (MINUS_EXPR, masktype, tmp ,one));
2372
2373    if (all)
2374    {
2375      /* exponent, and fraction  */
2376      tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2377      tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2378      exponent = gfc_create_var (masktype, "exponent");
2379      gfc_add_modify_expr(&se->pre, exponent, tmp);
2380      rcs->expn = exponent;
2381
2382      tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2383      fraction = gfc_create_var (masktype, "fraction");
2384      gfc_add_modify_expr(&se->pre, fraction, tmp);
2385      rcs->frac = fraction;
2386   }
2387 }
2388
2389 /* Build a call to __builtin_clz.  */
2390
2391 static tree
2392 call_builtin_clz (tree result_type, tree op0)
2393 {
2394   tree fn, parms, call;
2395   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2396
2397   if (op0_mode == TYPE_MODE (integer_type_node))
2398     fn = built_in_decls[BUILT_IN_CLZ];
2399   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2400     fn = built_in_decls[BUILT_IN_CLZL];
2401   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2402     fn = built_in_decls[BUILT_IN_CLZLL];
2403   else
2404     gcc_unreachable ();
2405
2406   parms = tree_cons (NULL, op0, NULL);
2407   call = gfc_build_function_call (fn, parms);
2408
2409   return convert (result_type, call);
2410 }
2411
2412 /* Generate code for SPACING (X) intrinsic function. We generate:
2413
2414     t = expn - (BITS_OF_FRACTION)
2415     res = t << (BITS_OF_FRACTION)
2416     if (t < 0)
2417       res = tiny(X)
2418 */
2419
2420 static void
2421 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2422 {
2423    tree arg;
2424    tree masktype;
2425    tree tmp, t1, cond;
2426    tree tiny, zero;
2427    tree fdigits;
2428    real_compnt_info rcs;
2429
2430    prepare_arg_info (se, expr, &rcs, 0);
2431    arg = rcs.arg;
2432    masktype = rcs.mtype;
2433    fdigits = rcs.fdigits;
2434    tiny = rcs.f1;
2435    zero = gfc_build_const (masktype, integer_zero_node);
2436    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2437    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2438    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2439    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2440    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2441    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2442    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2443
2444    se->expr = tmp;
2445 }
2446
2447 /* Generate code for RRSPACING (X) intrinsic function. We generate:
2448
2449     if (expn == 0 && frac == 0)
2450        res = 0;
2451     else
2452     {
2453        sedigits = edigits + 1;
2454        if (expn == 0)
2455        {
2456          t1 = leadzero (frac);
2457          frac = frac << (t1 + sedigits);
2458          frac = frac >> (sedigits);
2459        }
2460        t = bias + BITS_OF_FRACTION_OF;
2461        res = (t << BITS_OF_FRACTION_OF) | frac;
2462 */
2463
2464 static void
2465 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2466 {
2467    tree masktype;
2468    tree tmp, t1, t2, cond, cond2;
2469    tree one, zero;
2470    tree fdigits, fraction;
2471    real_compnt_info rcs;
2472
2473    prepare_arg_info (se, expr, &rcs, 1);
2474    masktype = rcs.mtype;
2475    fdigits = rcs.fdigits;
2476    fraction = rcs.frac;
2477    one = gfc_build_const (masktype, integer_one_node);
2478    zero = gfc_build_const (masktype, integer_zero_node);
2479    t2 = build2 (PLUS_EXPR, masktype, rcs.edigits, one);
2480
2481    t1 = call_builtin_clz (masktype, fraction);
2482    tmp = build2 (PLUS_EXPR, masktype, t1, one);
2483    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2484    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2485    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2486    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2487
2488    tmp = build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
2489    tmp = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2490    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2491
2492    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2493    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2494    tmp = build3 (COND_EXPR, masktype, cond,
2495                  convert (masktype, integer_zero_node), tmp);
2496
2497    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2498    se->expr = tmp;
2499 }
2500
2501 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2502
2503 static void
2504 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2505 {
2506   tree args;
2507
2508   args = gfc_conv_intrinsic_function_args (se, expr);
2509   args = TREE_VALUE (args);
2510   args = gfc_build_addr_expr (NULL, args);
2511   args = tree_cons (NULL_TREE, args, NULL_TREE);
2512   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2513 }
2514
2515 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2516
2517 static void
2518 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2519 {
2520   gfc_actual_arglist *actual;
2521   tree args;
2522   gfc_se argse;
2523
2524   args = NULL_TREE;
2525   for (actual = expr->value.function.actual; actual; actual = actual->next)
2526     {
2527       gfc_init_se (&argse, se);
2528
2529       /* Pass a NULL pointer for an absent arg.  */
2530       if (actual->expr == NULL)
2531         argse.expr = null_pointer_node;
2532       else
2533         gfc_conv_expr_reference (&argse, actual->expr);
2534
2535       gfc_add_block_to_block (&se->pre, &argse.pre);
2536       gfc_add_block_to_block (&se->post, &argse.post);
2537       args = gfc_chainon_list (args, argse.expr);
2538     }
2539   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2540 }
2541
2542
2543 /* Generate code for TRIM (A) intrinsic function.  */
2544
2545 static void
2546 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2547 {
2548   tree gfc_int4_type_node = gfc_get_int_type (4);
2549   tree var;
2550   tree len;
2551   tree addr;
2552   tree tmp;
2553   tree arglist;
2554   tree type;
2555   tree cond;
2556
2557   arglist = NULL_TREE;
2558
2559   type = build_pointer_type (gfc_character1_type_node);
2560   var = gfc_create_var (type, "pstr");
2561   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2562   len = gfc_create_var (gfc_int4_type_node, "len");
2563
2564   tmp = gfc_conv_intrinsic_function_args (se, expr);
2565   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2566   arglist = gfc_chainon_list (arglist, addr);
2567   arglist = chainon (arglist, tmp);
2568
2569   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2570   gfc_add_expr_to_block (&se->pre, tmp);
2571
2572   /* Free the temporary afterwards, if necessary.  */
2573   cond = build2 (GT_EXPR, boolean_type_node, len,
2574                  convert (TREE_TYPE (len), integer_zero_node));
2575   arglist = gfc_chainon_list (NULL_TREE, var);
2576   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2577   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2578   gfc_add_expr_to_block (&se->post, tmp);
2579
2580   se->expr = var;
2581   se->string_length = len;
2582 }
2583
2584
2585 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2586
2587 static void
2588 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2589 {
2590   tree gfc_int4_type_node = gfc_get_int_type (4);
2591   tree tmp;
2592   tree len;
2593   tree args;
2594   tree arglist;
2595   tree ncopies;
2596   tree var;
2597   tree type;
2598
2599   args = gfc_conv_intrinsic_function_args (se, expr);
2600   len = TREE_VALUE (args);
2601   tmp = gfc_advance_chain (args, 2);
2602   ncopies = TREE_VALUE (tmp);
2603   len = fold (build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2604   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2605   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2606
2607   arglist = NULL_TREE;
2608   arglist = gfc_chainon_list (arglist, var);
2609   arglist = chainon (arglist, args);
2610   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2611   gfc_add_expr_to_block (&se->pre, tmp);
2612
2613   se->expr = var;
2614   se->string_length = len;
2615 }
2616
2617
2618 /* Generate code for the IARGC intrinsic.  If args_only is true this is
2619    actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1.  */
2620
2621 static void
2622 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
2623 {
2624   tree tmp;
2625   tree fndecl;
2626   tree type;
2627
2628   /* Call the library function.  This always returns an INTEGER(4).  */
2629   fndecl = gfor_fndecl_iargc;
2630   tmp = gfc_build_function_call (fndecl, NULL_TREE);
2631
2632   /* Convert it to the required type.  */
2633   type = gfc_typenode_for_spec (&expr->ts);
2634   tmp = fold_convert (type, tmp);
2635
2636   if (args_only)
2637     tmp = build2 (MINUS_EXPR, type, tmp, convert (type, integer_one_node));
2638   se->expr = tmp;
2639 }
2640
2641 /* Generate code for an intrinsic function.  Some map directly to library
2642    calls, others get special handling.  In some cases the name of the function
2643    used depends on the type specifiers.  */
2644
2645 void
2646 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2647 {
2648   gfc_intrinsic_sym *isym;
2649   char *name;
2650   int lib;
2651
2652   isym = expr->value.function.isym;
2653
2654   name = &expr->value.function.name[2];
2655
2656   if (expr->rank > 0)
2657     {
2658       lib = gfc_is_intrinsic_libcall (expr);
2659       if (lib != 0)
2660         {
2661           if (lib == 1)
2662             se->ignore_optional = 1;
2663           gfc_conv_intrinsic_funcall (se, expr);
2664           return;
2665         }
2666     }
2667
2668   switch (expr->value.function.isym->generic_id)
2669     {
2670     case GFC_ISYM_NONE:
2671       gcc_unreachable ();
2672
2673     case GFC_ISYM_REPEAT:
2674       gfc_conv_intrinsic_repeat (se, expr);
2675       break;
2676
2677     case GFC_ISYM_TRIM:
2678       gfc_conv_intrinsic_trim (se, expr);
2679       break;
2680
2681     case GFC_ISYM_SI_KIND:
2682       gfc_conv_intrinsic_si_kind (se, expr);
2683       break;
2684
2685     case GFC_ISYM_SR_KIND:
2686       gfc_conv_intrinsic_sr_kind (se, expr);
2687       break;
2688
2689     case GFC_ISYM_EXPONENT:
2690       gfc_conv_intrinsic_exponent (se, expr);
2691       break;
2692
2693     case GFC_ISYM_SPACING:
2694       gfc_conv_intrinsic_spacing (se, expr);
2695       break;
2696
2697     case GFC_ISYM_RRSPACING:
2698       gfc_conv_intrinsic_rrspacing (se, expr);
2699       break;
2700
2701     case GFC_ISYM_SCAN:
2702       gfc_conv_intrinsic_scan (se, expr);
2703       break;
2704
2705     case GFC_ISYM_VERIFY:
2706       gfc_conv_intrinsic_verify (se, expr);
2707       break;
2708
2709     case GFC_ISYM_ALLOCATED:
2710       gfc_conv_allocated (se, expr);
2711       break;
2712
2713     case GFC_ISYM_ASSOCIATED:
2714       gfc_conv_associated(se, expr);
2715       break;
2716
2717     case GFC_ISYM_ABS:
2718       gfc_conv_intrinsic_abs (se, expr);
2719       break;
2720
2721     case GFC_ISYM_ADJUSTL:
2722       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2723       break;
2724
2725     case GFC_ISYM_ADJUSTR:
2726       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2727       break;
2728
2729     case GFC_ISYM_AIMAG:
2730       gfc_conv_intrinsic_imagpart (se, expr);
2731       break;
2732
2733     case GFC_ISYM_AINT:
2734       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2735       break;
2736
2737     case GFC_ISYM_ALL:
2738       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2739       break;
2740
2741     case GFC_ISYM_ANINT:
2742       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2743       break;
2744
2745     case GFC_ISYM_ANY:
2746       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2747       break;
2748
2749     case GFC_ISYM_BTEST:
2750       gfc_conv_intrinsic_btest (se, expr);
2751       break;
2752
2753     case GFC_ISYM_ACHAR:
2754     case GFC_ISYM_CHAR:
2755       gfc_conv_intrinsic_char (se, expr);
2756       break;
2757
2758     case GFC_ISYM_CONVERSION:
2759     case GFC_ISYM_REAL:
2760     case GFC_ISYM_LOGICAL:
2761     case GFC_ISYM_DBLE:
2762       gfc_conv_intrinsic_conversion (se, expr);
2763       break;
2764
2765       /* Integer conversions are handled seperately to make sure we get the
2766          correct rounding mode.  */
2767     case GFC_ISYM_INT:
2768       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2769       break;
2770
2771     case GFC_ISYM_NINT:
2772       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2773       break;
2774
2775     case GFC_ISYM_CEILING:
2776       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2777       break;
2778
2779     case GFC_ISYM_FLOOR:
2780       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2781       break;
2782
2783     case GFC_ISYM_MOD:
2784       gfc_conv_intrinsic_mod (se, expr, 0);
2785       break;
2786
2787     case GFC_ISYM_MODULO:
2788       gfc_conv_intrinsic_mod (se, expr, 1);
2789       break;
2790
2791     case GFC_ISYM_CMPLX:
2792       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2793       break;
2794
2795     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2796       gfc_conv_intrinsic_iargc (se, expr, TRUE);
2797       break;
2798
2799     case GFC_ISYM_CONJG:
2800       gfc_conv_intrinsic_conjg (se, expr);
2801       break;
2802
2803     case GFC_ISYM_COUNT:
2804       gfc_conv_intrinsic_count (se, expr);
2805       break;
2806
2807     case GFC_ISYM_DIM:
2808       gfc_conv_intrinsic_dim (se, expr);
2809       break;
2810
2811     case GFC_ISYM_DPROD:
2812       gfc_conv_intrinsic_dprod (se, expr);
2813       break;
2814
2815     case GFC_ISYM_IAND:
2816       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2817       break;
2818
2819     case GFC_ISYM_IBCLR:
2820       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2821       break;
2822
2823     case GFC_ISYM_IBITS:
2824       gfc_conv_intrinsic_ibits (se, expr);
2825       break;
2826
2827     case GFC_ISYM_IBSET:
2828       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2829       break;
2830
2831     case GFC_ISYM_IACHAR:
2832     case GFC_ISYM_ICHAR:
2833       /* We assume ASCII character sequence.  */
2834       gfc_conv_intrinsic_ichar (se, expr);
2835       break;
2836
2837     case GFC_ISYM_IARGC:
2838       gfc_conv_intrinsic_iargc (se, expr, FALSE);
2839       break;
2840
2841     case GFC_ISYM_IEOR:
2842       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2843       break;
2844
2845     case GFC_ISYM_INDEX:
2846       gfc_conv_intrinsic_index (se, expr);
2847       break;
2848
2849     case GFC_ISYM_IOR:
2850       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2851       break;
2852
2853     case GFC_ISYM_ISHFT:
2854       gfc_conv_intrinsic_ishft (se, expr);
2855       break;
2856
2857     case GFC_ISYM_ISHFTC:
2858       gfc_conv_intrinsic_ishftc (se, expr);
2859       break;
2860
2861     case GFC_ISYM_LBOUND:
2862       gfc_conv_intrinsic_bound (se, expr, 0);
2863       break;
2864
2865     case GFC_ISYM_LEN:
2866       gfc_conv_intrinsic_len (se, expr);
2867       break;
2868
2869     case GFC_ISYM_LEN_TRIM:
2870       gfc_conv_intrinsic_len_trim (se, expr);
2871       break;
2872
2873     case GFC_ISYM_LGE:
2874       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2875       break;
2876
2877     case GFC_ISYM_LGT:
2878       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2879       break;
2880
2881     case GFC_ISYM_LLE:
2882       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2883       break;
2884
2885     case GFC_ISYM_LLT:
2886       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2887       break;
2888
2889     case GFC_ISYM_MAX:
2890       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2891       break;
2892
2893     case GFC_ISYM_MAXLOC:
2894       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2895       break;
2896
2897     case GFC_ISYM_MAXVAL:
2898       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2899       break;
2900
2901     case GFC_ISYM_MERGE:
2902       gfc_conv_intrinsic_merge (se, expr);
2903       break;
2904
2905     case GFC_ISYM_MIN:
2906       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2907       break;
2908
2909     case GFC_ISYM_MINLOC:
2910       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2911       break;
2912
2913     case GFC_ISYM_MINVAL:
2914       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2915       break;
2916
2917     case GFC_ISYM_NOT:
2918       gfc_conv_intrinsic_not (se, expr);
2919       break;
2920
2921     case GFC_ISYM_PRESENT:
2922       gfc_conv_intrinsic_present (se, expr);
2923       break;
2924
2925     case GFC_ISYM_PRODUCT:
2926       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2927       break;
2928
2929     case GFC_ISYM_SIGN:
2930       gfc_conv_intrinsic_sign (se, expr);
2931       break;
2932
2933     case GFC_ISYM_SIZE:
2934       gfc_conv_intrinsic_size (se, expr);
2935       break;
2936
2937     case GFC_ISYM_SUM:
2938       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2939       break;
2940
2941     case GFC_ISYM_TRANSFER:
2942       gfc_conv_intrinsic_transfer (se, expr);
2943       break;
2944
2945     case GFC_ISYM_UBOUND:
2946       gfc_conv_intrinsic_bound (se, expr, 1);
2947       break;
2948
2949     case GFC_ISYM_DOT_PRODUCT:
2950     case GFC_ISYM_MATMUL:
2951     case GFC_ISYM_IRAND:
2952     case GFC_ISYM_RAND:
2953     case GFC_ISYM_ETIME:
2954     case GFC_ISYM_SECOND:
2955     case GFC_ISYM_GETCWD:
2956     case GFC_ISYM_GETGID:
2957     case GFC_ISYM_GETPID:
2958     case GFC_ISYM_GETUID:
2959       gfc_conv_intrinsic_funcall (se, expr);
2960       break;
2961
2962     default:
2963       gfc_conv_intrinsic_lib_function (se, expr);
2964       break;
2965     }
2966 }
2967
2968
2969 /* This generates code to execute before entering the scalarization loop.
2970    Currently does nothing.  */
2971
2972 void
2973 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
2974 {
2975   switch (ss->expr->value.function.isym->generic_id)
2976     {
2977     case GFC_ISYM_UBOUND:
2978     case GFC_ISYM_LBOUND:
2979       break;
2980
2981     default:
2982       gcc_unreachable ();
2983     }
2984 }
2985
2986
2987 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
2988    inside the scalarization loop.  */
2989
2990 static gfc_ss *
2991 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
2992 {
2993   gfc_ss *newss;
2994
2995   /* The two argument version returns a scalar.  */
2996   if (expr->value.function.actual->next->expr)
2997     return ss;
2998
2999   newss = gfc_get_ss ();
3000   newss->type = GFC_SS_INTRINSIC;
3001   newss->expr = expr;
3002   newss->next = ss;
3003
3004   return newss;
3005 }
3006
3007
3008 /* Walk an intrinsic array libcall.  */
3009
3010 static gfc_ss *
3011 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3012 {
3013   gfc_ss *newss;
3014
3015   gcc_assert (expr->rank > 0);
3016
3017   newss = gfc_get_ss ();
3018   newss->type = GFC_SS_FUNCTION;
3019   newss->expr = expr;
3020   newss->next = ss;
3021   newss->data.info.dimen = expr->rank;
3022
3023   return newss;
3024 }
3025
3026
3027 /* Returns nonzero if the specified intrinsic function call maps directly to a
3028    an external library call.  Should only be used for functions that return
3029    arrays.  */
3030
3031 int
3032 gfc_is_intrinsic_libcall (gfc_expr * expr)
3033 {
3034   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3035   gcc_assert (expr->rank > 0);
3036
3037   switch (expr->value.function.isym->generic_id)
3038     {
3039     case GFC_ISYM_ALL:
3040     case GFC_ISYM_ANY:
3041     case GFC_ISYM_COUNT:
3042     case GFC_ISYM_MATMUL:
3043     case GFC_ISYM_MAXLOC:
3044     case GFC_ISYM_MAXVAL:
3045     case GFC_ISYM_MINLOC:
3046     case GFC_ISYM_MINVAL:
3047     case GFC_ISYM_PRODUCT:
3048     case GFC_ISYM_SUM:
3049     case GFC_ISYM_SHAPE:
3050     case GFC_ISYM_SPREAD:
3051     case GFC_ISYM_TRANSPOSE:
3052       /* Ignore absent optional parameters.  */
3053       return 1;
3054
3055     case GFC_ISYM_RESHAPE:
3056     case GFC_ISYM_CSHIFT:
3057     case GFC_ISYM_EOSHIFT:
3058     case GFC_ISYM_PACK:
3059     case GFC_ISYM_UNPACK:
3060       /* Pass absent optional parameters.  */
3061       return 2;
3062
3063     default:
3064       return 0;
3065     }
3066 }
3067
3068 /* Walk an intrinsic function.  */
3069 gfc_ss *
3070 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3071                              gfc_intrinsic_sym * isym)
3072 {
3073   gcc_assert (isym);
3074
3075   if (isym->elemental)
3076     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
3077
3078   if (expr->rank == 0)
3079     return ss;
3080
3081   if (gfc_is_intrinsic_libcall (expr))
3082     return gfc_walk_intrinsic_libfunc (ss, expr);
3083
3084   /* Special cases.  */
3085   switch (isym->generic_id)
3086     {
3087     case GFC_ISYM_LBOUND:
3088     case GFC_ISYM_UBOUND:
3089       return gfc_walk_intrinsic_bound (ss, expr);
3090
3091     default:
3092       /* This probably meant someone forgot to add an intrinsic to the above
3093          list(s) when they implemented it, or something's gone horribly wrong.
3094        */
3095       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3096                       expr->value.function.name);
3097     }
3098 }
3099
3100 #include "gt-fortran-trans-intrinsic.h"