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       gfc_add_block_to_block (&se->pre, &arg1se.pre);
2844       gfc_add_block_to_block (&se->post, &arg1se.post);
2845       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2846                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2847       se->expr = tmp;
2848     }
2849   else
2850     {
2851       /* An optional target.  */
2852       ss2 = gfc_walk_expr (arg2->expr);
2853
2854       nonzero_charlen = NULL_TREE;
2855       if (arg1->expr->ts.type == BT_CHARACTER)
2856         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
2857                                   arg1->expr->ts.cl->backend_decl,
2858                                   integer_zero_node);
2859
2860       if (ss1 == gfc_ss_terminator)
2861         {
2862           /* A pointer to a scalar.  */
2863           gcc_assert (ss2 == gfc_ss_terminator);
2864           arg1se.want_pointer = 1;
2865           gfc_conv_expr (&arg1se, arg1->expr);
2866           arg2se.want_pointer = 1;
2867           gfc_conv_expr (&arg2se, arg2->expr);
2868           gfc_add_block_to_block (&se->pre, &arg1se.pre);
2869           gfc_add_block_to_block (&se->post, &arg1se.post);
2870           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2871           se->expr = tmp;
2872         }
2873       else
2874         {
2875
2876           /* An array pointer of zero length is not associated if target is
2877              present.  */
2878           arg1se.descriptor_only = 1;
2879           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2880           tmp = gfc_conv_descriptor_stride (arg1se.expr,
2881                                             gfc_rank_cst[arg1->expr->rank - 1]);
2882           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
2883                                  tmp, integer_zero_node);
2884
2885           /* A pointer to an array, call library function _gfor_associated.  */
2886           gcc_assert (ss2 != gfc_ss_terminator);
2887           args = NULL_TREE;
2888           arg1se.want_pointer = 1;
2889           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2890           args = gfc_chainon_list (args, arg1se.expr);
2891
2892           arg2se.want_pointer = 1;
2893           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2894           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2895           gfc_add_block_to_block (&se->post, &arg2se.post);
2896           args = gfc_chainon_list (args, arg2se.expr);
2897           fndecl = gfor_fndecl_associated;
2898           se->expr = build_function_call_expr (fndecl, args);
2899           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2900                              se->expr, nonzero_arraylen);
2901
2902         }
2903
2904       /* If target is present zero character length pointers cannot
2905          be associated.  */
2906       if (nonzero_charlen != NULL_TREE)
2907         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2908                            se->expr, nonzero_charlen);
2909     }
2910
2911   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2912 }
2913
2914
2915 /* Scan a string for any one of the characters in a set of characters.  */
2916
2917 static void
2918 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2919 {
2920   tree logical4_type_node = gfc_get_logical_type (4);
2921   tree args;
2922   tree back;
2923   tree type;
2924   tree tmp;
2925
2926   args = gfc_conv_intrinsic_function_args (se, expr);
2927   type = gfc_typenode_for_spec (&expr->ts);
2928   tmp = gfc_advance_chain (args, 3);
2929   if (TREE_CHAIN (tmp) == NULL_TREE)
2930     {
2931       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2932                         NULL_TREE);
2933       TREE_CHAIN (tmp) = back;
2934     }
2935   else
2936     {
2937       back = TREE_CHAIN (tmp);
2938       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2939     }
2940
2941   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2942   se->expr = convert (type, se->expr);
2943 }
2944
2945
2946 /* Verify that a set of characters contains all the characters in a string
2947    by identifying the position of the first character in a string of
2948    characters that does not appear in a given set of characters.  */
2949
2950 static void
2951 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2952 {
2953   tree logical4_type_node = gfc_get_logical_type (4);
2954   tree args;
2955   tree back;
2956   tree type;
2957   tree tmp;
2958
2959   args = gfc_conv_intrinsic_function_args (se, expr);
2960   type = gfc_typenode_for_spec (&expr->ts);
2961   tmp = gfc_advance_chain (args, 3);
2962   if (TREE_CHAIN (tmp) == NULL_TREE)
2963     {
2964       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2965                         NULL_TREE);
2966       TREE_CHAIN (tmp) = back;
2967     }
2968   else
2969     {
2970       back = TREE_CHAIN (tmp);
2971       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2972     }
2973
2974   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2975   se->expr = convert (type, se->expr);
2976 }
2977
2978 /* Prepare components and related information of a real number which is
2979    the first argument of a elemental functions to manipulate reals.  */
2980
2981 static void
2982 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2983                   real_compnt_info * rcs, int all)
2984 {
2985    tree arg;
2986    tree masktype;
2987    tree tmp;
2988    tree wbits;
2989    tree one;
2990    tree exponent, fraction;
2991    int n;
2992    gfc_expr *a1;
2993
2994    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2995      gfc_todo_error ("Non-IEEE floating format");
2996
2997    gcc_assert (expr->expr_type == EXPR_FUNCTION);
2998
2999    arg = gfc_conv_intrinsic_function_args (se, expr);
3000    arg = TREE_VALUE (arg);
3001    rcs->type = TREE_TYPE (arg);
3002
3003    /* Force arg'type to integer by unaffected convert  */
3004    a1 = expr->value.function.actual->expr;
3005    masktype = gfc_get_int_type (a1->ts.kind);
3006    rcs->mtype = masktype;
3007    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
3008    arg = gfc_create_var (masktype, "arg");
3009    gfc_add_modify_expr(&se->pre, arg, tmp);
3010    rcs->arg = arg;
3011
3012    /* Calculate the numbers of bits of exponent, fraction and word  */
3013    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
3014    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
3015    rcs->fdigits = convert (masktype, tmp);
3016    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
3017    wbits = convert (masktype, wbits);
3018    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
3019
3020    /* Form masks for exponent/fraction/sign  */
3021    one = gfc_build_const (masktype, integer_one_node);
3022    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
3023    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
3024    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
3025    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
3026    /* Form bias.  */
3027    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
3028    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
3029    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
3030
3031    if (all)
3032      {
3033        /* exponent, and fraction  */
3034        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
3035        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
3036        exponent = gfc_create_var (masktype, "exponent");
3037        gfc_add_modify_expr(&se->pre, exponent, tmp);
3038        rcs->expn = exponent;
3039
3040        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
3041        fraction = gfc_create_var (masktype, "fraction");
3042        gfc_add_modify_expr(&se->pre, fraction, tmp);
3043        rcs->frac = fraction;
3044      }
3045 }
3046
3047 /* Build a call to __builtin_clz.  */
3048
3049 static tree
3050 call_builtin_clz (tree result_type, tree op0)
3051 {
3052   tree fn, parms, call;
3053   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
3054
3055   if (op0_mode == TYPE_MODE (integer_type_node))
3056     fn = built_in_decls[BUILT_IN_CLZ];
3057   else if (op0_mode == TYPE_MODE (long_integer_type_node))
3058     fn = built_in_decls[BUILT_IN_CLZL];
3059   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
3060     fn = built_in_decls[BUILT_IN_CLZLL];
3061   else
3062     gcc_unreachable ();
3063
3064   parms = tree_cons (NULL, op0, NULL);
3065   call = build_function_call_expr (fn, parms);
3066
3067   return convert (result_type, call);
3068 }
3069
3070
3071 /* Generate code for SPACING (X) intrinsic function.
3072    SPACING (X) = POW (2, e-p)
3073
3074    We generate:
3075
3076     t = expn - fdigits // e - p.
3077     res = t << fdigits // Form the exponent. Fraction is zero.
3078     if (t < 0) // The result is out of range. Denormalized case.
3079       res = tiny(X)
3080  */
3081
3082 static void
3083 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3084 {
3085    tree arg;
3086    tree masktype;
3087    tree tmp, t1, cond;
3088    tree tiny, zero;
3089    tree fdigits;
3090    real_compnt_info rcs;
3091
3092    prepare_arg_info (se, expr, &rcs, 0);
3093    arg = rcs.arg;
3094    masktype = rcs.mtype;
3095    fdigits = rcs.fdigits;
3096    tiny = rcs.f1;
3097    zero = gfc_build_const (masktype, integer_zero_node);
3098    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
3099    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
3100    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
3101    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
3102    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3103    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
3104    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3105
3106    se->expr = tmp;
3107 }
3108
3109 /* Generate code for RRSPACING (X) intrinsic function.
3110    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
3111
3112    So the result's exponent is p. And if X is normalized, X's fraction part
3113    is the result's fraction. If X is denormalized, to get the X's fraction we
3114    shift X's fraction part to left until the first '1' is removed.
3115
3116    We generate:
3117
3118     if (expn == 0 && frac == 0)
3119        res = 0;
3120     else
3121     {
3122        // edigits is the number of exponent bits. Add the sign bit.
3123        sedigits = edigits + 1;
3124
3125        if (expn == 0) // Denormalized case.
3126        {
3127          t1 = leadzero (frac);
3128          frac = frac << (t1 + 1); //Remove the first '1'.
3129          frac = frac >> (sedigits); //Form the fraction.
3130        }
3131
3132        //fdigits is the number of fraction bits. Form the exponent.
3133        t = bias + fdigits;
3134
3135        res = (t << fdigits) | frac;
3136     }
3137 */
3138
3139 static void
3140 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3141 {
3142    tree masktype;
3143    tree tmp, t1, t2, cond, cond2;
3144    tree one, zero;
3145    tree fdigits, fraction;
3146    real_compnt_info rcs;
3147
3148    prepare_arg_info (se, expr, &rcs, 1);
3149    masktype = rcs.mtype;
3150    fdigits = rcs.fdigits;
3151    fraction = rcs.frac;
3152    one = gfc_build_const (masktype, integer_one_node);
3153    zero = gfc_build_const (masktype, integer_zero_node);
3154    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
3155
3156    t1 = call_builtin_clz (masktype, fraction);
3157    tmp = build2 (PLUS_EXPR, masktype, t1, one);
3158    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
3159    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
3160    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
3161    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
3162
3163    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
3164    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3165    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
3166
3167    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
3168    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
3169    tmp = build3 (COND_EXPR, masktype, cond,
3170                  build_int_cst (masktype, 0), tmp);
3171
3172    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3173    se->expr = tmp;
3174 }
3175
3176 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3177
3178 static void
3179 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3180 {
3181   tree args;
3182
3183   args = gfc_conv_intrinsic_function_args (se, expr);
3184   args = TREE_VALUE (args);
3185   args = build_fold_addr_expr (args);
3186   args = tree_cons (NULL_TREE, args, NULL_TREE);
3187   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3188 }
3189
3190 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3191
3192 static void
3193 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3194 {
3195   gfc_actual_arglist *actual;
3196   tree args;
3197   gfc_se argse;
3198
3199   args = NULL_TREE;
3200   for (actual = expr->value.function.actual; actual; actual = actual->next)
3201     {
3202       gfc_init_se (&argse, se);
3203
3204       /* Pass a NULL pointer for an absent arg.  */
3205       if (actual->expr == NULL)
3206         argse.expr = null_pointer_node;
3207       else
3208         gfc_conv_expr_reference (&argse, actual->expr);
3209
3210       gfc_add_block_to_block (&se->pre, &argse.pre);
3211       gfc_add_block_to_block (&se->post, &argse.post);
3212       args = gfc_chainon_list (args, argse.expr);
3213     }
3214   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3215 }
3216
3217
3218 /* Generate code for TRIM (A) intrinsic function.  */
3219
3220 static void
3221 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3222 {
3223   tree gfc_int4_type_node = gfc_get_int_type (4);
3224   tree var;
3225   tree len;
3226   tree addr;
3227   tree tmp;
3228   tree arglist;
3229   tree type;
3230   tree cond;
3231
3232   arglist = NULL_TREE;
3233
3234   type = build_pointer_type (gfc_character1_type_node);
3235   var = gfc_create_var (type, "pstr");
3236   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3237   len = gfc_create_var (gfc_int4_type_node, "len");
3238
3239   tmp = gfc_conv_intrinsic_function_args (se, expr);
3240   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3241   arglist = gfc_chainon_list (arglist, addr);
3242   arglist = chainon (arglist, tmp);
3243
3244   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3245   gfc_add_expr_to_block (&se->pre, tmp);
3246
3247   /* Free the temporary afterwards, if necessary.  */
3248   cond = build2 (GT_EXPR, boolean_type_node, len,
3249                  build_int_cst (TREE_TYPE (len), 0));
3250   arglist = gfc_chainon_list (NULL_TREE, var);
3251   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3252   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3253   gfc_add_expr_to_block (&se->post, tmp);
3254
3255   se->expr = var;
3256   se->string_length = len;
3257 }
3258
3259
3260 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3261
3262 static void
3263 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3264 {
3265   tree gfc_int4_type_node = gfc_get_int_type (4);
3266   tree tmp;
3267   tree len;
3268   tree args;
3269   tree arglist;
3270   tree ncopies;
3271   tree var;
3272   tree type;
3273
3274   args = gfc_conv_intrinsic_function_args (se, expr);
3275   len = TREE_VALUE (args);
3276   tmp = gfc_advance_chain (args, 2);
3277   ncopies = TREE_VALUE (tmp);
3278   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3279   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3280   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3281
3282   arglist = NULL_TREE;
3283   arglist = gfc_chainon_list (arglist, var);
3284   arglist = chainon (arglist, args);
3285   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3286   gfc_add_expr_to_block (&se->pre, tmp);
3287
3288   se->expr = var;
3289   se->string_length = len;
3290 }
3291
3292
3293 /* Generate code for the IARGC intrinsic.  */
3294
3295 static void
3296 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3297 {
3298   tree tmp;
3299   tree fndecl;
3300   tree type;
3301
3302   /* Call the library function.  This always returns an INTEGER(4).  */
3303   fndecl = gfor_fndecl_iargc;
3304   tmp = build_function_call_expr (fndecl, NULL_TREE);
3305
3306   /* Convert it to the required type.  */
3307   type = gfc_typenode_for_spec (&expr->ts);
3308   tmp = fold_convert (type, tmp);
3309
3310   se->expr = tmp;
3311 }
3312
3313
3314 /* The loc intrinsic returns the address of its argument as
3315    gfc_index_integer_kind integer.  */
3316
3317 static void
3318 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
3319 {
3320   tree temp_var;
3321   gfc_expr *arg_expr;
3322   gfc_ss *ss;
3323
3324   gcc_assert (!se->ss);
3325
3326   arg_expr = expr->value.function.actual->expr;
3327   ss = gfc_walk_expr (arg_expr);
3328   if (ss == gfc_ss_terminator)
3329     gfc_conv_expr_reference (se, arg_expr);
3330   else
3331     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3332   se->expr= convert (gfc_unsigned_type (long_integer_type_node),
3333                      se->expr);
3334
3335   /* Create a temporary variable for loc return value.  Without this,
3336      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3337   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
3338                              NULL);
3339   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3340   se->expr = temp_var;
3341 }
3342
3343 /* Generate code for an intrinsic function.  Some map directly to library
3344    calls, others get special handling.  In some cases the name of the function
3345    used depends on the type specifiers.  */
3346
3347 void
3348 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3349 {
3350   gfc_intrinsic_sym *isym;
3351   const char *name;
3352   int lib;
3353
3354   isym = expr->value.function.isym;
3355
3356   name = &expr->value.function.name[2];
3357
3358   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3359     {
3360       lib = gfc_is_intrinsic_libcall (expr);
3361       if (lib != 0)
3362         {
3363           if (lib == 1)
3364             se->ignore_optional = 1;
3365           gfc_conv_intrinsic_funcall (se, expr);
3366           return;
3367         }
3368     }
3369
3370   switch (expr->value.function.isym->generic_id)
3371     {
3372     case GFC_ISYM_NONE:
3373       gcc_unreachable ();
3374
3375     case GFC_ISYM_REPEAT:
3376       gfc_conv_intrinsic_repeat (se, expr);
3377       break;
3378
3379     case GFC_ISYM_TRIM:
3380       gfc_conv_intrinsic_trim (se, expr);
3381       break;
3382
3383     case GFC_ISYM_SI_KIND:
3384       gfc_conv_intrinsic_si_kind (se, expr);
3385       break;
3386
3387     case GFC_ISYM_SR_KIND:
3388       gfc_conv_intrinsic_sr_kind (se, expr);
3389       break;
3390
3391     case GFC_ISYM_EXPONENT:
3392       gfc_conv_intrinsic_exponent (se, expr);
3393       break;
3394
3395     case GFC_ISYM_SPACING:
3396       gfc_conv_intrinsic_spacing (se, expr);
3397       break;
3398
3399     case GFC_ISYM_RRSPACING:
3400       gfc_conv_intrinsic_rrspacing (se, expr);
3401       break;
3402
3403     case GFC_ISYM_SCAN:
3404       gfc_conv_intrinsic_scan (se, expr);
3405       break;
3406
3407     case GFC_ISYM_VERIFY:
3408       gfc_conv_intrinsic_verify (se, expr);
3409       break;
3410
3411     case GFC_ISYM_ALLOCATED:
3412       gfc_conv_allocated (se, expr);
3413       break;
3414
3415     case GFC_ISYM_ASSOCIATED:
3416       gfc_conv_associated(se, expr);
3417       break;
3418
3419     case GFC_ISYM_ABS:
3420       gfc_conv_intrinsic_abs (se, expr);
3421       break;
3422
3423     case GFC_ISYM_ADJUSTL:
3424       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3425       break;
3426
3427     case GFC_ISYM_ADJUSTR:
3428       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3429       break;
3430
3431     case GFC_ISYM_AIMAG:
3432       gfc_conv_intrinsic_imagpart (se, expr);
3433       break;
3434
3435     case GFC_ISYM_AINT:
3436       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3437       break;
3438
3439     case GFC_ISYM_ALL:
3440       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3441       break;
3442
3443     case GFC_ISYM_ANINT:
3444       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3445       break;
3446
3447     case GFC_ISYM_AND:
3448       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3449       break;
3450
3451     case GFC_ISYM_ANY:
3452       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3453       break;
3454
3455     case GFC_ISYM_BTEST:
3456       gfc_conv_intrinsic_btest (se, expr);
3457       break;
3458
3459     case GFC_ISYM_ACHAR:
3460     case GFC_ISYM_CHAR:
3461       gfc_conv_intrinsic_char (se, expr);
3462       break;
3463
3464     case GFC_ISYM_CONVERSION:
3465     case GFC_ISYM_REAL:
3466     case GFC_ISYM_LOGICAL:
3467     case GFC_ISYM_DBLE:
3468       gfc_conv_intrinsic_conversion (se, expr);
3469       break;
3470
3471       /* Integer conversions are handled separately to make sure we get the
3472          correct rounding mode.  */
3473     case GFC_ISYM_INT:
3474       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3475       break;
3476
3477     case GFC_ISYM_NINT:
3478       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3479       break;
3480
3481     case GFC_ISYM_CEILING:
3482       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3483       break;
3484
3485     case GFC_ISYM_FLOOR:
3486       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3487       break;
3488
3489     case GFC_ISYM_MOD:
3490       gfc_conv_intrinsic_mod (se, expr, 0);
3491       break;
3492
3493     case GFC_ISYM_MODULO:
3494       gfc_conv_intrinsic_mod (se, expr, 1);
3495       break;
3496
3497     case GFC_ISYM_CMPLX:
3498       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3499       break;
3500
3501     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3502       gfc_conv_intrinsic_iargc (se, expr);
3503       break;
3504
3505     case GFC_ISYM_COMPLEX:
3506       gfc_conv_intrinsic_cmplx (se, expr, 1);
3507       break;
3508
3509     case GFC_ISYM_CONJG:
3510       gfc_conv_intrinsic_conjg (se, expr);
3511       break;
3512
3513     case GFC_ISYM_COUNT:
3514       gfc_conv_intrinsic_count (se, expr);
3515       break;
3516
3517     case GFC_ISYM_CTIME:
3518       gfc_conv_intrinsic_ctime (se, expr);
3519       break;
3520
3521     case GFC_ISYM_DIM:
3522       gfc_conv_intrinsic_dim (se, expr);
3523       break;
3524
3525     case GFC_ISYM_DOT_PRODUCT:
3526       gfc_conv_intrinsic_dot_product (se, expr);
3527       break;
3528
3529     case GFC_ISYM_DPROD:
3530       gfc_conv_intrinsic_dprod (se, expr);
3531       break;
3532
3533     case GFC_ISYM_FDATE:
3534       gfc_conv_intrinsic_fdate (se, expr);
3535       break;
3536
3537     case GFC_ISYM_IAND:
3538       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3539       break;
3540
3541     case GFC_ISYM_IBCLR:
3542       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3543       break;
3544
3545     case GFC_ISYM_IBITS:
3546       gfc_conv_intrinsic_ibits (se, expr);
3547       break;
3548
3549     case GFC_ISYM_IBSET:
3550       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3551       break;
3552
3553     case GFC_ISYM_IACHAR:
3554     case GFC_ISYM_ICHAR:
3555       /* We assume ASCII character sequence.  */
3556       gfc_conv_intrinsic_ichar (se, expr);
3557       break;
3558
3559     case GFC_ISYM_IARGC:
3560       gfc_conv_intrinsic_iargc (se, expr);
3561       break;
3562
3563     case GFC_ISYM_IEOR:
3564       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3565       break;
3566
3567     case GFC_ISYM_INDEX:
3568       gfc_conv_intrinsic_index (se, expr);
3569       break;
3570
3571     case GFC_ISYM_IOR:
3572       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3573       break;
3574
3575     case GFC_ISYM_ISHFT:
3576       gfc_conv_intrinsic_ishft (se, expr);
3577       break;
3578
3579     case GFC_ISYM_ISHFTC:
3580       gfc_conv_intrinsic_ishftc (se, expr);
3581       break;
3582
3583     case GFC_ISYM_LBOUND:
3584       gfc_conv_intrinsic_bound (se, expr, 0);
3585       break;
3586
3587     case GFC_ISYM_TRANSPOSE:
3588       if (se->ss && se->ss->useflags)
3589         {
3590           gfc_conv_tmp_array_ref (se);
3591           gfc_advance_se_ss_chain (se);
3592         }
3593       else
3594         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3595       break;
3596
3597     case GFC_ISYM_LEN:
3598       gfc_conv_intrinsic_len (se, expr);
3599       break;
3600
3601     case GFC_ISYM_LEN_TRIM:
3602       gfc_conv_intrinsic_len_trim (se, expr);
3603       break;
3604
3605     case GFC_ISYM_LGE:
3606       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3607       break;
3608
3609     case GFC_ISYM_LGT:
3610       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3611       break;
3612
3613     case GFC_ISYM_LLE:
3614       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3615       break;
3616
3617     case GFC_ISYM_LLT:
3618       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3619       break;
3620
3621     case GFC_ISYM_MAX:
3622       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3623       break;
3624
3625     case GFC_ISYM_MAXLOC:
3626       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3627       break;
3628
3629     case GFC_ISYM_MAXVAL:
3630       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3631       break;
3632
3633     case GFC_ISYM_MERGE:
3634       gfc_conv_intrinsic_merge (se, expr);
3635       break;
3636
3637     case GFC_ISYM_MIN:
3638       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3639       break;
3640
3641     case GFC_ISYM_MINLOC:
3642       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3643       break;
3644
3645     case GFC_ISYM_MINVAL:
3646       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3647       break;
3648
3649     case GFC_ISYM_NOT:
3650       gfc_conv_intrinsic_not (se, expr);
3651       break;
3652
3653     case GFC_ISYM_OR:
3654       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3655       break;
3656
3657     case GFC_ISYM_PRESENT:
3658       gfc_conv_intrinsic_present (se, expr);
3659       break;
3660
3661     case GFC_ISYM_PRODUCT:
3662       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3663       break;
3664
3665     case GFC_ISYM_SIGN:
3666       gfc_conv_intrinsic_sign (se, expr);
3667       break;
3668
3669     case GFC_ISYM_SIZE:
3670       gfc_conv_intrinsic_size (se, expr);
3671       break;
3672
3673     case GFC_ISYM_SUM:
3674       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3675       break;
3676
3677     case GFC_ISYM_TRANSFER:
3678       if (se->ss)
3679         {
3680           if (se->ss->useflags)
3681             {
3682               /* Access the previously obtained result.  */
3683               gfc_conv_tmp_array_ref (se);
3684               gfc_advance_se_ss_chain (se);
3685               break;
3686             }
3687           else
3688             gfc_conv_intrinsic_array_transfer (se, expr);
3689         }
3690       else
3691         gfc_conv_intrinsic_transfer (se, expr);
3692       break;
3693
3694     case GFC_ISYM_TTYNAM:
3695       gfc_conv_intrinsic_ttynam (se, expr);
3696       break;
3697
3698     case GFC_ISYM_UBOUND:
3699       gfc_conv_intrinsic_bound (se, expr, 1);
3700       break;
3701
3702     case GFC_ISYM_XOR:
3703       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3704       break;
3705
3706     case GFC_ISYM_LOC:
3707       gfc_conv_intrinsic_loc (se, expr);
3708       break;
3709
3710     case GFC_ISYM_CHDIR:
3711     case GFC_ISYM_ETIME:
3712     case GFC_ISYM_FGET:
3713     case GFC_ISYM_FGETC:
3714     case GFC_ISYM_FNUM:
3715     case GFC_ISYM_FPUT:
3716     case GFC_ISYM_FPUTC:
3717     case GFC_ISYM_FSTAT:
3718     case GFC_ISYM_FTELL:
3719     case GFC_ISYM_GETCWD:
3720     case GFC_ISYM_GETGID:
3721     case GFC_ISYM_GETPID:
3722     case GFC_ISYM_GETUID:
3723     case GFC_ISYM_HOSTNM:
3724     case GFC_ISYM_KILL:
3725     case GFC_ISYM_IERRNO:
3726     case GFC_ISYM_IRAND:
3727     case GFC_ISYM_ISATTY:
3728     case GFC_ISYM_LINK:
3729     case GFC_ISYM_MALLOC:
3730     case GFC_ISYM_MATMUL:
3731     case GFC_ISYM_RAND:
3732     case GFC_ISYM_RENAME:
3733     case GFC_ISYM_SECOND:
3734     case GFC_ISYM_SECNDS:
3735     case GFC_ISYM_SIGNAL:
3736     case GFC_ISYM_STAT:
3737     case GFC_ISYM_SYMLNK:
3738     case GFC_ISYM_SYSTEM:
3739     case GFC_ISYM_TIME:
3740     case GFC_ISYM_TIME8:
3741     case GFC_ISYM_UMASK:
3742     case GFC_ISYM_UNLINK:
3743       gfc_conv_intrinsic_funcall (se, expr);
3744       break;
3745
3746     default:
3747       gfc_conv_intrinsic_lib_function (se, expr);
3748       break;
3749     }
3750 }
3751
3752
3753 /* This generates code to execute before entering the scalarization loop.
3754    Currently does nothing.  */
3755
3756 void
3757 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3758 {
3759   switch (ss->expr->value.function.isym->generic_id)
3760     {
3761     case GFC_ISYM_UBOUND:
3762     case GFC_ISYM_LBOUND:
3763       break;
3764
3765     default:
3766       gcc_unreachable ();
3767     }
3768 }
3769
3770
3771 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3772    inside the scalarization loop.  */
3773
3774 static gfc_ss *
3775 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3776 {
3777   gfc_ss *newss;
3778
3779   /* The two argument version returns a scalar.  */
3780   if (expr->value.function.actual->next->expr)
3781     return ss;
3782
3783   newss = gfc_get_ss ();
3784   newss->type = GFC_SS_INTRINSIC;
3785   newss->expr = expr;
3786   newss->next = ss;
3787   newss->data.info.dimen = 1;
3788
3789   return newss;
3790 }
3791
3792
3793 /* Walk an intrinsic array libcall.  */
3794
3795 static gfc_ss *
3796 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3797 {
3798   gfc_ss *newss;
3799
3800   gcc_assert (expr->rank > 0);
3801
3802   newss = gfc_get_ss ();
3803   newss->type = GFC_SS_FUNCTION;
3804   newss->expr = expr;
3805   newss->next = ss;
3806   newss->data.info.dimen = expr->rank;
3807
3808   return newss;
3809 }
3810
3811
3812 /* Returns nonzero if the specified intrinsic function call maps directly to a
3813    an external library call.  Should only be used for functions that return
3814    arrays.  */
3815
3816 int
3817 gfc_is_intrinsic_libcall (gfc_expr * expr)
3818 {
3819   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3820   gcc_assert (expr->rank > 0);
3821
3822   switch (expr->value.function.isym->generic_id)
3823     {
3824     case GFC_ISYM_ALL:
3825     case GFC_ISYM_ANY:
3826     case GFC_ISYM_COUNT:
3827     case GFC_ISYM_MATMUL:
3828     case GFC_ISYM_MAXLOC:
3829     case GFC_ISYM_MAXVAL:
3830     case GFC_ISYM_MINLOC:
3831     case GFC_ISYM_MINVAL:
3832     case GFC_ISYM_PRODUCT:
3833     case GFC_ISYM_SUM:
3834     case GFC_ISYM_SHAPE:
3835     case GFC_ISYM_SPREAD:
3836     case GFC_ISYM_TRANSPOSE:
3837       /* Ignore absent optional parameters.  */
3838       return 1;
3839
3840     case GFC_ISYM_RESHAPE:
3841     case GFC_ISYM_CSHIFT:
3842     case GFC_ISYM_EOSHIFT:
3843     case GFC_ISYM_PACK:
3844     case GFC_ISYM_UNPACK:
3845       /* Pass absent optional parameters.  */
3846       return 2;
3847
3848     default:
3849       return 0;
3850     }
3851 }
3852
3853 /* Walk an intrinsic function.  */
3854 gfc_ss *
3855 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3856                              gfc_intrinsic_sym * isym)
3857 {
3858   gcc_assert (isym);
3859
3860   if (isym->elemental)
3861     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3862
3863   if (expr->rank == 0)
3864     return ss;
3865
3866   if (gfc_is_intrinsic_libcall (expr))
3867     return gfc_walk_intrinsic_libfunc (ss, expr);
3868
3869   /* Special cases.  */
3870   switch (isym->generic_id)
3871     {
3872     case GFC_ISYM_LBOUND:
3873     case GFC_ISYM_UBOUND:
3874       return gfc_walk_intrinsic_bound (ss, expr);
3875
3876     case GFC_ISYM_TRANSFER:
3877       return gfc_walk_intrinsic_libfunc (ss, expr);
3878
3879     default:
3880       /* This probably meant someone forgot to add an intrinsic to the above
3881          list(s) when they implemented it, or something's gone horribly wrong.
3882        */
3883       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3884                       expr->value.function.name);
3885     }
3886 }
3887
3888 #include "gt-fortran-trans-intrinsic.h"