gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006 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, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, 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 "ggc.h"
  30 #include "toplev.h"
  31 #include "real.h"
  32 #include "tree-gimple.h"
  33 #include "flags.h"
  34 #include "gfortran.h"
  35 #include "arith.h"
  36 #include "intrinsic.h"
  37 #include "trans.h"
  38 #include "trans-const.h"
  39 #include "trans-types.h"
  40 #include "trans-array.h"
  41 #include "defaults.h"
  42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  43 #include "trans-stmt.h"
  44
  45 /* This maps fortran intrinsic math functions to external library or GCC
  46    builtin functions.  */
  47 typedef struct gfc_intrinsic_map_t      GTY(())
  48 {
  49   /* The explicit enum is required to work around inadequacies in the
  50      garbage collection/gengtype parsing mechanism.  */
  51   enum gfc_generic_isym_id id;
  52
  53   /* Enum value from the "language-independent", aka C-centric, part
  54      of gcc, or END_BUILTINS of no such value set.  */
  55   enum built_in_function code_r4;
  56   enum built_in_function code_r8;
  57   enum built_in_function code_r10;
  58   enum built_in_function code_r16;
  59   enum built_in_function code_c4;
  60   enum built_in_function code_c8;
  61   enum built_in_function code_c10;
  62   enum built_in_function code_c16;
  63
  64   /* True if the naming pattern is to prepend "c" for complex and
  65      append "f" for kind=4.  False if the naming pattern is to
  66      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  67   bool libm_name;
  68
  69   /* True if a complex version of the function exists.  */
  70   bool complex_available;
  71
  72   /* True if the function should be marked const.  */
  73   bool is_constant;
  74
  75   /* The base library name of this function.  */
  76   const char *name;
  77
  78   /* Cache decls created for the various operand types.  */
  79   tree real4_decl;
  80   tree real8_decl;
  81   tree real10_decl;
  82   tree real16_decl;
  83   tree complex4_decl;
  84   tree complex8_decl;
  85   tree complex10_decl;
  86   tree complex16_decl;
  87 }
  88 gfc_intrinsic_map_t;
  89
  90 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  91    defines complex variants of all of the entries in mathbuiltins.def
  92    except for atan2.  */
  93 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  94   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  95     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  96     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  97     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  98
  99 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 100   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 101     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 102     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 103     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 104     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 105
 106 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 107   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 108     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 110     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 111
 112 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 113   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 114     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 115     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 116     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 117
 118 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 119 {
 120   /* Functions built into gcc itself.  */
 121 #include "mathbuiltins.def"
 122
 123   /* Functions in libm.  */
 124   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 125      pattern for other mathbuiltins.def entries.  At present we have no
 126      optimizations for this in the common sources.  */
 127   LIBM_FUNCTION (SCALE, "scalbn", false),
 128
 129   /* Functions in libgfortran.  */
 130   LIBF_FUNCTION (FRACTION, "fraction", false),
 131   LIBF_FUNCTION (NEAREST, "nearest", false),
 132   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 133
 134   /* End the list.  */
 135   LIBF_FUNCTION (NONE, NULL, false)
 136 };
 137 #undef DEFINE_MATH_BUILTIN
 138 #undef DEFINE_MATH_BUILTIN_C
 139 #undef LIBM_FUNCTION
 140 #undef LIBF_FUNCTION
 141
 142 /* Structure for storing components of a floating number to be used by
 143    elemental functions to manipulate reals.  */
 144 typedef struct
 145 {
 146   tree arg;     /* Variable tree to view convert to integer.  */
 147   tree expn;    /* Variable tree to save exponent.  */
 148   tree frac;    /* Variable tree to save fraction.  */
 149   tree smask;   /* Constant tree of sign's mask.  */
 150   tree emask;   /* Constant tree of exponent's mask.  */
 151   tree fmask;   /* Constant tree of fraction's mask.  */
 152   tree edigits; /* Constant tree of the number of exponent bits.  */
 153   tree fdigits; /* Constant tree of the number of fraction bits.  */
 154   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 155   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 156   tree type;    /* Type tree of arg1.  */
 157   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 158 }
 159 real_compnt_info;
 160
 161
 162 /* Evaluate the arguments to an intrinsic function.  */
 163
 164 static tree
 165 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 166 {
 167   gfc_actual_arglist *actual;
 168   gfc_expr *e;
 169   gfc_intrinsic_arg  *formal;
 170   gfc_se argse;
 171   tree args;
 172
 173   args = NULL_TREE;
 174   formal = expr->value.function.isym->formal;
 175
 176   for (actual = expr->value.function.actual; actual; actual = actual->next,
 177        formal = formal ? formal->next : NULL)
 178     {
 179       e = actual->expr;
 180       /* Skip omitted optional arguments.  */
 181       if (!e)
 182         continue;
 183
 184       /* Evaluate the parameter.  This will substitute scalarized
 185          references automatically.  */
 186       gfc_init_se (&argse, se);
 187
 188       if (e->ts.type == BT_CHARACTER)
 189         {
 190           gfc_conv_expr (&argse, e);
 191           gfc_conv_string_parameter (&argse);
 192           args = gfc_chainon_list (args, argse.string_length);
 193         }
 194       else
 195         gfc_conv_expr_val (&argse, e);
 196
 197       /* If an optional argument is itself an optional dummy argument,
 198          check its presence and substitute a null if absent.  */
 199       if (e->expr_type ==EXPR_VARIABLE
 200             && e->symtree->n.sym->attr.optional
 201             && formal
 202             && formal->optional)
 203         gfc_conv_missing_dummy (&argse, e, formal->ts);
 204
 205       gfc_add_block_to_block (&se->pre, &argse.pre);
 206       gfc_add_block_to_block (&se->post, &argse.post);
 207       args = gfc_chainon_list (args, argse.expr);
 208     }
 209   return args;
 210 }
 211
 212
 213 /* Conversions between different types are output by the frontend as
 214    intrinsic functions.  We implement these directly with inline code.  */
 215
 216 static void
 217 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 218 {
 219   tree type;
 220   tree arg;
 221
 222   /* Evaluate the argument.  */
 223   type = gfc_typenode_for_spec (&expr->ts);
 224   gcc_assert (expr->value.function.actual->expr);
 225   arg = gfc_conv_intrinsic_function_args (se, expr);
 226   arg = TREE_VALUE (arg);
 227
 228   /* Conversion from complex to non-complex involves taking the real
 229      component of the value.  */
 230   if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 231       && expr->ts.type != BT_COMPLEX)
 232     {
 233       tree artype;
 234
 235       artype = TREE_TYPE (TREE_TYPE (arg));
 236       arg = build1 (REALPART_EXPR, artype, arg);
 237     }
 238
 239   se->expr = convert (type, arg);
 240 }
 241
 242 /* This is needed because the gcc backend only implements
 243    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 244    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 245    Similarly for CEILING.  */
 246
 247 static tree
 248 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 249 {
 250   tree tmp;
 251   tree cond;
 252   tree argtype;
 253   tree intval;
 254
 255   argtype = TREE_TYPE (arg);
 256   arg = gfc_evaluate_now (arg, pblock);
 257
 258   intval = convert (type, arg);
 259   intval = gfc_evaluate_now (intval, pblock);
 260
 261   tmp = convert (argtype, intval);
 262   cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 263
 264   tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 265                 build_int_cst (type, 1));
 266   tmp = build3 (COND_EXPR, type, cond, intval, tmp);
 267   return tmp;
 268 }
 269
 270
 271 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 272    NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
 273
 274 static tree
 275 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 276 {
 277   tree tmp;
 278   tree cond;
 279   tree neg;
 280   tree pos;
 281   tree argtype;
 282   REAL_VALUE_TYPE r;
 283
 284   argtype = TREE_TYPE (arg);
 285   arg = gfc_evaluate_now (arg, pblock);
 286
 287   real_from_string (&r, "0.5");
 288   pos = build_real (argtype, r);
 289
 290   real_from_string (&r, "-0.5");
 291   neg = build_real (argtype, r);
 292
 293   tmp = gfc_build_const (argtype, integer_zero_node);
 294   cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
 295
 296   tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
 297   tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
 298   return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
 299 }
 300
 301
 302 /* Convert a real to an integer using a specific rounding mode.
 303    Ideally we would just build the corresponding GENERIC node,
 304    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 305
 306 static tree
 307 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 308                enum tree_code op)
 309 {
 310   switch (op)
 311     {
 312     case FIX_FLOOR_EXPR:
 313       return build_fixbound_expr (pblock, arg, type, 0);
 314       break;
 315
 316     case FIX_CEIL_EXPR:
 317       return build_fixbound_expr (pblock, arg, type, 1);
 318       break;
 319
 320     case FIX_ROUND_EXPR:
 321       return build_round_expr (pblock, arg, type);
 322
 323     default:
 324       return build1 (op, type, arg);
 325     }
 326 }
 327
 328
 329 /* Round a real value using the specified rounding mode.
 330    We use a temporary integer of that same kind size as the result.
 331    Values larger than those that can be represented by this kind are
 332    unchanged, as they will not be accurate enough to represent the
 333    rounding.
 334     huge = HUGE (KIND (a))
 335     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 336    */
 337
 338 static void
 339 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op)
 340 {
 341   tree type;
 342   tree itype;
 343   tree arg;
 344   tree tmp;
 345   tree cond;
 346   mpfr_t huge;
 347   int n;
 348   int kind;
 349
 350   kind = expr->ts.kind;
 351
 352   n = END_BUILTINS;
 353   /* We have builtin functions for some cases.  */
 354   switch (op)
 355     {
 356     case FIX_ROUND_EXPR:
 357       switch (kind)
 358         {
 359         case 4:
 360           n = BUILT_IN_ROUNDF;
 361           break;
 362
 363         case 8:
 364           n = BUILT_IN_ROUND;
 365           break;
 366
 367         case 10:
 368         case 16:
 369           n = BUILT_IN_ROUNDL;
 370           break;
 371         }
 372       break;
 373
 374     case FIX_TRUNC_EXPR:
 375       switch (kind)
 376         {
 377         case 4:
 378           n = BUILT_IN_TRUNCF;
 379           break;
 380
 381         case 8:
 382           n = BUILT_IN_TRUNC;
 383           break;
 384
 385         case 10:
 386         case 16:
 387           n = BUILT_IN_TRUNCL;
 388           break;
 389         }
 390       break;
 391
 392     default:
 393       gcc_unreachable ();
 394     }
 395
 396   /* Evaluate the argument.  */
 397   gcc_assert (expr->value.function.actual->expr);
 398   arg = gfc_conv_intrinsic_function_args (se, expr);
 399
 400   /* Use a builtin function if one exists.  */
 401   if (n != END_BUILTINS)
 402     {
 403       tmp = built_in_decls[n];
 404       se->expr = build_function_call_expr (tmp, arg);
 405       return;
 406     }
 407
 408   /* This code is probably redundant, but we'll keep it lying around just
 409      in case.  */
 410   type = gfc_typenode_for_spec (&expr->ts);
 411   arg = TREE_VALUE (arg);
 412   arg = gfc_evaluate_now (arg, &se->pre);
 413
 414   /* Test if the value is too large to handle sensibly.  */
 415   gfc_set_model_kind (kind);
 416   mpfr_init (huge);
 417   n = gfc_validate_kind (BT_INTEGER, kind, false);
 418   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 419   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 420   cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
 421
 422   mpfr_neg (huge, huge, GFC_RND_MODE);
 423   tmp = gfc_conv_mpfr_to_tree (huge, kind);
 424   tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
 425   cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 426   itype = gfc_get_int_type (kind);
 427
 428   tmp = build_fix_expr (&se->pre, arg, itype, op);
 429   tmp = convert (type, tmp);
 430   se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
 431   mpfr_clear (huge);
 432 }
 433
 434
 435 /* Convert to an integer using the specified rounding mode.  */
 436
 437 static void
 438 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
 439 {
 440   tree type;
 441   tree arg;
 442
 443   /* Evaluate the argument.  */
 444   type = gfc_typenode_for_spec (&expr->ts);
 445   gcc_assert (expr->value.function.actual->expr);
 446   arg = gfc_conv_intrinsic_function_args (se, expr);
 447   arg = TREE_VALUE (arg);
 448
 449   if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
 450     {
 451       /* Conversion to a different integer kind.  */
 452       se->expr = convert (type, arg);
 453     }
 454   else
 455     {
 456       /* Conversion from complex to non-complex involves taking the real
 457          component of the value.  */
 458       if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 459           && expr->ts.type != BT_COMPLEX)
 460         {
 461           tree artype;
 462
 463           artype = TREE_TYPE (TREE_TYPE (arg));
 464           arg = build1 (REALPART_EXPR, artype, arg);
 465         }
 466
 467       se->expr = build_fix_expr (&se->pre, arg, type, op);
 468     }
 469 }
 470
 471
 472 /* Get the imaginary component of a value.  */
 473
 474 static void
 475 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 476 {
 477   tree arg;
 478
 479   arg = gfc_conv_intrinsic_function_args (se, expr);
 480   arg = TREE_VALUE (arg);
 481   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 482 }
 483
 484
 485 /* Get the complex conjugate of a value.  */
 486
 487 static void
 488 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 489 {
 490   tree arg;
 491
 492   arg = gfc_conv_intrinsic_function_args (se, expr);
 493   arg = TREE_VALUE (arg);
 494   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 495 }
 496
 497
 498 /* Initialize function decls for library functions.  The external functions
 499    are created as required.  Builtin functions are added here.  */
 500
 501 void
 502 gfc_build_intrinsic_lib_fndecls (void)
 503 {
 504   gfc_intrinsic_map_t *m;
 505
 506   /* Add GCC builtin functions.  */
 507   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 508     {
 509       if (m->code_r4 != END_BUILTINS)
 510         m->real4_decl = built_in_decls[m->code_r4];
 511       if (m->code_r8 != END_BUILTINS)
 512         m->real8_decl = built_in_decls[m->code_r8];
 513       if (m->code_r10 != END_BUILTINS)
 514         m->real10_decl = built_in_decls[m->code_r10];
 515       if (m->code_r16 != END_BUILTINS)
 516         m->real16_decl = built_in_decls[m->code_r16];
 517       if (m->code_c4 != END_BUILTINS)
 518         m->complex4_decl = built_in_decls[m->code_c4];
 519       if (m->code_c8 != END_BUILTINS)
 520         m->complex8_decl = built_in_decls[m->code_c8];
 521       if (m->code_c10 != END_BUILTINS)
 522         m->complex10_decl = built_in_decls[m->code_c10];
 523       if (m->code_c16 != END_BUILTINS)
 524         m->complex16_decl = built_in_decls[m->code_c16];
 525     }
 526 }
 527
 528
 529 /* Create a fndecl for a simple intrinsic library function.  */
 530
 531 static tree
 532 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 533 {
 534   tree type;
 535   tree argtypes;
 536   tree fndecl;
 537   gfc_actual_arglist *actual;
 538   tree *pdecl;
 539   gfc_typespec *ts;
 540   char name[GFC_MAX_SYMBOL_LEN + 3];
 541
 542   ts = &expr->ts;
 543   if (ts->type == BT_REAL)
 544     {
 545       switch (ts->kind)
 546         {
 547         case 4:
 548           pdecl = &m->real4_decl;
 549           break;
 550         case 8:
 551           pdecl = &m->real8_decl;
 552           break;
 553         case 10:
 554           pdecl = &m->real10_decl;
 555           break;
 556         case 16:
 557           pdecl = &m->real16_decl;
 558           break;
 559         default:
 560           gcc_unreachable ();
 561         }
 562     }
 563   else if (ts->type == BT_COMPLEX)
 564     {
 565       gcc_assert (m->complex_available);
 566
 567       switch (ts->kind)
 568         {
 569         case 4:
 570           pdecl = &m->complex4_decl;
 571           break;
 572         case 8:
 573           pdecl = &m->complex8_decl;
 574           break;
 575         case 10:
 576           pdecl = &m->complex10_decl;
 577           break;
 578         case 16:
 579           pdecl = &m->complex16_decl;
 580           break;
 581         default:
 582           gcc_unreachable ();
 583         }
 584     }
 585   else
 586     gcc_unreachable ();
 587
 588   if (*pdecl)
 589     return *pdecl;
 590
 591   if (m->libm_name)
 592     {
 593       gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
 594                  || ts->kind == 16);
 595       snprintf (name, sizeof (name), "%s%s%s",
 596                 ts->type == BT_COMPLEX ? "c" : "",
 597                 m->name,
 598                 ts->kind == 4 ? "f" : "");
 599     }
 600   else
 601     {
 602       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 603                 ts->type == BT_COMPLEX ? 'c' : 'r',
 604                 ts->kind);
 605     }
 606
 607   argtypes = NULL_TREE;
 608   for (actual = expr->value.function.actual; actual; actual = actual->next)
 609     {
 610       type = gfc_typenode_for_spec (&actual->expr->ts);
 611       argtypes = gfc_chainon_list (argtypes, type);
 612     }
 613   argtypes = gfc_chainon_list (argtypes, void_type_node);
 614   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 615   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 616
 617   /* Mark the decl as external.  */
 618   DECL_EXTERNAL (fndecl) = 1;
 619   TREE_PUBLIC (fndecl) = 1;
 620
 621   /* Mark it __attribute__((const)), if possible.  */
 622   TREE_READONLY (fndecl) = m->is_constant;
 623
 624   rest_of_decl_compilation (fndecl, 1, 0);
 625
 626   (*pdecl) = fndecl;
 627   return fndecl;
 628 }
 629
 630
 631 /* Convert an intrinsic function into an external or builtin call.  */
 632
 633 static void
 634 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 635 {
 636   gfc_intrinsic_map_t *m;
 637   tree args;
 638   tree fndecl;
 639   gfc_generic_isym_id id;
 640
 641   id = expr->value.function.isym->generic_id;
 642   /* Find the entry for this function.  */
 643   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 644     {
 645       if (id == m->id)
 646         break;
 647     }
 648
 649   if (m->id == GFC_ISYM_NONE)
 650     {
 651       internal_error ("Intrinsic function %s(%d) not recognized",
 652                       expr->value.function.name, id);
 653     }
 654
 655   /* Get the decl and generate the call.  */
 656   args = gfc_conv_intrinsic_function_args (se, expr);
 657   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 658   se->expr = build_function_call_expr (fndecl, args);
 659 }
 660
 661 /* Generate code for EXPONENT(X) intrinsic function.  */
 662
 663 static void
 664 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
 665 {
 666   tree args, fndecl;
 667   gfc_expr *a1;
 668
 669   args = gfc_conv_intrinsic_function_args (se, expr);
 670
 671   a1 = expr->value.function.actual->expr;
 672   switch (a1->ts.kind)
 673     {
 674     case 4:
 675       fndecl = gfor_fndecl_math_exponent4;
 676       break;
 677     case 8:
 678       fndecl = gfor_fndecl_math_exponent8;
 679       break;
 680     case 10:
 681       fndecl = gfor_fndecl_math_exponent10;
 682       break;
 683     case 16:
 684       fndecl = gfor_fndecl_math_exponent16;
 685       break;
 686     default:
 687       gcc_unreachable ();
 688     }
 689
 690   se->expr = build_function_call_expr (fndecl, args);
 691 }
 692
 693 /* Evaluate a single upper or lower bound.  */
 694 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 695
 696 static void
 697 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 698 {
 699   gfc_actual_arglist *arg;
 700   gfc_actual_arglist *arg2;
 701   tree desc;
 702   tree type;
 703   tree bound;
 704   tree tmp;
 705   tree cond;
 706   gfc_se argse;
 707   gfc_ss *ss;
 708   int i;
 709
 710   arg = expr->value.function.actual;
 711   arg2 = arg->next;
 712
 713   if (se->ss)
 714     {
 715       /* Create an implicit second parameter from the loop variable.  */
 716       gcc_assert (!arg2->expr);
 717       gcc_assert (se->loop->dimen == 1);
 718       gcc_assert (se->ss->expr == expr);
 719       gfc_advance_se_ss_chain (se);
 720       bound = se->loop->loopvar[0];
 721       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 722                            se->loop->from[0]);
 723     }
 724   else
 725     {
 726       /* use the passed argument.  */
 727       gcc_assert (arg->next->expr);
 728       gfc_init_se (&argse, NULL);
 729       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 730       gfc_add_block_to_block (&se->pre, &argse.pre);
 731       bound = argse.expr;
 732       /* Convert from one based to zero based.  */
 733       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 734                            gfc_index_one_node);
 735     }
 736
 737   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 738   /* Get a descriptor for the first parameter.  */
 739   ss = gfc_walk_expr (arg->expr);
 740   gcc_assert (ss != gfc_ss_terminator);
 741   gfc_init_se (&argse, NULL);
 742   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 743   gfc_add_block_to_block (&se->pre, &argse.pre);
 744   gfc_add_block_to_block (&se->post, &argse.post);
 745
 746   desc = argse.expr;
 747
 748   if (INTEGER_CST_P (bound))
 749     {
 750       gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
 751       i = TREE_INT_CST_LOW (bound);
 752       gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
 753     }
 754   else
 755     {
 756       if (flag_bounds_check)
 757         {
 758           bound = gfc_evaluate_now (bound, &se->pre);
 759           cond = fold_build2 (LT_EXPR, boolean_type_node,
 760                               bound, build_int_cst (TREE_TYPE (bound), 0));
 761           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 762           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 763           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 764           gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, NULL);
 765         }
 766     }
 767
 768   if (upper)
 769     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 770   else
 771     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 772
 773   type = gfc_typenode_for_spec (&expr->ts);
 774   se->expr = convert (type, se->expr);
 775 }
 776
 777
 778 static void
 779 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 780 {
 781   tree args;
 782   tree val;
 783   int n;
 784
 785   args = gfc_conv_intrinsic_function_args (se, expr);
 786   gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
 787   val = TREE_VALUE (args);
 788
 789   switch (expr->value.function.actual->expr->ts.type)
 790     {
 791     case BT_INTEGER:
 792     case BT_REAL:
 793       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 794       break;
 795
 796     case BT_COMPLEX:
 797       switch (expr->ts.kind)
 798         {
 799         case 4:
 800           n = BUILT_IN_CABSF;
 801           break;
 802         case 8:
 803           n = BUILT_IN_CABS;
 804           break;
 805         case 10:
 806         case 16:
 807           n = BUILT_IN_CABSL;
 808           break;
 809         default:
 810           gcc_unreachable ();
 811         }
 812       se->expr = build_function_call_expr (built_in_decls[n], args);
 813       break;
 814
 815     default:
 816       gcc_unreachable ();
 817     }
 818 }
 819
 820
 821 /* Create a complex value from one or two real components.  */
 822
 823 static void
 824 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 825 {
 826   tree arg;
 827   tree real;
 828   tree imag;
 829   tree type;
 830
 831   type = gfc_typenode_for_spec (&expr->ts);
 832   arg = gfc_conv_intrinsic_function_args (se, expr);
 833   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 834   if (both)
 835     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 836   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 837     {
 838       arg = TREE_VALUE (arg);
 839       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 840       imag = convert (TREE_TYPE (type), imag);
 841     }
 842   else
 843     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 844
 845   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
 846 }
 847
 848 /* Remainder function MOD(A, P) = A - INT(A / P) * P
 849                       MODULO(A, P) = A - FLOOR (A / P) * P  */
 850 /* TODO: MOD(x, 0)  */
 851
 852 static void
 853 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 854 {
 855   tree arg;
 856   tree arg2;
 857   tree type;
 858   tree itype;
 859   tree tmp;
 860   tree test;
 861   tree test2;
 862   mpfr_t huge;
 863   int n;
 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   switch (expr->ts.type)
 871     {
 872     case BT_INTEGER:
 873       /* Integer case is easy, we've got a builtin op.  */
 874       if (modulo)
 875        se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
 876       else
 877        se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
 878       break;
 879
 880     case BT_REAL:
 881       /* Real values we have to do the hard way.  */
 882       arg = gfc_evaluate_now (arg, &se->pre);
 883       arg2 = gfc_evaluate_now (arg2, &se->pre);
 884
 885       tmp = build2 (RDIV_EXPR, type, arg, arg2);
 886       /* Test if the value is too large to handle sensibly.  */
 887       gfc_set_model_kind (expr->ts.kind);
 888       mpfr_init (huge);
 889       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
 890       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 891       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 892       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 893
 894       mpfr_neg (huge, huge, GFC_RND_MODE);
 895       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 896       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 897       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 898
 899       itype = gfc_get_int_type (expr->ts.kind);
 900       if (modulo)
 901        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
 902       else
 903        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 904       tmp = convert (type, tmp);
 905       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 906       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 907       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 908       mpfr_clear (huge);
 909       break;
 910
 911     default:
 912       gcc_unreachable ();
 913     }
 914 }
 915
 916 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 917
 918 static void
 919 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 920 {
 921   tree arg;
 922   tree arg2;
 923   tree val;
 924   tree tmp;
 925   tree type;
 926   tree zero;
 927
 928   arg = gfc_conv_intrinsic_function_args (se, expr);
 929   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 930   arg = TREE_VALUE (arg);
 931   type = TREE_TYPE (arg);
 932
 933   val = build2 (MINUS_EXPR, type, arg, arg2);
 934   val = gfc_evaluate_now (val, &se->pre);
 935
 936   zero = gfc_build_const (type, integer_zero_node);
 937   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 938   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 939 }
 940
 941
 942 /* SIGN(A, B) is absolute value of A times sign of B.
 943    The real value versions use library functions to ensure the correct
 944    handling of negative zero.  Integer case implemented as:
 945    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 946   */
 947
 948 static void
 949 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 950 {
 951   tree tmp;
 952   tree arg;
 953   tree arg2;
 954   tree type;
 955   tree zero;
 956   tree testa;
 957   tree testb;
 958
 959
 960   arg = gfc_conv_intrinsic_function_args (se, expr);
 961   if (expr->ts.type == BT_REAL)
 962     {
 963       switch (expr->ts.kind)
 964         {
 965         case 4:
 966           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 967           break;
 968         case 8:
 969           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 970           break;
 971         case 10:
 972         case 16:
 973           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
 974           break;
 975         default:
 976           gcc_unreachable ();
 977         }
 978       se->expr = build_function_call_expr (tmp, arg);
 979       return;
 980     }
 981
 982   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 983   arg = TREE_VALUE (arg);
 984   type = TREE_TYPE (arg);
 985   zero = gfc_build_const (type, integer_zero_node);
 986
 987   testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
 988   testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
 989   tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
 990   se->expr = fold_build3 (COND_EXPR, type, tmp,
 991                           build1 (NEGATE_EXPR, type, arg), arg);
 992 }
 993
 994
 995 /* Test for the presence of an optional argument.  */
 996
 997 static void
 998 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 999 {
1000   gfc_expr *arg;
1001
1002   arg = expr->value.function.actual->expr;
1003   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1004   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1005   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1006 }
1007
1008
1009 /* Calculate the double precision product of two single precision values.  */
1010
1011 static void
1012 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1013 {
1014   tree arg;
1015   tree arg2;
1016   tree type;
1017
1018   arg = gfc_conv_intrinsic_function_args (se, expr);
1019   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1020   arg = TREE_VALUE (arg);
1021
1022   /* Convert the args to double precision before multiplying.  */
1023   type = gfc_typenode_for_spec (&expr->ts);
1024   arg = convert (type, arg);
1025   arg2 = convert (type, arg2);
1026   se->expr = build2 (MULT_EXPR, type, arg, arg2);
1027 }
1028
1029
1030 /* Return a length one character string containing an ascii character.  */
1031
1032 static void
1033 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1034 {
1035   tree arg;
1036   tree var;
1037   tree type;
1038
1039   arg = gfc_conv_intrinsic_function_args (se, expr);
1040   arg = TREE_VALUE (arg);
1041
1042   /* We currently don't support character types != 1.  */
1043   gcc_assert (expr->ts.kind == 1);
1044   type = gfc_character1_type_node;
1045   var = gfc_create_var (type, "char");
1046
1047   arg = convert (type, arg);
1048   gfc_add_modify_expr (&se->pre, var, arg);
1049   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1050   se->string_length = integer_one_node;
1051 }
1052
1053
1054 static void
1055 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1056 {
1057   tree var;
1058   tree len;
1059   tree tmp;
1060   tree arglist;
1061   tree type;
1062   tree cond;
1063   tree gfc_int8_type_node = gfc_get_int_type (8);
1064
1065   type = build_pointer_type (gfc_character1_type_node);
1066   var = gfc_create_var (type, "pstr");
1067   len = gfc_create_var (gfc_int8_type_node, "len");
1068
1069   tmp = gfc_conv_intrinsic_function_args (se, expr);
1070   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1071   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1072   arglist = chainon (arglist, tmp);
1073
1074   tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
1075   gfc_add_expr_to_block (&se->pre, tmp);
1076
1077   /* Free the temporary afterwards, if necessary.  */
1078   cond = build2 (GT_EXPR, boolean_type_node, len,
1079                  build_int_cst (TREE_TYPE (len), 0));
1080   arglist = gfc_chainon_list (NULL_TREE, var);
1081   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1082   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1083   gfc_add_expr_to_block (&se->post, tmp);
1084
1085   se->expr = var;
1086   se->string_length = len;
1087 }
1088
1089
1090 static void
1091 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1092 {
1093   tree var;
1094   tree len;
1095   tree tmp;
1096   tree arglist;
1097   tree type;
1098   tree cond;
1099   tree gfc_int4_type_node = gfc_get_int_type (4);
1100
1101   type = build_pointer_type (gfc_character1_type_node);
1102   var = gfc_create_var (type, "pstr");
1103   len = gfc_create_var (gfc_int4_type_node, "len");
1104
1105   tmp = gfc_conv_intrinsic_function_args (se, expr);
1106   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1107   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1108   arglist = chainon (arglist, tmp);
1109
1110   tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
1111   gfc_add_expr_to_block (&se->pre, tmp);
1112
1113   /* Free the temporary afterwards, if necessary.  */
1114   cond = build2 (GT_EXPR, boolean_type_node, len,
1115                  build_int_cst (TREE_TYPE (len), 0));
1116   arglist = gfc_chainon_list (NULL_TREE, var);
1117   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1118   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1119   gfc_add_expr_to_block (&se->post, tmp);
1120
1121   se->expr = var;
1122   se->string_length = len;
1123 }
1124
1125
1126 /* Return a character string containing the tty name.  */
1127
1128 static void
1129 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1130 {
1131   tree var;
1132   tree len;
1133   tree tmp;
1134   tree arglist;
1135   tree type;
1136   tree cond;
1137   tree gfc_int4_type_node = gfc_get_int_type (4);
1138
1139   type = build_pointer_type (gfc_character1_type_node);
1140   var = gfc_create_var (type, "pstr");
1141   len = gfc_create_var (gfc_int4_type_node, "len");
1142
1143   tmp = gfc_conv_intrinsic_function_args (se, expr);
1144   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1145   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1146   arglist = chainon (arglist, tmp);
1147
1148   tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
1149   gfc_add_expr_to_block (&se->pre, tmp);
1150
1151   /* Free the temporary afterwards, if necessary.  */
1152   cond = build2 (GT_EXPR, boolean_type_node, len,
1153                  build_int_cst (TREE_TYPE (len), 0));
1154   arglist = gfc_chainon_list (NULL_TREE, var);
1155   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1156   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1157   gfc_add_expr_to_block (&se->post, tmp);
1158
1159   se->expr = var;
1160   se->string_length = len;
1161 }
1162
1163
1164 /* Get the minimum/maximum value of all the parameters.
1165     minmax (a1, a2, a3, ...)
1166     {
1167       if (a2 .op. a1)
1168         mvar = a2;
1169       else
1170         mvar = a1;
1171       if (a3 .op. mvar)
1172         mvar = a3;
1173       ...
1174       return mvar
1175     }
1176  */
1177
1178 /* TODO: Mismatching types can occur when specific names are used.
1179    These should be handled during resolution.  */
1180 static void
1181 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1182 {
1183   tree limit;
1184   tree tmp;
1185   tree mvar;
1186   tree val;
1187   tree thencase;
1188   tree elsecase;
1189   tree arg;
1190   tree type;
1191
1192   arg = gfc_conv_intrinsic_function_args (se, expr);
1193   type = gfc_typenode_for_spec (&expr->ts);
1194
1195   limit = TREE_VALUE (arg);
1196   if (TREE_TYPE (limit) != type)
1197     limit = convert (type, limit);
1198   /* Only evaluate the argument once.  */
1199   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1200     limit = gfc_evaluate_now(limit, &se->pre);
1201
1202   mvar = gfc_create_var (type, "M");
1203   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1204   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1205     {
1206       val = TREE_VALUE (arg);
1207       if (TREE_TYPE (val) != type)
1208         val = convert (type, val);
1209
1210       /* Only evaluate the argument once.  */
1211       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1212         val = gfc_evaluate_now(val, &se->pre);
1213
1214       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1215
1216       tmp = build2 (op, boolean_type_node, val, limit);
1217       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1218       gfc_add_expr_to_block (&se->pre, tmp);
1219       elsecase = build_empty_stmt ();
1220       limit = mvar;
1221     }
1222   se->expr = mvar;
1223 }
1224
1225
1226 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1227    has the generic name.  */
1228
1229 static gfc_symbol *
1230 gfc_get_symbol_for_expr (gfc_expr * expr)
1231 {
1232   gfc_symbol *sym;
1233
1234   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1235   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1236   sym = gfc_new_symbol (expr->value.function.name, NULL);
1237
1238   sym->ts = expr->ts;
1239   sym->attr.external = 1;
1240   sym->attr.function = 1;
1241   sym->attr.always_explicit = 1;
1242   sym->attr.proc = PROC_INTRINSIC;
1243   sym->attr.flavor = FL_PROCEDURE;
1244   sym->result = sym;
1245   if (expr->rank > 0)
1246     {
1247       sym->attr.dimension = 1;
1248       sym->as = gfc_get_array_spec ();
1249       sym->as->type = AS_ASSUMED_SHAPE;
1250       sym->as->rank = expr->rank;
1251     }
1252
1253   /* TODO: proper argument lists for external intrinsics.  */
1254   return sym;
1255 }
1256
1257 /* Generate a call to an external intrinsic function.  */
1258 static void
1259 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1260 {
1261   gfc_symbol *sym;
1262
1263   gcc_assert (!se->ss || se->ss->expr == expr);
1264
1265   if (se->ss)
1266     gcc_assert (expr->rank > 0);
1267   else
1268     gcc_assert (expr->rank == 0);
1269
1270   sym = gfc_get_symbol_for_expr (expr);
1271   gfc_conv_function_call (se, sym, expr->value.function.actual);
1272   gfc_free (sym);
1273 }
1274
1275 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1276    Implemented as
1277     any(a)
1278     {
1279       forall (i=...)
1280         if (a[i] != 0)
1281           return 1
1282       end forall
1283       return 0
1284     }
1285     all(a)
1286     {
1287       forall (i=...)
1288         if (a[i] == 0)
1289           return 0
1290       end forall
1291       return 1
1292     }
1293  */
1294 static void
1295 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1296 {
1297   tree resvar;
1298   stmtblock_t block;
1299   stmtblock_t body;
1300   tree type;
1301   tree tmp;
1302   tree found;
1303   gfc_loopinfo loop;
1304   gfc_actual_arglist *actual;
1305   gfc_ss *arrayss;
1306   gfc_se arrayse;
1307   tree exit_label;
1308
1309   if (se->ss)
1310     {
1311       gfc_conv_intrinsic_funcall (se, expr);
1312       return;
1313     }
1314
1315   actual = expr->value.function.actual;
1316   type = gfc_typenode_for_spec (&expr->ts);
1317   /* Initialize the result.  */
1318   resvar = gfc_create_var (type, "test");
1319   if (op == EQ_EXPR)
1320     tmp = convert (type, boolean_true_node);
1321   else
1322     tmp = convert (type, boolean_false_node);
1323   gfc_add_modify_expr (&se->pre, resvar, tmp);
1324
1325   /* Walk the arguments.  */
1326   arrayss = gfc_walk_expr (actual->expr);
1327   gcc_assert (arrayss != gfc_ss_terminator);
1328
1329   /* Initialize the scalarizer.  */
1330   gfc_init_loopinfo (&loop);
1331   exit_label = gfc_build_label_decl (NULL_TREE);
1332   TREE_USED (exit_label) = 1;
1333   gfc_add_ss_to_loop (&loop, arrayss);
1334
1335   /* Initialize the loop.  */
1336   gfc_conv_ss_startstride (&loop);
1337   gfc_conv_loop_setup (&loop);
1338
1339   gfc_mark_ss_chain_used (arrayss, 1);
1340   /* Generate the loop body.  */
1341   gfc_start_scalarized_body (&loop, &body);
1342
1343   /* If the condition matches then set the return value.  */
1344   gfc_start_block (&block);
1345   if (op == EQ_EXPR)
1346     tmp = convert (type, boolean_false_node);
1347   else
1348     tmp = convert (type, boolean_true_node);
1349   gfc_add_modify_expr (&block, resvar, tmp);
1350
1351   /* And break out of the loop.  */
1352   tmp = build1_v (GOTO_EXPR, exit_label);
1353   gfc_add_expr_to_block (&block, tmp);
1354
1355   found = gfc_finish_block (&block);
1356
1357   /* Check this element.  */
1358   gfc_init_se (&arrayse, NULL);
1359   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1360   arrayse.ss = arrayss;
1361   gfc_conv_expr_val (&arrayse, actual->expr);
1362
1363   gfc_add_block_to_block (&body, &arrayse.pre);
1364   tmp = build2 (op, boolean_type_node, arrayse.expr,
1365                 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1366   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1367   gfc_add_expr_to_block (&body, tmp);
1368   gfc_add_block_to_block (&body, &arrayse.post);
1369
1370   gfc_trans_scalarizing_loops (&loop, &body);
1371
1372   /* Add the exit label.  */
1373   tmp = build1_v (LABEL_EXPR, exit_label);
1374   gfc_add_expr_to_block (&loop.pre, tmp);
1375
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 /* COUNT(A) = Number of true elements in A.  */
1384 static void
1385 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1386 {
1387   tree resvar;
1388   tree type;
1389   stmtblock_t body;
1390   tree tmp;
1391   gfc_loopinfo loop;
1392   gfc_actual_arglist *actual;
1393   gfc_ss *arrayss;
1394   gfc_se arrayse;
1395
1396   if (se->ss)
1397     {
1398       gfc_conv_intrinsic_funcall (se, expr);
1399       return;
1400     }
1401
1402   actual = expr->value.function.actual;
1403
1404   type = gfc_typenode_for_spec (&expr->ts);
1405   /* Initialize the result.  */
1406   resvar = gfc_create_var (type, "count");
1407   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1408
1409   /* Walk the arguments.  */
1410   arrayss = gfc_walk_expr (actual->expr);
1411   gcc_assert (arrayss != gfc_ss_terminator);
1412
1413   /* Initialize the scalarizer.  */
1414   gfc_init_loopinfo (&loop);
1415   gfc_add_ss_to_loop (&loop, arrayss);
1416
1417   /* Initialize the loop.  */
1418   gfc_conv_ss_startstride (&loop);
1419   gfc_conv_loop_setup (&loop);
1420
1421   gfc_mark_ss_chain_used (arrayss, 1);
1422   /* Generate the loop body.  */
1423   gfc_start_scalarized_body (&loop, &body);
1424
1425   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1426                 build_int_cst (TREE_TYPE (resvar), 1));
1427   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1428
1429   gfc_init_se (&arrayse, NULL);
1430   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1431   arrayse.ss = arrayss;
1432   gfc_conv_expr_val (&arrayse, actual->expr);
1433   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1434
1435   gfc_add_block_to_block (&body, &arrayse.pre);
1436   gfc_add_expr_to_block (&body, tmp);
1437   gfc_add_block_to_block (&body, &arrayse.post);
1438
1439   gfc_trans_scalarizing_loops (&loop, &body);
1440
1441   gfc_add_block_to_block (&se->pre, &loop.pre);
1442   gfc_add_block_to_block (&se->pre, &loop.post);
1443   gfc_cleanup_loop (&loop);
1444
1445   se->expr = resvar;
1446 }
1447
1448 /* Inline implementation of the sum and product intrinsics.  */
1449 static void
1450 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1451 {
1452   tree resvar;
1453   tree type;
1454   stmtblock_t body;
1455   stmtblock_t block;
1456   tree tmp;
1457   gfc_loopinfo loop;
1458   gfc_actual_arglist *actual;
1459   gfc_ss *arrayss;
1460   gfc_ss *maskss;
1461   gfc_se arrayse;
1462   gfc_se maskse;
1463   gfc_expr *arrayexpr;
1464   gfc_expr *maskexpr;
1465
1466   if (se->ss)
1467     {
1468       gfc_conv_intrinsic_funcall (se, expr);
1469       return;
1470     }
1471
1472   type = gfc_typenode_for_spec (&expr->ts);
1473   /* Initialize the result.  */
1474   resvar = gfc_create_var (type, "val");
1475   if (op == PLUS_EXPR)
1476     tmp = gfc_build_const (type, integer_zero_node);
1477   else
1478     tmp = gfc_build_const (type, integer_one_node);
1479
1480   gfc_add_modify_expr (&se->pre, resvar, tmp);
1481
1482   /* Walk the arguments.  */
1483   actual = expr->value.function.actual;
1484   arrayexpr = actual->expr;
1485   arrayss = gfc_walk_expr (arrayexpr);
1486   gcc_assert (arrayss != gfc_ss_terminator);
1487
1488   actual = actual->next->next;
1489   gcc_assert (actual);
1490   maskexpr = actual->expr;
1491   if (maskexpr && maskexpr->rank != 0)
1492     {
1493       maskss = gfc_walk_expr (maskexpr);
1494       gcc_assert (maskss != gfc_ss_terminator);
1495     }
1496   else
1497     maskss = NULL;
1498
1499   /* Initialize the scalarizer.  */
1500   gfc_init_loopinfo (&loop);
1501   gfc_add_ss_to_loop (&loop, arrayss);
1502   if (maskss)
1503     gfc_add_ss_to_loop (&loop, maskss);
1504
1505   /* Initialize the loop.  */
1506   gfc_conv_ss_startstride (&loop);
1507   gfc_conv_loop_setup (&loop);
1508
1509   gfc_mark_ss_chain_used (arrayss, 1);
1510   if (maskss)
1511     gfc_mark_ss_chain_used (maskss, 1);
1512   /* Generate the loop body.  */
1513   gfc_start_scalarized_body (&loop, &body);
1514
1515   /* If we have a mask, only add this element if the mask is set.  */
1516   if (maskss)
1517     {
1518       gfc_init_se (&maskse, NULL);
1519       gfc_copy_loopinfo_to_se (&maskse, &loop);
1520       maskse.ss = maskss;
1521       gfc_conv_expr_val (&maskse, maskexpr);
1522       gfc_add_block_to_block (&body, &maskse.pre);
1523
1524       gfc_start_block (&block);
1525     }
1526   else
1527     gfc_init_block (&block);
1528
1529   /* Do the actual summation/product.  */
1530   gfc_init_se (&arrayse, NULL);
1531   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1532   arrayse.ss = arrayss;
1533   gfc_conv_expr_val (&arrayse, arrayexpr);
1534   gfc_add_block_to_block (&block, &arrayse.pre);
1535
1536   tmp = build2 (op, type, resvar, arrayse.expr);
1537   gfc_add_modify_expr (&block, resvar, tmp);
1538   gfc_add_block_to_block (&block, &arrayse.post);
1539
1540   if (maskss)
1541     {
1542       /* We enclose the above in if (mask) {...} .  */
1543       tmp = gfc_finish_block (&block);
1544
1545       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1546     }
1547   else
1548     tmp = gfc_finish_block (&block);
1549   gfc_add_expr_to_block (&body, tmp);
1550
1551   gfc_trans_scalarizing_loops (&loop, &body);
1552
1553   /* For a scalar mask, enclose the loop in an if statement.  */
1554   if (maskexpr && maskss == NULL)
1555     {
1556       gfc_init_se (&maskse, NULL);
1557       gfc_conv_expr_val (&maskse, maskexpr);
1558       gfc_init_block (&block);
1559       gfc_add_block_to_block (&block, &loop.pre);
1560       gfc_add_block_to_block (&block, &loop.post);
1561       tmp = gfc_finish_block (&block);
1562
1563       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1564       gfc_add_expr_to_block (&block, tmp);
1565       gfc_add_block_to_block (&se->pre, &block);
1566     }
1567   else
1568     {
1569       gfc_add_block_to_block (&se->pre, &loop.pre);
1570       gfc_add_block_to_block (&se->pre, &loop.post);
1571     }
1572
1573   gfc_cleanup_loop (&loop);
1574
1575   se->expr = resvar;
1576 }
1577
1578
1579 /* Inline implementation of the dot_product intrinsic. This function
1580    is based on gfc_conv_intrinsic_arith (the previous function).  */
1581 static void
1582 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1583 {
1584   tree resvar;
1585   tree type;
1586   stmtblock_t body;
1587   stmtblock_t block;
1588   tree tmp;
1589   gfc_loopinfo loop;
1590   gfc_actual_arglist *actual;
1591   gfc_ss *arrayss1, *arrayss2;
1592   gfc_se arrayse1, arrayse2;
1593   gfc_expr *arrayexpr1, *arrayexpr2;
1594
1595   type = gfc_typenode_for_spec (&expr->ts);
1596
1597   /* Initialize the result.  */
1598   resvar = gfc_create_var (type, "val");
1599   if (expr->ts.type == BT_LOGICAL)
1600     tmp = convert (type, integer_zero_node);
1601   else
1602     tmp = gfc_build_const (type, integer_zero_node);
1603
1604   gfc_add_modify_expr (&se->pre, resvar, tmp);
1605
1606   /* Walk argument #1.  */
1607   actual = expr->value.function.actual;
1608   arrayexpr1 = actual->expr;
1609   arrayss1 = gfc_walk_expr (arrayexpr1);
1610   gcc_assert (arrayss1 != gfc_ss_terminator);
1611
1612   /* Walk argument #2.  */
1613   actual = actual->next;
1614   arrayexpr2 = actual->expr;
1615   arrayss2 = gfc_walk_expr (arrayexpr2);
1616   gcc_assert (arrayss2 != gfc_ss_terminator);
1617
1618   /* Initialize the scalarizer.  */
1619   gfc_init_loopinfo (&loop);
1620   gfc_add_ss_to_loop (&loop, arrayss1);
1621   gfc_add_ss_to_loop (&loop, arrayss2);
1622
1623   /* Initialize the loop.  */
1624   gfc_conv_ss_startstride (&loop);
1625   gfc_conv_loop_setup (&loop);
1626
1627   gfc_mark_ss_chain_used (arrayss1, 1);
1628   gfc_mark_ss_chain_used (arrayss2, 1);
1629
1630   /* Generate the loop body.  */
1631   gfc_start_scalarized_body (&loop, &body);
1632   gfc_init_block (&block);
1633
1634   /* Make the tree expression for [conjg(]array1[)].  */
1635   gfc_init_se (&arrayse1, NULL);
1636   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
1637   arrayse1.ss = arrayss1;
1638   gfc_conv_expr_val (&arrayse1, arrayexpr1);
1639   if (expr->ts.type == BT_COMPLEX)
1640     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
1641   gfc_add_block_to_block (&block, &arrayse1.pre);
1642
1643   /* Make the tree expression for array2.  */
1644   gfc_init_se (&arrayse2, NULL);
1645   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
1646   arrayse2.ss = arrayss2;
1647   gfc_conv_expr_val (&arrayse2, arrayexpr2);
1648   gfc_add_block_to_block (&block, &arrayse2.pre);
1649
1650   /* Do the actual product and sum.  */
1651   if (expr->ts.type == BT_LOGICAL)
1652     {
1653       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
1654       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
1655     }
1656   else
1657     {
1658       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
1659       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
1660     }
1661   gfc_add_modify_expr (&block, resvar, tmp);
1662
1663   /* Finish up the loop block and the loop.  */
1664   tmp = gfc_finish_block (&block);
1665   gfc_add_expr_to_block (&body, tmp);
1666
1667   gfc_trans_scalarizing_loops (&loop, &body);
1668   gfc_add_block_to_block (&se->pre, &loop.pre);
1669   gfc_add_block_to_block (&se->pre, &loop.post);
1670   gfc_cleanup_loop (&loop);
1671
1672   se->expr = resvar;
1673 }
1674
1675
1676 static void
1677 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1678 {
1679   stmtblock_t body;
1680   stmtblock_t block;
1681   stmtblock_t ifblock;
1682   stmtblock_t elseblock;
1683   tree limit;
1684   tree type;
1685   tree tmp;
1686   tree elsetmp;
1687   tree ifbody;
1688   gfc_loopinfo loop;
1689   gfc_actual_arglist *actual;
1690   gfc_ss *arrayss;
1691   gfc_ss *maskss;
1692   gfc_se arrayse;
1693   gfc_se maskse;
1694   gfc_expr *arrayexpr;
1695   gfc_expr *maskexpr;
1696   tree pos;
1697   int n;
1698
1699   if (se->ss)
1700     {
1701       gfc_conv_intrinsic_funcall (se, expr);
1702       return;
1703     }
1704
1705   /* Initialize the result.  */
1706   pos = gfc_create_var (gfc_array_index_type, "pos");
1707   type = gfc_typenode_for_spec (&expr->ts);
1708
1709   /* Walk the arguments.  */
1710   actual = expr->value.function.actual;
1711   arrayexpr = actual->expr;
1712   arrayss = gfc_walk_expr (arrayexpr);
1713   gcc_assert (arrayss != gfc_ss_terminator);
1714
1715   actual = actual->next->next;
1716   gcc_assert (actual);
1717   maskexpr = actual->expr;
1718   if (maskexpr && maskexpr->rank != 0)
1719     {
1720       maskss = gfc_walk_expr (maskexpr);
1721       gcc_assert (maskss != gfc_ss_terminator);
1722     }
1723   else
1724     maskss = NULL;
1725
1726   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1727   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1728   switch (arrayexpr->ts.type)
1729     {
1730     case BT_REAL:
1731       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1732       break;
1733
1734     case BT_INTEGER:
1735       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1736                                   arrayexpr->ts.kind);
1737       break;
1738
1739     default:
1740       gcc_unreachable ();
1741     }
1742
1743   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1744   if (op == GT_EXPR)
1745     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1746   gfc_add_modify_expr (&se->pre, limit, tmp);
1747
1748   /* Initialize the scalarizer.  */
1749   gfc_init_loopinfo (&loop);
1750   gfc_add_ss_to_loop (&loop, arrayss);
1751   if (maskss)
1752     gfc_add_ss_to_loop (&loop, maskss);
1753
1754   /* Initialize the loop.  */
1755   gfc_conv_ss_startstride (&loop);
1756   gfc_conv_loop_setup (&loop);
1757
1758   gcc_assert (loop.dimen == 1);
1759
1760   /* Initialize the position to zero, following Fortran 2003.  We are free
1761      to do this because Fortran 95 allows the result of an entirely false
1762      mask to be processor dependent.  */
1763   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
1764
1765   gfc_mark_ss_chain_used (arrayss, 1);
1766   if (maskss)
1767     gfc_mark_ss_chain_used (maskss, 1);
1768   /* Generate the loop body.  */
1769   gfc_start_scalarized_body (&loop, &body);
1770
1771   /* If we have a mask, only check this element if the mask is set.  */
1772   if (maskss)
1773     {
1774       gfc_init_se (&maskse, NULL);
1775       gfc_copy_loopinfo_to_se (&maskse, &loop);
1776       maskse.ss = maskss;
1777       gfc_conv_expr_val (&maskse, maskexpr);
1778       gfc_add_block_to_block (&body, &maskse.pre);
1779
1780       gfc_start_block (&block);
1781     }
1782   else
1783     gfc_init_block (&block);
1784
1785   /* Compare with the current limit.  */
1786   gfc_init_se (&arrayse, NULL);
1787   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1788   arrayse.ss = arrayss;
1789   gfc_conv_expr_val (&arrayse, arrayexpr);
1790   gfc_add_block_to_block (&block, &arrayse.pre);
1791
1792   /* We do the following if this is a more extreme value.  */
1793   gfc_start_block (&ifblock);
1794
1795   /* Assign the value to the limit...  */
1796   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1797
1798   /* Remember where we are.  */
1799   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1800
1801   ifbody = gfc_finish_block (&ifblock);
1802
1803   /* If it is a more extreme value or pos is still zero.  */
1804   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
1805                   build2 (op, boolean_type_node, arrayse.expr, limit),
1806                   build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
1807   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1808   gfc_add_expr_to_block (&block, tmp);
1809
1810   if (maskss)
1811     {
1812       /* We enclose the above in if (mask) {...}.  */
1813       tmp = gfc_finish_block (&block);
1814
1815       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1816     }
1817   else
1818     tmp = gfc_finish_block (&block);
1819   gfc_add_expr_to_block (&body, tmp);
1820
1821   gfc_trans_scalarizing_loops (&loop, &body);
1822
1823   /* For a scalar mask, enclose the loop in an if statement.  */
1824   if (maskexpr && maskss == NULL)
1825     {
1826       gfc_init_se (&maskse, NULL);
1827       gfc_conv_expr_val (&maskse, maskexpr);
1828       gfc_init_block (&block);
1829       gfc_add_block_to_block (&block, &loop.pre);
1830       gfc_add_block_to_block (&block, &loop.post);
1831       tmp = gfc_finish_block (&block);
1832
1833       /* For the else part of the scalar mask, just initialize
1834          the pos variable the same way as above.  */
1835
1836       gfc_init_block (&elseblock);
1837       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
1838       elsetmp = gfc_finish_block (&elseblock);
1839
1840       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
1841       gfc_add_expr_to_block (&block, tmp);
1842       gfc_add_block_to_block (&se->pre, &block);
1843     }
1844   else
1845     {
1846       gfc_add_block_to_block (&se->pre, &loop.pre);
1847       gfc_add_block_to_block (&se->pre, &loop.post);
1848     }
1849   gfc_cleanup_loop (&loop);
1850
1851   /* Return a value in the range 1..SIZE(array).  */
1852   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1853                      gfc_index_one_node);
1854   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
1855   /* And convert to the required type.  */
1856   se->expr = convert (type, tmp);
1857 }
1858
1859 static void
1860 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1861 {
1862   tree limit;
1863   tree type;
1864   tree tmp;
1865   tree ifbody;
1866   stmtblock_t body;
1867   stmtblock_t block;
1868   gfc_loopinfo loop;
1869   gfc_actual_arglist *actual;
1870   gfc_ss *arrayss;
1871   gfc_ss *maskss;
1872   gfc_se arrayse;
1873   gfc_se maskse;
1874   gfc_expr *arrayexpr;
1875   gfc_expr *maskexpr;
1876   int n;
1877
1878   if (se->ss)
1879     {
1880       gfc_conv_intrinsic_funcall (se, expr);
1881       return;
1882     }
1883
1884   type = gfc_typenode_for_spec (&expr->ts);
1885   /* Initialize the result.  */
1886   limit = gfc_create_var (type, "limit");
1887   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1888   switch (expr->ts.type)
1889     {
1890     case BT_REAL:
1891       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1892       break;
1893
1894     case BT_INTEGER:
1895       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1896       break;
1897
1898     default:
1899       gcc_unreachable ();
1900     }
1901
1902   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1903   if (op == GT_EXPR)
1904     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1905   gfc_add_modify_expr (&se->pre, limit, tmp);
1906
1907   /* Walk the arguments.  */
1908   actual = expr->value.function.actual;
1909   arrayexpr = actual->expr;
1910   arrayss = gfc_walk_expr (arrayexpr);
1911   gcc_assert (arrayss != gfc_ss_terminator);
1912
1913   actual = actual->next->next;
1914   gcc_assert (actual);
1915   maskexpr = actual->expr;
1916   if (maskexpr && maskexpr->rank != 0)
1917     {
1918       maskss = gfc_walk_expr (maskexpr);
1919       gcc_assert (maskss != gfc_ss_terminator);
1920     }
1921   else
1922     maskss = NULL;
1923
1924   /* Initialize the scalarizer.  */
1925   gfc_init_loopinfo (&loop);
1926   gfc_add_ss_to_loop (&loop, arrayss);
1927   if (maskss)
1928     gfc_add_ss_to_loop (&loop, maskss);
1929
1930   /* Initialize the loop.  */
1931   gfc_conv_ss_startstride (&loop);
1932   gfc_conv_loop_setup (&loop);
1933
1934   gfc_mark_ss_chain_used (arrayss, 1);
1935   if (maskss)
1936     gfc_mark_ss_chain_used (maskss, 1);
1937   /* Generate the loop body.  */
1938   gfc_start_scalarized_body (&loop, &body);
1939
1940   /* If we have a mask, only add this element if the mask is set.  */
1941   if (maskss)
1942     {
1943       gfc_init_se (&maskse, NULL);
1944       gfc_copy_loopinfo_to_se (&maskse, &loop);
1945       maskse.ss = maskss;
1946       gfc_conv_expr_val (&maskse, maskexpr);
1947       gfc_add_block_to_block (&body, &maskse.pre);
1948
1949       gfc_start_block (&block);
1950     }
1951   else
1952     gfc_init_block (&block);
1953
1954   /* Compare with the current limit.  */
1955   gfc_init_se (&arrayse, NULL);
1956   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1957   arrayse.ss = arrayss;
1958   gfc_conv_expr_val (&arrayse, arrayexpr);
1959   gfc_add_block_to_block (&block, &arrayse.pre);
1960
1961   /* Assign the value to the limit...  */
1962   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1963
1964   /* If it is a more extreme value.  */
1965   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1966   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1967   gfc_add_expr_to_block (&block, tmp);
1968   gfc_add_block_to_block (&block, &arrayse.post);
1969
1970   tmp = gfc_finish_block (&block);
1971   if (maskss)
1972     /* We enclose the above in if (mask) {...}.  */
1973     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1974   gfc_add_expr_to_block (&body, tmp);
1975
1976   gfc_trans_scalarizing_loops (&loop, &body);
1977
1978   /* For a scalar mask, enclose the loop in an if statement.  */
1979   if (maskexpr && maskss == NULL)
1980     {
1981       gfc_init_se (&maskse, NULL);
1982       gfc_conv_expr_val (&maskse, maskexpr);
1983       gfc_init_block (&block);
1984       gfc_add_block_to_block (&block, &loop.pre);
1985       gfc_add_block_to_block (&block, &loop.post);
1986       tmp = gfc_finish_block (&block);
1987
1988       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1989       gfc_add_expr_to_block (&block, tmp);
1990       gfc_add_block_to_block (&se->pre, &block);
1991     }
1992   else
1993     {
1994       gfc_add_block_to_block (&se->pre, &loop.pre);
1995       gfc_add_block_to_block (&se->pre, &loop.post);
1996     }
1997
1998   gfc_cleanup_loop (&loop);
1999
2000   se->expr = limit;
2001 }
2002
2003 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2004 static void
2005 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2006 {
2007   tree arg;
2008   tree arg2;
2009   tree type;
2010   tree tmp;
2011
2012   arg = gfc_conv_intrinsic_function_args (se, expr);
2013   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2014   arg = TREE_VALUE (arg);
2015   type = TREE_TYPE (arg);
2016
2017   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2018   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
2019   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2020                      build_int_cst (type, 0));
2021   type = gfc_typenode_for_spec (&expr->ts);
2022   se->expr = convert (type, tmp);
2023 }
2024
2025 /* Generate code to perform the specified operation.  */
2026 static void
2027 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2028 {
2029   tree arg;
2030   tree arg2;
2031   tree type;
2032
2033   arg = gfc_conv_intrinsic_function_args (se, expr);
2034   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2035   arg = TREE_VALUE (arg);
2036   type = TREE_TYPE (arg);
2037
2038   se->expr = fold_build2 (op, type, arg, arg2);
2039 }
2040
2041 /* Bitwise not.  */
2042 static void
2043 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2044 {
2045   tree arg;
2046
2047   arg = gfc_conv_intrinsic_function_args (se, expr);
2048   arg = TREE_VALUE (arg);
2049
2050   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2051 }
2052
2053 /* Set or clear a single bit.  */
2054 static void
2055 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2056 {
2057   tree arg;
2058   tree arg2;
2059   tree type;
2060   tree tmp;
2061   int op;
2062
2063   arg = gfc_conv_intrinsic_function_args (se, expr);
2064   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2065   arg = TREE_VALUE (arg);
2066   type = TREE_TYPE (arg);
2067
2068   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2069   if (set)
2070     op = BIT_IOR_EXPR;
2071   else
2072     {
2073       op = BIT_AND_EXPR;
2074       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2075     }
2076   se->expr = fold_build2 (op, type, arg, tmp);
2077 }
2078
2079 /* Extract a sequence of bits.
2080     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2081 static void
2082 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2083 {
2084   tree arg;
2085   tree arg2;
2086   tree arg3;
2087   tree type;
2088   tree tmp;
2089   tree mask;
2090
2091   arg = gfc_conv_intrinsic_function_args (se, expr);
2092   arg2 = TREE_CHAIN (arg);
2093   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
2094   arg = TREE_VALUE (arg);
2095   arg2 = TREE_VALUE (arg2);
2096   type = TREE_TYPE (arg);
2097
2098   mask = build_int_cst (NULL_TREE, -1);
2099   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
2100   mask = build1 (BIT_NOT_EXPR, type, mask);
2101
2102   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
2103
2104   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2105 }
2106
2107 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2108                         ? 0
2109                         : ((shift >= 0) ? i << shift : i >> -shift)
2110    where all shifts are logical shifts.  */
2111 static void
2112 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2113 {
2114   tree arg;
2115   tree arg2;
2116   tree type;
2117   tree utype;
2118   tree tmp;
2119   tree width;
2120   tree num_bits;
2121   tree cond;
2122   tree lshift;
2123   tree rshift;
2124
2125   arg = gfc_conv_intrinsic_function_args (se, expr);
2126   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2127   arg = TREE_VALUE (arg);
2128   type = TREE_TYPE (arg);
2129   utype = gfc_unsigned_type (type);
2130
2131   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2132
2133   /* Left shift if positive.  */
2134   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2135
2136   /* Right shift if negative.
2137      We convert to an unsigned type because we want a logical shift.
2138      The standard doesn't define the case of shifting negative
2139      numbers, and we try to be compatible with other compilers, most
2140      notably g77, here.  */
2141   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2142                                        convert (utype, arg), width));
2143
2144   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2145                      build_int_cst (TREE_TYPE (arg2), 0));
2146   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2147
2148   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2149      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2150      special case.  */
2151   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2152   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2153
2154   se->expr = fold_build3 (COND_EXPR, type, cond,
2155                           build_int_cst (type, 0), tmp);
2156 }
2157
2158 /* Circular shift.  AKA rotate or barrel shift.  */
2159 static void
2160 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2161 {
2162   tree arg;
2163   tree arg2;
2164   tree arg3;
2165   tree type;
2166   tree tmp;
2167   tree lrot;
2168   tree rrot;
2169   tree zero;
2170
2171   arg = gfc_conv_intrinsic_function_args (se, expr);
2172   arg2 = TREE_CHAIN (arg);
2173   arg3 = TREE_CHAIN (arg2);
2174   if (arg3)
2175     {
2176       /* Use a library function for the 3 parameter version.  */
2177       tree int4type = gfc_get_int_type (4);
2178
2179       type = TREE_TYPE (TREE_VALUE (arg));
2180       /* We convert the first argument to at least 4 bytes, and
2181          convert back afterwards.  This removes the need for library
2182          functions for all argument sizes, and function will be
2183          aligned to at least 32 bits, so there's no loss.  */
2184       if (expr->ts.kind < 4)
2185         {
2186           tmp = convert (int4type, TREE_VALUE (arg));
2187           TREE_VALUE (arg) = tmp;
2188         }
2189       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2190          need loads of library  functions.  They cannot have values >
2191          BIT_SIZE (I) so the conversion is safe.  */
2192       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2193       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2194
2195       switch (expr->ts.kind)
2196         {
2197         case 1:
2198         case 2:
2199         case 4:
2200           tmp = gfor_fndecl_math_ishftc4;
2201           break;
2202         case 8:
2203           tmp = gfor_fndecl_math_ishftc8;
2204           break;
2205         case 16:
2206           tmp = gfor_fndecl_math_ishftc16;
2207           break;
2208         default:
2209           gcc_unreachable ();
2210         }
2211       se->expr = build_function_call_expr (tmp, arg);
2212       /* Convert the result back to the original type, if we extended
2213          the first argument's width above.  */
2214       if (expr->ts.kind < 4)
2215         se->expr = convert (type, se->expr);
2216
2217       return;
2218     }
2219   arg = TREE_VALUE (arg);
2220   arg2 = TREE_VALUE (arg2);
2221   type = TREE_TYPE (arg);
2222
2223   /* Rotate left if positive.  */
2224   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2225
2226   /* Rotate right if negative.  */
2227   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2228   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2229
2230   zero = build_int_cst (TREE_TYPE (arg2), 0);
2231   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2232   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2233
2234   /* Do nothing if shift == 0.  */
2235   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2236   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2237 }
2238
2239 /* The length of a character string.  */
2240 static void
2241 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2242 {
2243   tree len;
2244   tree type;
2245   tree decl;
2246   gfc_symbol *sym;
2247   gfc_se argse;
2248   gfc_expr *arg;
2249
2250   gcc_assert (!se->ss);
2251
2252   arg = expr->value.function.actual->expr;
2253
2254   type = gfc_typenode_for_spec (&expr->ts);
2255   switch (arg->expr_type)
2256     {
2257     case EXPR_CONSTANT:
2258       len = build_int_cst (NULL_TREE, arg->value.character.length);
2259       break;
2260
2261     case EXPR_ARRAY:
2262       /* Obtain the string length from the function used by
2263          trans-array.c(gfc_trans_array_constructor).  */
2264       len = NULL_TREE;
2265       get_array_ctor_strlen (arg->value.constructor, &len);
2266       break;
2267
2268     default:
2269         if (arg->expr_type == EXPR_VARIABLE
2270             && (arg->ref == NULL || (arg->ref->next == NULL
2271                                      && arg->ref->type == REF_ARRAY)))
2272           {
2273             /* This doesn't catch all cases.
2274                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2275                and the surrounding thread.  */
2276             sym = arg->symtree->n.sym;
2277             decl = gfc_get_symbol_decl (sym);
2278             if (decl == current_function_decl && sym->attr.function
2279                 && (sym->result == sym))
2280               decl = gfc_get_fake_result_decl (sym, 0);
2281
2282             len = sym->ts.cl->backend_decl;
2283             gcc_assert (len);
2284           }
2285         else
2286           {
2287             /* Anybody stupid enough to do this deserves inefficient code.  */
2288             gfc_init_se (&argse, se);
2289             gfc_conv_expr (&argse, arg);
2290             gfc_add_block_to_block (&se->pre, &argse.pre);
2291             gfc_add_block_to_block (&se->post, &argse.post);
2292             len = argse.string_length;
2293         }
2294       break;
2295     }
2296   se->expr = convert (type, len);
2297 }
2298
2299 /* The length of a character string not including trailing blanks.  */
2300 static void
2301 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2302 {
2303   tree args;
2304   tree type;
2305
2306   args = gfc_conv_intrinsic_function_args (se, expr);
2307   type = gfc_typenode_for_spec (&expr->ts);
2308   se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2309   se->expr = convert (type, se->expr);
2310 }
2311
2312
2313 /* Returns the starting position of a substring within a string.  */
2314
2315 static void
2316 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2317 {
2318   tree logical4_type_node = gfc_get_logical_type (4);
2319   tree args;
2320   tree back;
2321   tree type;
2322   tree tmp;
2323
2324   args = gfc_conv_intrinsic_function_args (se, expr);
2325   type = gfc_typenode_for_spec (&expr->ts);
2326   tmp = gfc_advance_chain (args, 3);
2327   if (TREE_CHAIN (tmp) == NULL_TREE)
2328     {
2329       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2330                         NULL_TREE);
2331       TREE_CHAIN (tmp) = back;
2332     }
2333   else
2334     {
2335       back = TREE_CHAIN (tmp);
2336       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2337     }
2338
2339   se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2340   se->expr = convert (type, se->expr);
2341 }
2342
2343 /* The ascii value for a single character.  */
2344 static void
2345 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2346 {
2347   tree arg;
2348   tree type;
2349
2350   arg = gfc_conv_intrinsic_function_args (se, expr);
2351   arg = TREE_VALUE (TREE_CHAIN (arg));
2352   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2353   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2354   type = gfc_typenode_for_spec (&expr->ts);
2355
2356   se->expr = build_fold_indirect_ref (arg);
2357   se->expr = convert (type, se->expr);
2358 }
2359
2360
2361 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2362
2363 static void
2364 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2365 {
2366   tree arg;
2367   tree tsource;
2368   tree fsource;
2369   tree mask;
2370   tree type;
2371   tree len;
2372
2373   arg = gfc_conv_intrinsic_function_args (se, expr);
2374   if (expr->ts.type != BT_CHARACTER)
2375     {
2376       tsource = TREE_VALUE (arg);
2377       arg = TREE_CHAIN (arg);
2378       fsource = TREE_VALUE (arg);
2379       mask = TREE_VALUE (TREE_CHAIN (arg));
2380     }
2381   else
2382     {
2383       /* We do the same as in the non-character case, but the argument
2384          list is different because of the string length arguments. We
2385          also have to set the string length for the result.  */
2386       len = TREE_VALUE (arg);
2387       arg = TREE_CHAIN (arg);
2388       tsource = TREE_VALUE (arg);
2389       arg = TREE_CHAIN (TREE_CHAIN (arg));
2390       fsource = TREE_VALUE (arg);
2391       mask = TREE_VALUE (TREE_CHAIN (arg));
2392
2393       se->string_length = len;
2394     }
2395   type = TREE_TYPE (tsource);
2396   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2397 }
2398
2399
2400 static void
2401 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2402 {
2403   gfc_actual_arglist *actual;
2404   tree args;
2405   tree type;
2406   tree fndecl;
2407   gfc_se argse;
2408   gfc_ss *ss;
2409
2410   gfc_init_se (&argse, NULL);
2411   actual = expr->value.function.actual;
2412
2413   ss = gfc_walk_expr (actual->expr);
2414   gcc_assert (ss != gfc_ss_terminator);
2415   argse.want_pointer = 1;
2416   argse.data_not_needed = 1;
2417   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2418   gfc_add_block_to_block (&se->pre, &argse.pre);
2419   gfc_add_block_to_block (&se->post, &argse.post);
2420   args = gfc_chainon_list (NULL_TREE, argse.expr);
2421
2422   actual = actual->next;
2423   if (actual->expr)
2424     {
2425       gfc_init_se (&argse, NULL);
2426       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2427       gfc_add_block_to_block (&se->pre, &argse.pre);
2428       args = gfc_chainon_list (args, argse.expr);
2429       fndecl = gfor_fndecl_size1;
2430     }
2431   else
2432     fndecl = gfor_fndecl_size0;
2433
2434   se->expr = build_function_call_expr (fndecl, args);
2435   type = gfc_typenode_for_spec (&expr->ts);
2436   se->expr = convert (type, se->expr);
2437 }
2438
2439
2440 /* Intrinsic string comparison functions.  */
2441
2442   static void
2443 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2444 {
2445   tree type;
2446   tree args;
2447   tree arg2;
2448
2449   args = gfc_conv_intrinsic_function_args (se, expr);
2450   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2451
2452   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2453                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2454                 TREE_VALUE (TREE_CHAIN (arg2)));
2455
2456   type = gfc_typenode_for_spec (&expr->ts);
2457   se->expr = fold_build2 (op, type, se->expr,
2458                      build_int_cst (TREE_TYPE (se->expr), 0));
2459 }
2460
2461 /* Generate a call to the adjustl/adjustr library function.  */
2462 static void
2463 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2464 {
2465   tree args;
2466   tree len;
2467   tree type;
2468   tree var;
2469   tree tmp;
2470
2471   args = gfc_conv_intrinsic_function_args (se, expr);
2472   len = TREE_VALUE (args);
2473
2474   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2475   var = gfc_conv_string_tmp (se, type, len);
2476   args = tree_cons (NULL_TREE, var, args);
2477
2478   tmp = build_function_call_expr (fndecl, args);
2479   gfc_add_expr_to_block (&se->pre, tmp);
2480   se->expr = var;
2481   se->string_length = len;
2482 }
2483
2484
2485 /* A helper function for gfc_conv_intrinsic_array_transfer to compute
2486    the size of tree expressions in bytes.  */
2487 static tree
2488 gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
2489 {
2490   tree tmp;
2491
2492   if (e->ts.type == BT_CHARACTER)
2493     tmp = se->string_length;
2494   else
2495     {
2496       if (e->rank)
2497         {
2498           tmp = gfc_get_element_type (TREE_TYPE (se->expr));
2499           tmp = size_in_bytes (tmp);
2500         }
2501       else
2502         tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
2503     }
2504
2505   return fold_convert (gfc_array_index_type, tmp);
2506 }
2507
2508
2509 /* Array transfer statement.
2510      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2511    where:
2512      typeof<DEST> = typeof<MOLD>
2513    and:
2514      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2515               sizeof (DEST(0) * SIZE).  */
2516
2517 static void
2518 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2519 {
2520   tree tmp;
2521   tree extent;
2522   tree source;
2523   tree source_bytes;
2524   tree dest_word_len;
2525   tree size_words;
2526   tree size_bytes;
2527   tree upper;
2528   tree lower;
2529   tree stride;
2530   tree stmt;
2531   tree args;
2532   gfc_actual_arglist *arg;
2533   gfc_se argse;
2534   gfc_ss *ss;
2535   gfc_ss_info *info;
2536   stmtblock_t block;
2537   int n;
2538
2539   gcc_assert (se->loop);
2540   info = &se->ss->data.info;
2541
2542   /* Convert SOURCE.  The output from this stage is:-
2543         source_bytes = length of the source in bytes
2544         source = pointer to the source data.  */
2545   arg = expr->value.function.actual;
2546   gfc_init_se (&argse, NULL);
2547   ss = gfc_walk_expr (arg->expr);
2548
2549   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
2550
2551   /* Obtain the pointer to source and the length of source in bytes.  */
2552   if (ss == gfc_ss_terminator)
2553     {
2554       gfc_conv_expr_reference (&argse, arg->expr);
2555       source = argse.expr;
2556
2557       /* Obtain the source word length.  */
2558       tmp = gfc_size_in_bytes (&argse, arg->expr);
2559     }
2560   else
2561     {
2562       gfc_init_se (&argse, NULL);
2563       argse.want_pointer = 0;
2564       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2565       source = gfc_conv_descriptor_data_get (argse.expr);
2566
2567       /* Repack the source if not a full variable array.  */
2568       if (!(arg->expr->expr_type == EXPR_VARIABLE
2569               && arg->expr->ref->u.ar.type == AR_FULL))
2570         {
2571           tmp = build_fold_addr_expr (argse.expr);
2572           tmp = gfc_chainon_list (NULL_TREE, tmp);
2573           source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
2574           source = gfc_evaluate_now (source, &argse.pre);
2575
2576           /* Free the temporary.  */
2577           gfc_start_block (&block);
2578           tmp = convert (pvoid_type_node, source);
2579           tmp = gfc_chainon_list (NULL_TREE, tmp);
2580           tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2581           gfc_add_expr_to_block (&block, tmp);
2582           stmt = gfc_finish_block (&block);
2583
2584           /* Clean up if it was repacked.  */
2585           gfc_init_block (&block);
2586           tmp = gfc_conv_array_data (argse.expr);
2587           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
2588           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
2589           gfc_add_expr_to_block (&block, tmp);
2590           gfc_add_block_to_block (&block, &se->post);
2591           gfc_init_block (&se->post);
2592           gfc_add_block_to_block (&se->post, &block);
2593         }
2594
2595       /* Obtain the source word length.  */
2596       tmp = gfc_size_in_bytes (&argse, arg->expr);
2597
2598       /* Obtain the size of the array in bytes.  */
2599       extent = gfc_create_var (gfc_array_index_type, NULL);
2600       for (n = 0; n < arg->expr->rank; n++)
2601         {
2602           tree idx;
2603           idx = gfc_rank_cst[n];
2604           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2605           stride = gfc_conv_descriptor_stride (argse.expr, idx);
2606           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2607           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2608           tmp = build2 (MINUS_EXPR, gfc_array_index_type,
2609                         upper, lower);
2610           gfc_add_modify_expr (&argse.pre, extent, tmp);
2611           tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2612                         extent, gfc_index_one_node);
2613           tmp = build2 (MULT_EXPR, gfc_array_index_type,
2614                         tmp, source_bytes);
2615         }
2616     }
2617
2618   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2619   gfc_add_block_to_block (&se->pre, &argse.pre);
2620   gfc_add_block_to_block (&se->post, &argse.post);
2621
2622   /* Now convert MOLD.  The sole output is:
2623         dest_word_len = destination word length in bytes.  */
2624   arg = arg->next;
2625
2626   gfc_init_se (&argse, NULL);
2627   ss = gfc_walk_expr (arg->expr);
2628
2629   if (ss == gfc_ss_terminator)
2630     {
2631       gfc_conv_expr_reference (&argse, arg->expr);
2632
2633       /* Obtain the source word length.  */
2634       tmp = gfc_size_in_bytes (&argse, arg->expr);
2635     }
2636   else
2637     {
2638       gfc_init_se (&argse, NULL);
2639       argse.want_pointer = 0;
2640       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2641
2642       /* Obtain the source word length.  */
2643       tmp = gfc_size_in_bytes (&argse, arg->expr);
2644     }
2645
2646   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
2647   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
2648
2649   /* Finally convert SIZE, if it is present.  */
2650   arg = arg->next;
2651   size_words = gfc_create_var (gfc_array_index_type, NULL);
2652
2653   if (arg->expr)
2654     {
2655       gfc_init_se (&argse, NULL);
2656       gfc_conv_expr_reference (&argse, arg->expr);
2657       tmp = convert (gfc_array_index_type,
2658                          build_fold_indirect_ref (argse.expr));
2659       gfc_add_block_to_block (&se->pre, &argse.pre);
2660       gfc_add_block_to_block (&se->post, &argse.post);
2661     }
2662   else
2663     tmp = NULL_TREE;
2664
2665   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
2666   if (tmp != NULL_TREE)
2667     {
2668       tmp = build2 (MULT_EXPR, gfc_array_index_type,
2669                     tmp, dest_word_len);
2670       tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
2671     }
2672   else
2673     tmp = source_bytes;
2674
2675   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
2676   gfc_add_modify_expr (&se->pre, size_words,
2677                        build2 (CEIL_DIV_EXPR, gfc_array_index_type,
2678                                size_bytes, dest_word_len));
2679
2680   /* Evaluate the bounds of the result.  If the loop range exists, we have
2681      to check if it is too large.  If so, we modify loop->to be consistent
2682      with min(size, size(source)).  Otherwise, size is made consistent with
2683      the loop range, so that the right number of bytes is transferred.*/
2684   n = se->loop->order[0];
2685   if (se->loop->to[n] != NULL_TREE)
2686     {
2687       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2688                          se->loop->to[n], se->loop->from[n]);
2689       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2690                     tmp, gfc_index_one_node);
2691       tmp = build2 (MIN_EXPR, gfc_array_index_type,
2692                     tmp, size_words);
2693       gfc_add_modify_expr (&se->pre, size_words, tmp);
2694       gfc_add_modify_expr (&se->pre, size_bytes,
2695                            build2 (MULT_EXPR, gfc_array_index_type,
2696                            size_words, dest_word_len));
2697       upper = build2 (PLUS_EXPR, gfc_array_index_type,
2698                       size_words, se->loop->from[n]);
2699       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2700                       upper, gfc_index_one_node);
2701     }
2702   else
2703     {
2704       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2705                       size_words, gfc_index_one_node);
2706       se->loop->from[n] = gfc_index_zero_node;
2707     }
2708
2709   se->loop->to[n] = upper;
2710
2711   /* Build a destination descriptor, using the pointer, source, as the
2712      data field.  This is already allocated so set callee_alloc.  */
2713   tmp = gfc_typenode_for_spec (&expr->ts);
2714   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
2715                                info, tmp, false, true, false, false);
2716
2717   /* Use memcpy to do the transfer.  */
2718   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2719   args = gfc_chainon_list (NULL_TREE, tmp);
2720   tmp = fold_convert (pvoid_type_node, source);
2721   args = gfc_chainon_list (args, source);
2722   args = gfc_chainon_list (args, size_bytes);
2723   tmp = built_in_decls[BUILT_IN_MEMCPY];
2724   tmp = build_function_call_expr (tmp, args);
2725   gfc_add_expr_to_block (&se->pre, tmp);
2726
2727   se->expr = info->descriptor;
2728   if (expr->ts.type == BT_CHARACTER)
2729     se->string_length = dest_word_len;
2730 }
2731
2732
2733 /* Scalar transfer statement.
2734    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
2735
2736 static void
2737 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2738 {
2739   gfc_actual_arglist *arg;
2740   gfc_se argse;
2741   tree type;
2742   tree ptr;
2743   gfc_ss *ss;
2744
2745   /* Get a pointer to the source.  */
2746   arg = expr->value.function.actual;
2747   ss = gfc_walk_expr (arg->expr);
2748   gfc_init_se (&argse, NULL);
2749   if (ss == gfc_ss_terminator)
2750     gfc_conv_expr_reference (&argse, arg->expr);
2751   else
2752     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2753   gfc_add_block_to_block (&se->pre, &argse.pre);
2754   gfc_add_block_to_block (&se->post, &argse.post);
2755   ptr = argse.expr;
2756
2757   arg = arg->next;
2758   type = gfc_typenode_for_spec (&expr->ts);
2759   ptr = convert (build_pointer_type (type), ptr);
2760   if (expr->ts.type == BT_CHARACTER)
2761     {
2762       gfc_init_se (&argse, NULL);
2763       gfc_conv_expr (&argse, arg->expr);
2764       gfc_add_block_to_block (&se->pre, &argse.pre);
2765       gfc_add_block_to_block (&se->post, &argse.post);
2766       se->expr = ptr;
2767       se->string_length = argse.string_length;
2768     }
2769   else
2770     {
2771       se->expr = build_fold_indirect_ref (ptr);
2772     }
2773 }
2774
2775
2776 /* Generate code for the ALLOCATED intrinsic.
2777    Generate inline code that directly check the address of the argument.  */
2778
2779 static void
2780 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2781 {
2782   gfc_actual_arglist *arg1;
2783   gfc_se arg1se;
2784   gfc_ss *ss1;
2785   tree tmp;
2786
2787   gfc_init_se (&arg1se, NULL);
2788   arg1 = expr->value.function.actual;
2789   ss1 = gfc_walk_expr (arg1->expr);
2790   arg1se.descriptor_only = 1;
2791   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2792
2793   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2794   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2795                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2796   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2797 }
2798
2799
2800 /* Generate code for the ASSOCIATED intrinsic.
2801    If both POINTER and TARGET are arrays, generate a call to library function
2802    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2803    In other cases, generate inline code that directly compare the address of
2804    POINTER with the address of TARGET.  */
2805
2806 static void
2807 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2808 {
2809   gfc_actual_arglist *arg1;
2810   gfc_actual_arglist *arg2;
2811   gfc_se arg1se;
2812   gfc_se arg2se;
2813   tree tmp2;
2814   tree tmp;
2815   tree args, fndecl;
2816   tree nonzero_charlen;
2817   tree nonzero_arraylen;
2818   gfc_ss *ss1, *ss2;
2819
2820   gfc_init_se (&arg1se, NULL);
2821   gfc_init_se (&arg2se, NULL);
2822   arg1 = expr->value.function.actual;
2823   arg2 = arg1->next;
2824   ss1 = gfc_walk_expr (arg1->expr);
2825
2826   if (!arg2->expr)
2827     {
2828       /* No optional target.  */
2829       if (ss1 == gfc_ss_terminator)
2830         {
2831           /* A pointer to a scalar.  */
2832           arg1se.want_pointer = 1;
2833           gfc_conv_expr (&arg1se, arg1->expr);
2834           tmp2 = arg1se.expr;
2835         }
2836       else
2837         {
2838           /* A pointer to an array.  */
2839           arg1se.descriptor_only = 1;
2840           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2841           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
2842         }
2843       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2844                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2845       se->expr = tmp;
2846     }
2847   else
2848     {
2849       /* An optional target.  */
2850       ss2 = gfc_walk_expr (arg2->expr);
2851
2852       nonzero_charlen = NULL_TREE;
2853       if (arg1->expr->ts.type == BT_CHARACTER)
2854         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
2855                                   arg1->expr->ts.cl->backend_decl,
2856                                   integer_zero_node);
2857
2858       if (ss1 == gfc_ss_terminator)
2859         {
2860           /* A pointer to a scalar.  */
2861           gcc_assert (ss2 == gfc_ss_terminator);
2862           arg1se.want_pointer = 1;
2863           gfc_conv_expr (&arg1se, arg1->expr);
2864           arg2se.want_pointer = 1;
2865           gfc_conv_expr (&arg2se, arg2->expr);
2866           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2867           se->expr = tmp;
2868         }
2869       else
2870         {
2871
2872           /* An array pointer of zero length is not associated if target is
2873              present.  */
2874           arg1se.descriptor_only = 1;
2875           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2876           tmp = gfc_conv_descriptor_stride (arg1se.expr,
2877                                             gfc_rank_cst[arg1->expr->rank - 1]);
2878           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
2879                                  tmp, integer_zero_node);
2880
2881           /* A pointer to an array, call library function _gfor_associated.  */
2882           gcc_assert (ss2 != gfc_ss_terminator);
2883           args = NULL_TREE;
2884           arg1se.want_pointer = 1;
2885           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2886           args = gfc_chainon_list (args, arg1se.expr);
2887
2888           arg2se.want_pointer = 1;
2889           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2890           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2891           gfc_add_block_to_block (&se->post, &arg2se.post);
2892           args = gfc_chainon_list (args, arg2se.expr);
2893           fndecl = gfor_fndecl_associated;
2894           se->expr = build_function_call_expr (fndecl, args);
2895           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2896                              se->expr, nonzero_arraylen);
2897
2898         }
2899
2900       /* If target is present zero character length pointers cannot
2901          be associated.  */
2902       if (nonzero_charlen != NULL_TREE)
2903         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2904                            se->expr, nonzero_charlen);
2905     }
2906
2907   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2908 }
2909
2910
2911 /* Scan a string for any one of the characters in a set of characters.  */
2912
2913 static void
2914 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2915 {
2916   tree logical4_type_node = gfc_get_logical_type (4);
2917   tree args;
2918   tree back;
2919   tree type;
2920   tree tmp;
2921
2922   args = gfc_conv_intrinsic_function_args (se, expr);
2923   type = gfc_typenode_for_spec (&expr->ts);
2924   tmp = gfc_advance_chain (args, 3);
2925   if (TREE_CHAIN (tmp) == NULL_TREE)
2926     {
2927       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2928                         NULL_TREE);
2929       TREE_CHAIN (tmp) = back;
2930     }
2931   else
2932     {
2933       back = TREE_CHAIN (tmp);
2934       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2935     }
2936
2937   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2938   se->expr = convert (type, se->expr);
2939 }
2940
2941
2942 /* Verify that a set of characters contains all the characters in a string
2943    by identifying the position of the first character in a string of
2944    characters that does not appear in a given set of characters.  */
2945
2946 static void
2947 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2948 {
2949   tree logical4_type_node = gfc_get_logical_type (4);
2950   tree args;
2951   tree back;
2952   tree type;
2953   tree tmp;
2954
2955   args = gfc_conv_intrinsic_function_args (se, expr);
2956   type = gfc_typenode_for_spec (&expr->ts);
2957   tmp = gfc_advance_chain (args, 3);
2958   if (TREE_CHAIN (tmp) == NULL_TREE)
2959     {
2960       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2961                         NULL_TREE);
2962       TREE_CHAIN (tmp) = back;
2963     }
2964   else
2965     {
2966       back = TREE_CHAIN (tmp);
2967       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2968     }
2969
2970   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2971   se->expr = convert (type, se->expr);
2972 }
2973
2974 /* Prepare components and related information of a real number which is
2975    the first argument of a elemental functions to manipulate reals.  */
2976
2977 static void
2978 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2979                   real_compnt_info * rcs, int all)
2980 {
2981    tree arg;
2982    tree masktype;
2983    tree tmp;
2984    tree wbits;
2985    tree one;
2986    tree exponent, fraction;
2987    int n;
2988    gfc_expr *a1;
2989
2990    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2991      gfc_todo_error ("Non-IEEE floating format");
2992
2993    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2994
2995    arg = gfc_conv_intrinsic_function_args (se, expr);
2996    arg = TREE_VALUE (arg);
2997    rcs->type = TREE_TYPE (arg);
2998
2999    /* Force arg'type to integer by unaffected convert  */
3000    a1 = expr->value.function.actual->expr;
3001    masktype = gfc_get_int_type (a1->ts.kind);
3002    rcs->mtype = masktype;
3003    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
3004    arg = gfc_create_var (masktype, "arg");
3005    gfc_add_modify_expr(&se->pre, arg, tmp);
3006    rcs->arg = arg;
3007
3008    /* Calculate the numbers of bits of exponent, fraction and word  */
3009    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
3010    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
3011    rcs->fdigits = convert (masktype, tmp);
3012    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
3013    wbits = convert (masktype, wbits);
3014    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
3015
3016    /* Form masks for exponent/fraction/sign  */
3017    one = gfc_build_const (masktype, integer_one_node);
3018    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
3019    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
3020    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
3021    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
3022    /* Form bias.  */
3023    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
3024    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
3025    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
3026
3027    if (all)
3028      {
3029        /* exponent, and fraction  */
3030        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
3031        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
3032        exponent = gfc_create_var (masktype, "exponent");
3033        gfc_add_modify_expr(&se->pre, exponent, tmp);
3034        rcs->expn = exponent;
3035
3036        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
3037        fraction = gfc_create_var (masktype, "fraction");
3038        gfc_add_modify_expr(&se->pre, fraction, tmp);
3039        rcs->frac = fraction;
3040      }
3041 }
3042
3043 /* Build a call to __builtin_clz.  */
3044
3045 static tree
3046 call_builtin_clz (tree result_type, tree op0)
3047 {
3048   tree fn, parms, call;
3049   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
3050
3051   if (op0_mode == TYPE_MODE (integer_type_node))
3052     fn = built_in_decls[BUILT_IN_CLZ];
3053   else if (op0_mode == TYPE_MODE (long_integer_type_node))
3054     fn = built_in_decls[BUILT_IN_CLZL];
3055   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
3056     fn = built_in_decls[BUILT_IN_CLZLL];
3057   else
3058     gcc_unreachable ();
3059
3060   parms = tree_cons (NULL, op0, NULL);
3061   call = build_function_call_expr (fn, parms);
3062
3063   return convert (result_type, call);
3064 }
3065
3066
3067 /* Generate code for SPACING (X) intrinsic function.
3068    SPACING (X) = POW (2, e-p)
3069
3070    We generate:
3071
3072     t = expn - fdigits // e - p.
3073     res = t << fdigits // Form the exponent. Fraction is zero.
3074     if (t < 0) // The result is out of range. Denormalized case.
3075       res = tiny(X)
3076  */
3077
3078 static void
3079 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3080 {
3081    tree arg;
3082    tree masktype;
3083    tree tmp, t1, cond;
3084    tree tiny, zero;
3085    tree fdigits;
3086    real_compnt_info rcs;
3087
3088    prepare_arg_info (se, expr, &rcs, 0);
3089    arg = rcs.arg;
3090    masktype = rcs.mtype;
3091    fdigits = rcs.fdigits;
3092    tiny = rcs.f1;
3093    zero = gfc_build_const (masktype, integer_zero_node);
3094    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
3095    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
3096    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
3097    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
3098    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3099    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
3100    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3101
3102    se->expr = tmp;
3103 }
3104
3105 /* Generate code for RRSPACING (X) intrinsic function.
3106    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
3107
3108    So the result's exponent is p. And if X is normalized, X's fraction part
3109    is the result's fraction. If X is denormalized, to get the X's fraction we
3110    shift X's fraction part to left until the first '1' is removed.
3111
3112    We generate:
3113
3114     if (expn == 0 && frac == 0)
3115        res = 0;
3116     else
3117     {
3118        // edigits is the number of exponent bits. Add the sign bit.
3119        sedigits = edigits + 1;
3120
3121        if (expn == 0) // Denormalized case.
3122        {
3123          t1 = leadzero (frac);
3124          frac = frac << (t1 + 1); //Remove the first '1'.
3125          frac = frac >> (sedigits); //Form the fraction.
3126        }
3127
3128        //fdigits is the number of fraction bits. Form the exponent.
3129        t = bias + fdigits;
3130
3131        res = (t << fdigits) | frac;
3132     }
3133 */
3134
3135 static void
3136 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3137 {
3138    tree masktype;
3139    tree tmp, t1, t2, cond, cond2;
3140    tree one, zero;
3141    tree fdigits, fraction;
3142    real_compnt_info rcs;
3143
3144    prepare_arg_info (se, expr, &rcs, 1);
3145    masktype = rcs.mtype;
3146    fdigits = rcs.fdigits;
3147    fraction = rcs.frac;
3148    one = gfc_build_const (masktype, integer_one_node);
3149    zero = gfc_build_const (masktype, integer_zero_node);
3150    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
3151
3152    t1 = call_builtin_clz (masktype, fraction);
3153    tmp = build2 (PLUS_EXPR, masktype, t1, one);
3154    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
3155    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
3156    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
3157    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
3158
3159    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
3160    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3161    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
3162
3163    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
3164    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
3165    tmp = build3 (COND_EXPR, masktype, cond,
3166                  build_int_cst (masktype, 0), tmp);
3167
3168    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3169    se->expr = tmp;
3170 }
3171
3172 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3173
3174 static void
3175 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3176 {
3177   tree args;
3178
3179   args = gfc_conv_intrinsic_function_args (se, expr);
3180   args = TREE_VALUE (args);
3181   args = build_fold_addr_expr (args);
3182   args = tree_cons (NULL_TREE, args, NULL_TREE);
3183   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3184 }
3185
3186 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3187
3188 static void
3189 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3190 {
3191   gfc_actual_arglist *actual;
3192   tree args;
3193   gfc_se argse;
3194
3195   args = NULL_TREE;
3196   for (actual = expr->value.function.actual; actual; actual = actual->next)
3197     {
3198       gfc_init_se (&argse, se);
3199
3200       /* Pass a NULL pointer for an absent arg.  */
3201       if (actual->expr == NULL)
3202         argse.expr = null_pointer_node;
3203       else
3204         gfc_conv_expr_reference (&argse, actual->expr);
3205
3206       gfc_add_block_to_block (&se->pre, &argse.pre);
3207       gfc_add_block_to_block (&se->post, &argse.post);
3208       args = gfc_chainon_list (args, argse.expr);
3209     }
3210   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3211 }
3212
3213
3214 /* Generate code for TRIM (A) intrinsic function.  */
3215
3216 static void
3217 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3218 {
3219   tree gfc_int4_type_node = gfc_get_int_type (4);
3220   tree var;
3221   tree len;
3222   tree addr;
3223   tree tmp;
3224   tree arglist;
3225   tree type;
3226   tree cond;
3227
3228   arglist = NULL_TREE;
3229
3230   type = build_pointer_type (gfc_character1_type_node);
3231   var = gfc_create_var (type, "pstr");
3232   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3233   len = gfc_create_var (gfc_int4_type_node, "len");
3234
3235   tmp = gfc_conv_intrinsic_function_args (se, expr);
3236   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3237   arglist = gfc_chainon_list (arglist, addr);
3238   arglist = chainon (arglist, tmp);
3239
3240   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3241   gfc_add_expr_to_block (&se->pre, tmp);
3242
3243   /* Free the temporary afterwards, if necessary.  */
3244   cond = build2 (GT_EXPR, boolean_type_node, len,
3245                  build_int_cst (TREE_TYPE (len), 0));
3246   arglist = gfc_chainon_list (NULL_TREE, var);
3247   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3248   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3249   gfc_add_expr_to_block (&se->post, tmp);
3250
3251   se->expr = var;
3252   se->string_length = len;
3253 }
3254
3255
3256 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3257
3258 static void
3259 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3260 {
3261   tree gfc_int4_type_node = gfc_get_int_type (4);
3262   tree tmp;
3263   tree len;
3264   tree args;
3265   tree arglist;
3266   tree ncopies;
3267   tree var;
3268   tree type;
3269
3270   args = gfc_conv_intrinsic_function_args (se, expr);
3271   len = TREE_VALUE (args);
3272   tmp = gfc_advance_chain (args, 2);
3273   ncopies = TREE_VALUE (tmp);
3274   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3275   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3276   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3277
3278   arglist = NULL_TREE;
3279   arglist = gfc_chainon_list (arglist, var);
3280   arglist = chainon (arglist, args);
3281   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3282   gfc_add_expr_to_block (&se->pre, tmp);
3283
3284   se->expr = var;
3285   se->string_length = len;
3286 }
3287
3288
3289 /* Generate code for the IARGC intrinsic.  */
3290
3291 static void
3292 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3293 {
3294   tree tmp;
3295   tree fndecl;
3296   tree type;
3297
3298   /* Call the library function.  This always returns an INTEGER(4).  */
3299   fndecl = gfor_fndecl_iargc;
3300   tmp = build_function_call_expr (fndecl, NULL_TREE);
3301
3302   /* Convert it to the required type.  */
3303   type = gfc_typenode_for_spec (&expr->ts);
3304   tmp = fold_convert (type, tmp);
3305
3306   se->expr = tmp;
3307 }
3308
3309
3310 /* The loc intrinsic returns the address of its argument as
3311    gfc_index_integer_kind integer.  */
3312
3313 static void
3314 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
3315 {
3316   tree temp_var;
3317   gfc_expr *arg_expr;
3318   gfc_ss *ss;
3319
3320   gcc_assert (!se->ss);
3321
3322   arg_expr = expr->value.function.actual->expr;
3323   ss = gfc_walk_expr (arg_expr);
3324   if (ss == gfc_ss_terminator)
3325     gfc_conv_expr_reference (se, arg_expr);
3326   else
3327     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3328   se->expr= convert (gfc_unsigned_type (long_integer_type_node),
3329                      se->expr);
3330
3331   /* Create a temporary variable for loc return value.  Without this,
3332      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3333   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
3334                              NULL);
3335   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3336   se->expr = temp_var;
3337 }
3338
3339 /* Generate code for an intrinsic function.  Some map directly to library
3340    calls, others get special handling.  In some cases the name of the function
3341    used depends on the type specifiers.  */
3342
3343 void
3344 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3345 {
3346   gfc_intrinsic_sym *isym;
3347   const char *name;
3348   int lib;
3349
3350   isym = expr->value.function.isym;
3351
3352   name = &expr->value.function.name[2];
3353
3354   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3355     {
3356       lib = gfc_is_intrinsic_libcall (expr);
3357       if (lib != 0)
3358         {
3359           if (lib == 1)
3360             se->ignore_optional = 1;
3361           gfc_conv_intrinsic_funcall (se, expr);
3362           return;
3363         }
3364     }
3365
3366   switch (expr->value.function.isym->generic_id)
3367     {
3368     case GFC_ISYM_NONE:
3369       gcc_unreachable ();
3370
3371     case GFC_ISYM_REPEAT:
3372       gfc_conv_intrinsic_repeat (se, expr);
3373       break;
3374
3375     case GFC_ISYM_TRIM:
3376       gfc_conv_intrinsic_trim (se, expr);
3377       break;
3378
3379     case GFC_ISYM_SI_KIND:
3380       gfc_conv_intrinsic_si_kind (se, expr);
3381       break;
3382
3383     case GFC_ISYM_SR_KIND:
3384       gfc_conv_intrinsic_sr_kind (se, expr);
3385       break;
3386
3387     case GFC_ISYM_EXPONENT:
3388       gfc_conv_intrinsic_exponent (se, expr);
3389       break;
3390
3391     case GFC_ISYM_SPACING:
3392       gfc_conv_intrinsic_spacing (se, expr);
3393       break;
3394
3395     case GFC_ISYM_RRSPACING:
3396       gfc_conv_intrinsic_rrspacing (se, expr);
3397       break;
3398
3399     case GFC_ISYM_SCAN:
3400       gfc_conv_intrinsic_scan (se, expr);
3401       break;
3402
3403     case GFC_ISYM_VERIFY:
3404       gfc_conv_intrinsic_verify (se, expr);
3405       break;
3406
3407     case GFC_ISYM_ALLOCATED:
3408       gfc_conv_allocated (se, expr);
3409       break;
3410
3411     case GFC_ISYM_ASSOCIATED:
3412       gfc_conv_associated(se, expr);
3413       break;
3414
3415     case GFC_ISYM_ABS:
3416       gfc_conv_intrinsic_abs (se, expr);
3417       break;
3418
3419     case GFC_ISYM_ADJUSTL:
3420       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3421       break;
3422
3423     case GFC_ISYM_ADJUSTR:
3424       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3425       break;
3426
3427     case GFC_ISYM_AIMAG:
3428       gfc_conv_intrinsic_imagpart (se, expr);
3429       break;
3430
3431     case GFC_ISYM_AINT:
3432       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3433       break;
3434
3435     case GFC_ISYM_ALL:
3436       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3437       break;
3438
3439     case GFC_ISYM_ANINT:
3440       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3441       break;
3442
3443     case GFC_ISYM_AND:
3444       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3445       break;
3446
3447     case GFC_ISYM_ANY:
3448       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3449       break;
3450
3451     case GFC_ISYM_BTEST:
3452       gfc_conv_intrinsic_btest (se, expr);
3453       break;
3454
3455     case GFC_ISYM_ACHAR:
3456     case GFC_ISYM_CHAR:
3457       gfc_conv_intrinsic_char (se, expr);
3458       break;
3459
3460     case GFC_ISYM_CONVERSION:
3461     case GFC_ISYM_REAL:
3462     case GFC_ISYM_LOGICAL:
3463     case GFC_ISYM_DBLE:
3464       gfc_conv_intrinsic_conversion (se, expr);
3465       break;
3466
3467       /* Integer conversions are handled separately to make sure we get the
3468          correct rounding mode.  */
3469     case GFC_ISYM_INT:
3470       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3471       break;
3472
3473     case GFC_ISYM_NINT:
3474       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3475       break;
3476
3477     case GFC_ISYM_CEILING:
3478       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3479       break;
3480
3481     case GFC_ISYM_FLOOR:
3482       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3483       break;
3484
3485     case GFC_ISYM_MOD:
3486       gfc_conv_intrinsic_mod (se, expr, 0);
3487       break;
3488
3489     case GFC_ISYM_MODULO:
3490       gfc_conv_intrinsic_mod (se, expr, 1);
3491       break;
3492
3493     case GFC_ISYM_CMPLX:
3494       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3495       break;
3496
3497     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3498       gfc_conv_intrinsic_iargc (se, expr);
3499       break;
3500
3501     case GFC_ISYM_COMPLEX:
3502       gfc_conv_intrinsic_cmplx (se, expr, 1);
3503       break;
3504
3505     case GFC_ISYM_CONJG:
3506       gfc_conv_intrinsic_conjg (se, expr);
3507       break;
3508
3509     case GFC_ISYM_COUNT:
3510       gfc_conv_intrinsic_count (se, expr);
3511       break;
3512
3513     case GFC_ISYM_CTIME:
3514       gfc_conv_intrinsic_ctime (se, expr);
3515       break;
3516
3517     case GFC_ISYM_DIM:
3518       gfc_conv_intrinsic_dim (se, expr);
3519       break;
3520
3521     case GFC_ISYM_DOT_PRODUCT:
3522       gfc_conv_intrinsic_dot_product (se, expr);
3523       break;
3524
3525     case GFC_ISYM_DPROD:
3526       gfc_conv_intrinsic_dprod (se, expr);
3527       break;
3528
3529     case GFC_ISYM_FDATE:
3530       gfc_conv_intrinsic_fdate (se, expr);
3531       break;
3532
3533     case GFC_ISYM_IAND:
3534       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3535       break;
3536
3537     case GFC_ISYM_IBCLR:
3538       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3539       break;
3540
3541     case GFC_ISYM_IBITS:
3542       gfc_conv_intrinsic_ibits (se, expr);
3543       break;
3544
3545     case GFC_ISYM_IBSET:
3546       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3547       break;
3548
3549     case GFC_ISYM_IACHAR:
3550     case GFC_ISYM_ICHAR:
3551       /* We assume ASCII character sequence.  */
3552       gfc_conv_intrinsic_ichar (se, expr);
3553       break;
3554
3555     case GFC_ISYM_IARGC:
3556       gfc_conv_intrinsic_iargc (se, expr);
3557       break;
3558
3559     case GFC_ISYM_IEOR:
3560       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3561       break;
3562
3563     case GFC_ISYM_INDEX:
3564       gfc_conv_intrinsic_index (se, expr);
3565       break;
3566
3567     case GFC_ISYM_IOR:
3568       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3569       break;
3570
3571     case GFC_ISYM_ISHFT:
3572       gfc_conv_intrinsic_ishft (se, expr);
3573       break;
3574
3575     case GFC_ISYM_ISHFTC:
3576       gfc_conv_intrinsic_ishftc (se, expr);
3577       break;
3578
3579     case GFC_ISYM_LBOUND:
3580       gfc_conv_intrinsic_bound (se, expr, 0);
3581       break;
3582
3583     case GFC_ISYM_TRANSPOSE:
3584       if (se->ss && se->ss->useflags)
3585         {
3586           gfc_conv_tmp_array_ref (se);
3587           gfc_advance_se_ss_chain (se);
3588         }
3589       else
3590         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3591       break;
3592
3593     case GFC_ISYM_LEN:
3594       gfc_conv_intrinsic_len (se, expr);
3595       break;
3596
3597     case GFC_ISYM_LEN_TRIM:
3598       gfc_conv_intrinsic_len_trim (se, expr);
3599       break;
3600
3601     case GFC_ISYM_LGE:
3602       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3603       break;
3604
3605     case GFC_ISYM_LGT:
3606       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3607       break;
3608
3609     case GFC_ISYM_LLE:
3610       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3611       break;
3612
3613     case GFC_ISYM_LLT:
3614       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3615       break;
3616
3617     case GFC_ISYM_MAX:
3618       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3619       break;
3620
3621     case GFC_ISYM_MAXLOC:
3622       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3623       break;
3624
3625     case GFC_ISYM_MAXVAL:
3626       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3627       break;
3628
3629     case GFC_ISYM_MERGE:
3630       gfc_conv_intrinsic_merge (se, expr);
3631       break;
3632
3633     case GFC_ISYM_MIN:
3634       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3635       break;
3636
3637     case GFC_ISYM_MINLOC:
3638       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3639       break;
3640
3641     case GFC_ISYM_MINVAL:
3642       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3643       break;
3644
3645     case GFC_ISYM_NOT:
3646       gfc_conv_intrinsic_not (se, expr);
3647       break;
3648
3649     case GFC_ISYM_OR:
3650       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3651       break;
3652
3653     case GFC_ISYM_PRESENT:
3654       gfc_conv_intrinsic_present (se, expr);
3655       break;
3656
3657     case GFC_ISYM_PRODUCT:
3658       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3659       break;
3660
3661     case GFC_ISYM_SIGN:
3662       gfc_conv_intrinsic_sign (se, expr);
3663       break;
3664
3665     case GFC_ISYM_SIZE:
3666       gfc_conv_intrinsic_size (se, expr);
3667       break;
3668
3669     case GFC_ISYM_SUM:
3670       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3671       break;
3672
3673     case GFC_ISYM_TRANSFER:
3674       if (se->ss)
3675         {
3676           if (se->ss->useflags)
3677             {
3678               /* Access the previously obtained result.  */
3679               gfc_conv_tmp_array_ref (se);
3680               gfc_advance_se_ss_chain (se);
3681               break;
3682             }
3683           else
3684             gfc_conv_intrinsic_array_transfer (se, expr);
3685         }
3686       else
3687         gfc_conv_intrinsic_transfer (se, expr);
3688       break;
3689
3690     case GFC_ISYM_TTYNAM:
3691       gfc_conv_intrinsic_ttynam (se, expr);
3692       break;
3693
3694     case GFC_ISYM_UBOUND:
3695       gfc_conv_intrinsic_bound (se, expr, 1);
3696       break;
3697
3698     case GFC_ISYM_XOR:
3699       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3700       break;
3701
3702     case GFC_ISYM_LOC:
3703       gfc_conv_intrinsic_loc (se, expr);
3704       break;
3705
3706     case GFC_ISYM_CHDIR:
3707     case GFC_ISYM_ETIME:
3708     case GFC_ISYM_FGET:
3709     case GFC_ISYM_FGETC:
3710     case GFC_ISYM_FNUM:
3711     case GFC_ISYM_FPUT:
3712     case GFC_ISYM_FPUTC:
3713     case GFC_ISYM_FSTAT:
3714     case GFC_ISYM_FTELL:
3715     case GFC_ISYM_GETCWD:
3716     case GFC_ISYM_GETGID:
3717     case GFC_ISYM_GETPID:
3718     case GFC_ISYM_GETUID:
3719     case GFC_ISYM_HOSTNM:
3720     case GFC_ISYM_KILL:
3721     case GFC_ISYM_IERRNO:
3722     case GFC_ISYM_IRAND:
3723     case GFC_ISYM_ISATTY:
3724     case GFC_ISYM_LINK:
3725     case GFC_ISYM_MALLOC:
3726     case GFC_ISYM_MATMUL:
3727     case GFC_ISYM_RAND:
3728     case GFC_ISYM_RENAME:
3729     case GFC_ISYM_SECOND:
3730     case GFC_ISYM_SECNDS:
3731     case GFC_ISYM_SIGNAL:
3732     case GFC_ISYM_STAT:
3733     case GFC_ISYM_SYMLNK:
3734     case GFC_ISYM_SYSTEM:
3735     case GFC_ISYM_TIME:
3736     case GFC_ISYM_TIME8:
3737     case GFC_ISYM_UMASK:
3738     case GFC_ISYM_UNLINK:
3739       gfc_conv_intrinsic_funcall (se, expr);
3740       break;
3741
3742     default:
3743       gfc_conv_intrinsic_lib_function (se, expr);
3744       break;
3745     }
3746 }
3747
3748
3749 /* This generates code to execute before entering the scalarization loop.
3750    Currently does nothing.  */
3751
3752 void
3753 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3754 {
3755   switch (ss->expr->value.function.isym->generic_id)
3756     {
3757     case GFC_ISYM_UBOUND:
3758     case GFC_ISYM_LBOUND:
3759       break;
3760
3761     default:
3762       gcc_unreachable ();
3763     }
3764 }
3765
3766
3767 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3768    inside the scalarization loop.  */
3769
3770 static gfc_ss *
3771 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3772 {
3773   gfc_ss *newss;
3774
3775   /* The two argument version returns a scalar.  */
3776   if (expr->value.function.actual->next->expr)
3777     return ss;
3778
3779   newss = gfc_get_ss ();
3780   newss->type = GFC_SS_INTRINSIC;
3781   newss->expr = expr;
3782   newss->next = ss;
3783   newss->data.info.dimen = 1;
3784
3785   return newss;
3786 }
3787
3788
3789 /* Walk an intrinsic array libcall.  */
3790
3791 static gfc_ss *
3792 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3793 {
3794   gfc_ss *newss;
3795
3796   gcc_assert (expr->rank > 0);
3797
3798   newss = gfc_get_ss ();
3799   newss->type = GFC_SS_FUNCTION;
3800   newss->expr = expr;
3801   newss->next = ss;
3802   newss->data.info.dimen = expr->rank;
3803
3804   return newss;
3805 }
3806
3807
3808 /* Returns nonzero if the specified intrinsic function call maps directly to a
3809    an external library call.  Should only be used for functions that return
3810    arrays.  */
3811
3812 int
3813 gfc_is_intrinsic_libcall (gfc_expr * expr)
3814 {
3815   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3816   gcc_assert (expr->rank > 0);
3817
3818   switch (expr->value.function.isym->generic_id)
3819     {
3820     case GFC_ISYM_ALL:
3821     case GFC_ISYM_ANY:
3822     case GFC_ISYM_COUNT:
3823     case GFC_ISYM_MATMUL:
3824     case GFC_ISYM_MAXLOC:
3825     case GFC_ISYM_MAXVAL:
3826     case GFC_ISYM_MINLOC:
3827     case GFC_ISYM_MINVAL:
3828     case GFC_ISYM_PRODUCT:
3829     case GFC_ISYM_SUM:
3830     case GFC_ISYM_SHAPE:
3831     case GFC_ISYM_SPREAD:
3832     case GFC_ISYM_TRANSPOSE:
3833       /* Ignore absent optional parameters.  */
3834       return 1;
3835
3836     case GFC_ISYM_RESHAPE:
3837     case GFC_ISYM_CSHIFT:
3838     case GFC_ISYM_EOSHIFT:
3839     case GFC_ISYM_PACK:
3840     case GFC_ISYM_UNPACK:
3841       /* Pass absent optional parameters.  */
3842       return 2;
3843
3844     default:
3845       return 0;
3846     }
3847 }
3848
3849 /* Walk an intrinsic function.  */
3850 gfc_ss *
3851 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3852                              gfc_intrinsic_sym * isym)
3853 {
3854   gcc_assert (isym);
3855
3856   if (isym->elemental)
3857     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3858
3859   if (expr->rank == 0)
3860     return ss;
3861
3862   if (gfc_is_intrinsic_libcall (expr))
3863     return gfc_walk_intrinsic_libfunc (ss, expr);
3864
3865   /* Special cases.  */
3866   switch (isym->generic_id)
3867     {
3868     case GFC_ISYM_LBOUND:
3869     case GFC_ISYM_UBOUND:
3870       return gfc_walk_intrinsic_bound (ss, expr);
3871
3872     case GFC_ISYM_TRANSFER:
3873       return gfc_walk_intrinsic_libfunc (ss, expr);
3874
3875     default:
3876       /* This probably meant someone forgot to add an intrinsic to the above
3877          list(s) when they implemented it, or something's gone horribly wrong.
3878        */
3879       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3880                       expr->value.function.name);
3881     }
3882 }
3883
3884 #include "gt-fortran-trans-intrinsic.h"