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, ikind;
 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, true);
 890       ikind = expr->ts.kind;
 891       if (n < 0)
 892         {
 893           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
 894           ikind = gfc_max_integer_kind;
 895         }
 896       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 897       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 898       test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
 899
 900       mpfr_neg (huge, huge, GFC_RND_MODE);
 901       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
 902       test = build2 (GT_EXPR, boolean_type_node, tmp, test);
 903       test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 904
 905       itype = gfc_get_int_type (ikind);
 906       if (modulo)
 907        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
 908       else
 909        tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 910       tmp = convert (type, tmp);
 911       tmp = build3 (COND_EXPR, type, test2, tmp, arg);
 912       tmp = build2 (MULT_EXPR, type, tmp, arg2);
 913       se->expr = build2 (MINUS_EXPR, type, arg, tmp);
 914       mpfr_clear (huge);
 915       break;
 916
 917     default:
 918       gcc_unreachable ();
 919     }
 920 }
 921
 922 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 923
 924 static void
 925 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 926 {
 927   tree arg;
 928   tree arg2;
 929   tree val;
 930   tree tmp;
 931   tree type;
 932   tree zero;
 933
 934   arg = gfc_conv_intrinsic_function_args (se, expr);
 935   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 936   arg = TREE_VALUE (arg);
 937   type = TREE_TYPE (arg);
 938
 939   val = build2 (MINUS_EXPR, type, arg, arg2);
 940   val = gfc_evaluate_now (val, &se->pre);
 941
 942   zero = gfc_build_const (type, integer_zero_node);
 943   tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
 944   se->expr = build3 (COND_EXPR, type, tmp, zero, val);
 945 }
 946
 947
 948 /* SIGN(A, B) is absolute value of A times sign of B.
 949    The real value versions use library functions to ensure the correct
 950    handling of negative zero.  Integer case implemented as:
 951    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 952   */
 953
 954 static void
 955 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 956 {
 957   tree tmp;
 958   tree arg;
 959   tree arg2;
 960   tree type;
 961   tree zero;
 962   tree testa;
 963   tree testb;
 964
 965
 966   arg = gfc_conv_intrinsic_function_args (se, expr);
 967   if (expr->ts.type == BT_REAL)
 968     {
 969       switch (expr->ts.kind)
 970         {
 971         case 4:
 972           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
 973           break;
 974         case 8:
 975           tmp = built_in_decls[BUILT_IN_COPYSIGN];
 976           break;
 977         case 10:
 978         case 16:
 979           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
 980           break;
 981         default:
 982           gcc_unreachable ();
 983         }
 984       se->expr = build_function_call_expr (tmp, arg);
 985       return;
 986     }
 987
 988   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 989   arg = TREE_VALUE (arg);
 990   type = TREE_TYPE (arg);
 991   zero = gfc_build_const (type, integer_zero_node);
 992
 993   testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero);
 994   testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero);
 995   tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb);
 996   se->expr = fold_build3 (COND_EXPR, type, tmp,
 997                           build1 (NEGATE_EXPR, type, arg), arg);
 998 }
 999
1000
1001 /* Test for the presence of an optional argument.  */
1002
1003 static void
1004 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1005 {
1006   gfc_expr *arg;
1007
1008   arg = expr->value.function.actual->expr;
1009   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1010   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1011   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1012 }
1013
1014
1015 /* Calculate the double precision product of two single precision values.  */
1016
1017 static void
1018 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1019 {
1020   tree arg;
1021   tree arg2;
1022   tree type;
1023
1024   arg = gfc_conv_intrinsic_function_args (se, expr);
1025   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1026   arg = TREE_VALUE (arg);
1027
1028   /* Convert the args to double precision before multiplying.  */
1029   type = gfc_typenode_for_spec (&expr->ts);
1030   arg = convert (type, arg);
1031   arg2 = convert (type, arg2);
1032   se->expr = build2 (MULT_EXPR, type, arg, arg2);
1033 }
1034
1035
1036 /* Return a length one character string containing an ascii character.  */
1037
1038 static void
1039 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1040 {
1041   tree arg;
1042   tree var;
1043   tree type;
1044
1045   arg = gfc_conv_intrinsic_function_args (se, expr);
1046   arg = TREE_VALUE (arg);
1047
1048   /* We currently don't support character types != 1.  */
1049   gcc_assert (expr->ts.kind == 1);
1050   type = gfc_character1_type_node;
1051   var = gfc_create_var (type, "char");
1052
1053   arg = convert (type, arg);
1054   gfc_add_modify_expr (&se->pre, var, arg);
1055   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1056   se->string_length = integer_one_node;
1057 }
1058
1059
1060 static void
1061 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1062 {
1063   tree var;
1064   tree len;
1065   tree tmp;
1066   tree arglist;
1067   tree type;
1068   tree cond;
1069   tree gfc_int8_type_node = gfc_get_int_type (8);
1070
1071   type = build_pointer_type (gfc_character1_type_node);
1072   var = gfc_create_var (type, "pstr");
1073   len = gfc_create_var (gfc_int8_type_node, "len");
1074
1075   tmp = gfc_conv_intrinsic_function_args (se, expr);
1076   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1077   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1078   arglist = chainon (arglist, tmp);
1079
1080   tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
1081   gfc_add_expr_to_block (&se->pre, tmp);
1082
1083   /* Free the temporary afterwards, if necessary.  */
1084   cond = build2 (GT_EXPR, boolean_type_node, len,
1085                  build_int_cst (TREE_TYPE (len), 0));
1086   arglist = gfc_chainon_list (NULL_TREE, var);
1087   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1088   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1089   gfc_add_expr_to_block (&se->post, tmp);
1090
1091   se->expr = var;
1092   se->string_length = len;
1093 }
1094
1095
1096 static void
1097 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1098 {
1099   tree var;
1100   tree len;
1101   tree tmp;
1102   tree arglist;
1103   tree type;
1104   tree cond;
1105   tree gfc_int4_type_node = gfc_get_int_type (4);
1106
1107   type = build_pointer_type (gfc_character1_type_node);
1108   var = gfc_create_var (type, "pstr");
1109   len = gfc_create_var (gfc_int4_type_node, "len");
1110
1111   tmp = gfc_conv_intrinsic_function_args (se, expr);
1112   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1113   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1114   arglist = chainon (arglist, tmp);
1115
1116   tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
1117   gfc_add_expr_to_block (&se->pre, tmp);
1118
1119   /* Free the temporary afterwards, if necessary.  */
1120   cond = build2 (GT_EXPR, boolean_type_node, len,
1121                  build_int_cst (TREE_TYPE (len), 0));
1122   arglist = gfc_chainon_list (NULL_TREE, var);
1123   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1124   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1125   gfc_add_expr_to_block (&se->post, tmp);
1126
1127   se->expr = var;
1128   se->string_length = len;
1129 }
1130
1131
1132 /* Return a character string containing the tty name.  */
1133
1134 static void
1135 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1136 {
1137   tree var;
1138   tree len;
1139   tree tmp;
1140   tree arglist;
1141   tree type;
1142   tree cond;
1143   tree gfc_int4_type_node = gfc_get_int_type (4);
1144
1145   type = build_pointer_type (gfc_character1_type_node);
1146   var = gfc_create_var (type, "pstr");
1147   len = gfc_create_var (gfc_int4_type_node, "len");
1148
1149   tmp = gfc_conv_intrinsic_function_args (se, expr);
1150   arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
1151   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
1152   arglist = chainon (arglist, tmp);
1153
1154   tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
1155   gfc_add_expr_to_block (&se->pre, tmp);
1156
1157   /* Free the temporary afterwards, if necessary.  */
1158   cond = build2 (GT_EXPR, boolean_type_node, len,
1159                  build_int_cst (TREE_TYPE (len), 0));
1160   arglist = gfc_chainon_list (NULL_TREE, var);
1161   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
1162   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1163   gfc_add_expr_to_block (&se->post, tmp);
1164
1165   se->expr = var;
1166   se->string_length = len;
1167 }
1168
1169
1170 /* Get the minimum/maximum value of all the parameters.
1171     minmax (a1, a2, a3, ...)
1172     {
1173       if (a2 .op. a1)
1174         mvar = a2;
1175       else
1176         mvar = a1;
1177       if (a3 .op. mvar)
1178         mvar = a3;
1179       ...
1180       return mvar
1181     }
1182  */
1183
1184 /* TODO: Mismatching types can occur when specific names are used.
1185    These should be handled during resolution.  */
1186 static void
1187 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1188 {
1189   tree limit;
1190   tree tmp;
1191   tree mvar;
1192   tree val;
1193   tree thencase;
1194   tree elsecase;
1195   tree arg;
1196   tree type;
1197
1198   arg = gfc_conv_intrinsic_function_args (se, expr);
1199   type = gfc_typenode_for_spec (&expr->ts);
1200
1201   limit = TREE_VALUE (arg);
1202   if (TREE_TYPE (limit) != type)
1203     limit = convert (type, limit);
1204   /* Only evaluate the argument once.  */
1205   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1206     limit = gfc_evaluate_now(limit, &se->pre);
1207
1208   mvar = gfc_create_var (type, "M");
1209   elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1210   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1211     {
1212       val = TREE_VALUE (arg);
1213       if (TREE_TYPE (val) != type)
1214         val = convert (type, val);
1215
1216       /* Only evaluate the argument once.  */
1217       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1218         val = gfc_evaluate_now(val, &se->pre);
1219
1220       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1221
1222       tmp = build2 (op, boolean_type_node, val, limit);
1223       tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1224       gfc_add_expr_to_block (&se->pre, tmp);
1225       elsecase = build_empty_stmt ();
1226       limit = mvar;
1227     }
1228   se->expr = mvar;
1229 }
1230
1231
1232 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1233    has the generic name.  */
1234
1235 static gfc_symbol *
1236 gfc_get_symbol_for_expr (gfc_expr * expr)
1237 {
1238   gfc_symbol *sym;
1239
1240   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1241   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1242   sym = gfc_new_symbol (expr->value.function.name, NULL);
1243
1244   sym->ts = expr->ts;
1245   sym->attr.external = 1;
1246   sym->attr.function = 1;
1247   sym->attr.always_explicit = 1;
1248   sym->attr.proc = PROC_INTRINSIC;
1249   sym->attr.flavor = FL_PROCEDURE;
1250   sym->result = sym;
1251   if (expr->rank > 0)
1252     {
1253       sym->attr.dimension = 1;
1254       sym->as = gfc_get_array_spec ();
1255       sym->as->type = AS_ASSUMED_SHAPE;
1256       sym->as->rank = expr->rank;
1257     }
1258
1259   /* TODO: proper argument lists for external intrinsics.  */
1260   return sym;
1261 }
1262
1263 /* Generate a call to an external intrinsic function.  */
1264 static void
1265 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1266 {
1267   gfc_symbol *sym;
1268
1269   gcc_assert (!se->ss || se->ss->expr == expr);
1270
1271   if (se->ss)
1272     gcc_assert (expr->rank > 0);
1273   else
1274     gcc_assert (expr->rank == 0);
1275
1276   sym = gfc_get_symbol_for_expr (expr);
1277   gfc_conv_function_call (se, sym, expr->value.function.actual);
1278   gfc_free (sym);
1279 }
1280
1281 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1282    Implemented as
1283     any(a)
1284     {
1285       forall (i=...)
1286         if (a[i] != 0)
1287           return 1
1288       end forall
1289       return 0
1290     }
1291     all(a)
1292     {
1293       forall (i=...)
1294         if (a[i] == 0)
1295           return 0
1296       end forall
1297       return 1
1298     }
1299  */
1300 static void
1301 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1302 {
1303   tree resvar;
1304   stmtblock_t block;
1305   stmtblock_t body;
1306   tree type;
1307   tree tmp;
1308   tree found;
1309   gfc_loopinfo loop;
1310   gfc_actual_arglist *actual;
1311   gfc_ss *arrayss;
1312   gfc_se arrayse;
1313   tree exit_label;
1314
1315   if (se->ss)
1316     {
1317       gfc_conv_intrinsic_funcall (se, expr);
1318       return;
1319     }
1320
1321   actual = expr->value.function.actual;
1322   type = gfc_typenode_for_spec (&expr->ts);
1323   /* Initialize the result.  */
1324   resvar = gfc_create_var (type, "test");
1325   if (op == EQ_EXPR)
1326     tmp = convert (type, boolean_true_node);
1327   else
1328     tmp = convert (type, boolean_false_node);
1329   gfc_add_modify_expr (&se->pre, resvar, tmp);
1330
1331   /* Walk the arguments.  */
1332   arrayss = gfc_walk_expr (actual->expr);
1333   gcc_assert (arrayss != gfc_ss_terminator);
1334
1335   /* Initialize the scalarizer.  */
1336   gfc_init_loopinfo (&loop);
1337   exit_label = gfc_build_label_decl (NULL_TREE);
1338   TREE_USED (exit_label) = 1;
1339   gfc_add_ss_to_loop (&loop, arrayss);
1340
1341   /* Initialize the loop.  */
1342   gfc_conv_ss_startstride (&loop);
1343   gfc_conv_loop_setup (&loop);
1344
1345   gfc_mark_ss_chain_used (arrayss, 1);
1346   /* Generate the loop body.  */
1347   gfc_start_scalarized_body (&loop, &body);
1348
1349   /* If the condition matches then set the return value.  */
1350   gfc_start_block (&block);
1351   if (op == EQ_EXPR)
1352     tmp = convert (type, boolean_false_node);
1353   else
1354     tmp = convert (type, boolean_true_node);
1355   gfc_add_modify_expr (&block, resvar, tmp);
1356
1357   /* And break out of the loop.  */
1358   tmp = build1_v (GOTO_EXPR, exit_label);
1359   gfc_add_expr_to_block (&block, tmp);
1360
1361   found = gfc_finish_block (&block);
1362
1363   /* Check this element.  */
1364   gfc_init_se (&arrayse, NULL);
1365   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1366   arrayse.ss = arrayss;
1367   gfc_conv_expr_val (&arrayse, actual->expr);
1368
1369   gfc_add_block_to_block (&body, &arrayse.pre);
1370   tmp = build2 (op, boolean_type_node, arrayse.expr,
1371                 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1372   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1373   gfc_add_expr_to_block (&body, tmp);
1374   gfc_add_block_to_block (&body, &arrayse.post);
1375
1376   gfc_trans_scalarizing_loops (&loop, &body);
1377
1378   /* Add the exit label.  */
1379   tmp = build1_v (LABEL_EXPR, exit_label);
1380   gfc_add_expr_to_block (&loop.pre, tmp);
1381
1382   gfc_add_block_to_block (&se->pre, &loop.pre);
1383   gfc_add_block_to_block (&se->pre, &loop.post);
1384   gfc_cleanup_loop (&loop);
1385
1386   se->expr = resvar;
1387 }
1388
1389 /* COUNT(A) = Number of true elements in A.  */
1390 static void
1391 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1392 {
1393   tree resvar;
1394   tree type;
1395   stmtblock_t body;
1396   tree tmp;
1397   gfc_loopinfo loop;
1398   gfc_actual_arglist *actual;
1399   gfc_ss *arrayss;
1400   gfc_se arrayse;
1401
1402   if (se->ss)
1403     {
1404       gfc_conv_intrinsic_funcall (se, expr);
1405       return;
1406     }
1407
1408   actual = expr->value.function.actual;
1409
1410   type = gfc_typenode_for_spec (&expr->ts);
1411   /* Initialize the result.  */
1412   resvar = gfc_create_var (type, "count");
1413   gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1414
1415   /* Walk the arguments.  */
1416   arrayss = gfc_walk_expr (actual->expr);
1417   gcc_assert (arrayss != gfc_ss_terminator);
1418
1419   /* Initialize the scalarizer.  */
1420   gfc_init_loopinfo (&loop);
1421   gfc_add_ss_to_loop (&loop, arrayss);
1422
1423   /* Initialize the loop.  */
1424   gfc_conv_ss_startstride (&loop);
1425   gfc_conv_loop_setup (&loop);
1426
1427   gfc_mark_ss_chain_used (arrayss, 1);
1428   /* Generate the loop body.  */
1429   gfc_start_scalarized_body (&loop, &body);
1430
1431   tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1432                 build_int_cst (TREE_TYPE (resvar), 1));
1433   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1434
1435   gfc_init_se (&arrayse, NULL);
1436   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1437   arrayse.ss = arrayss;
1438   gfc_conv_expr_val (&arrayse, actual->expr);
1439   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1440
1441   gfc_add_block_to_block (&body, &arrayse.pre);
1442   gfc_add_expr_to_block (&body, tmp);
1443   gfc_add_block_to_block (&body, &arrayse.post);
1444
1445   gfc_trans_scalarizing_loops (&loop, &body);
1446
1447   gfc_add_block_to_block (&se->pre, &loop.pre);
1448   gfc_add_block_to_block (&se->pre, &loop.post);
1449   gfc_cleanup_loop (&loop);
1450
1451   se->expr = resvar;
1452 }
1453
1454 /* Inline implementation of the sum and product intrinsics.  */
1455 static void
1456 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1457 {
1458   tree resvar;
1459   tree type;
1460   stmtblock_t body;
1461   stmtblock_t block;
1462   tree tmp;
1463   gfc_loopinfo loop;
1464   gfc_actual_arglist *actual;
1465   gfc_ss *arrayss;
1466   gfc_ss *maskss;
1467   gfc_se arrayse;
1468   gfc_se maskse;
1469   gfc_expr *arrayexpr;
1470   gfc_expr *maskexpr;
1471
1472   if (se->ss)
1473     {
1474       gfc_conv_intrinsic_funcall (se, expr);
1475       return;
1476     }
1477
1478   type = gfc_typenode_for_spec (&expr->ts);
1479   /* Initialize the result.  */
1480   resvar = gfc_create_var (type, "val");
1481   if (op == PLUS_EXPR)
1482     tmp = gfc_build_const (type, integer_zero_node);
1483   else
1484     tmp = gfc_build_const (type, integer_one_node);
1485
1486   gfc_add_modify_expr (&se->pre, resvar, tmp);
1487
1488   /* Walk the arguments.  */
1489   actual = expr->value.function.actual;
1490   arrayexpr = actual->expr;
1491   arrayss = gfc_walk_expr (arrayexpr);
1492   gcc_assert (arrayss != gfc_ss_terminator);
1493
1494   actual = actual->next->next;
1495   gcc_assert (actual);
1496   maskexpr = actual->expr;
1497   if (maskexpr && maskexpr->rank != 0)
1498     {
1499       maskss = gfc_walk_expr (maskexpr);
1500       gcc_assert (maskss != gfc_ss_terminator);
1501     }
1502   else
1503     maskss = NULL;
1504
1505   /* Initialize the scalarizer.  */
1506   gfc_init_loopinfo (&loop);
1507   gfc_add_ss_to_loop (&loop, arrayss);
1508   if (maskss)
1509     gfc_add_ss_to_loop (&loop, maskss);
1510
1511   /* Initialize the loop.  */
1512   gfc_conv_ss_startstride (&loop);
1513   gfc_conv_loop_setup (&loop);
1514
1515   gfc_mark_ss_chain_used (arrayss, 1);
1516   if (maskss)
1517     gfc_mark_ss_chain_used (maskss, 1);
1518   /* Generate the loop body.  */
1519   gfc_start_scalarized_body (&loop, &body);
1520
1521   /* If we have a mask, only add this element if the mask is set.  */
1522   if (maskss)
1523     {
1524       gfc_init_se (&maskse, NULL);
1525       gfc_copy_loopinfo_to_se (&maskse, &loop);
1526       maskse.ss = maskss;
1527       gfc_conv_expr_val (&maskse, maskexpr);
1528       gfc_add_block_to_block (&body, &maskse.pre);
1529
1530       gfc_start_block (&block);
1531     }
1532   else
1533     gfc_init_block (&block);
1534
1535   /* Do the actual summation/product.  */
1536   gfc_init_se (&arrayse, NULL);
1537   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1538   arrayse.ss = arrayss;
1539   gfc_conv_expr_val (&arrayse, arrayexpr);
1540   gfc_add_block_to_block (&block, &arrayse.pre);
1541
1542   tmp = build2 (op, type, resvar, arrayse.expr);
1543   gfc_add_modify_expr (&block, resvar, tmp);
1544   gfc_add_block_to_block (&block, &arrayse.post);
1545
1546   if (maskss)
1547     {
1548       /* We enclose the above in if (mask) {...} .  */
1549       tmp = gfc_finish_block (&block);
1550
1551       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1552     }
1553   else
1554     tmp = gfc_finish_block (&block);
1555   gfc_add_expr_to_block (&body, tmp);
1556
1557   gfc_trans_scalarizing_loops (&loop, &body);
1558
1559   /* For a scalar mask, enclose the loop in an if statement.  */
1560   if (maskexpr && maskss == NULL)
1561     {
1562       gfc_init_se (&maskse, NULL);
1563       gfc_conv_expr_val (&maskse, maskexpr);
1564       gfc_init_block (&block);
1565       gfc_add_block_to_block (&block, &loop.pre);
1566       gfc_add_block_to_block (&block, &loop.post);
1567       tmp = gfc_finish_block (&block);
1568
1569       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1570       gfc_add_expr_to_block (&block, tmp);
1571       gfc_add_block_to_block (&se->pre, &block);
1572     }
1573   else
1574     {
1575       gfc_add_block_to_block (&se->pre, &loop.pre);
1576       gfc_add_block_to_block (&se->pre, &loop.post);
1577     }
1578
1579   gfc_cleanup_loop (&loop);
1580
1581   se->expr = resvar;
1582 }
1583
1584
1585 /* Inline implementation of the dot_product intrinsic. This function
1586    is based on gfc_conv_intrinsic_arith (the previous function).  */
1587 static void
1588 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1589 {
1590   tree resvar;
1591   tree type;
1592   stmtblock_t body;
1593   stmtblock_t block;
1594   tree tmp;
1595   gfc_loopinfo loop;
1596   gfc_actual_arglist *actual;
1597   gfc_ss *arrayss1, *arrayss2;
1598   gfc_se arrayse1, arrayse2;
1599   gfc_expr *arrayexpr1, *arrayexpr2;
1600
1601   type = gfc_typenode_for_spec (&expr->ts);
1602
1603   /* Initialize the result.  */
1604   resvar = gfc_create_var (type, "val");
1605   if (expr->ts.type == BT_LOGICAL)
1606     tmp = convert (type, integer_zero_node);
1607   else
1608     tmp = gfc_build_const (type, integer_zero_node);
1609
1610   gfc_add_modify_expr (&se->pre, resvar, tmp);
1611
1612   /* Walk argument #1.  */
1613   actual = expr->value.function.actual;
1614   arrayexpr1 = actual->expr;
1615   arrayss1 = gfc_walk_expr (arrayexpr1);
1616   gcc_assert (arrayss1 != gfc_ss_terminator);
1617
1618   /* Walk argument #2.  */
1619   actual = actual->next;
1620   arrayexpr2 = actual->expr;
1621   arrayss2 = gfc_walk_expr (arrayexpr2);
1622   gcc_assert (arrayss2 != gfc_ss_terminator);
1623
1624   /* Initialize the scalarizer.  */
1625   gfc_init_loopinfo (&loop);
1626   gfc_add_ss_to_loop (&loop, arrayss1);
1627   gfc_add_ss_to_loop (&loop, arrayss2);
1628
1629   /* Initialize the loop.  */
1630   gfc_conv_ss_startstride (&loop);
1631   gfc_conv_loop_setup (&loop);
1632
1633   gfc_mark_ss_chain_used (arrayss1, 1);
1634   gfc_mark_ss_chain_used (arrayss2, 1);
1635
1636   /* Generate the loop body.  */
1637   gfc_start_scalarized_body (&loop, &body);
1638   gfc_init_block (&block);
1639
1640   /* Make the tree expression for [conjg(]array1[)].  */
1641   gfc_init_se (&arrayse1, NULL);
1642   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
1643   arrayse1.ss = arrayss1;
1644   gfc_conv_expr_val (&arrayse1, arrayexpr1);
1645   if (expr->ts.type == BT_COMPLEX)
1646     arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
1647   gfc_add_block_to_block (&block, &arrayse1.pre);
1648
1649   /* Make the tree expression for array2.  */
1650   gfc_init_se (&arrayse2, NULL);
1651   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
1652   arrayse2.ss = arrayss2;
1653   gfc_conv_expr_val (&arrayse2, arrayexpr2);
1654   gfc_add_block_to_block (&block, &arrayse2.pre);
1655
1656   /* Do the actual product and sum.  */
1657   if (expr->ts.type == BT_LOGICAL)
1658     {
1659       tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
1660       tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
1661     }
1662   else
1663     {
1664       tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
1665       tmp = build2 (PLUS_EXPR, type, resvar, tmp);
1666     }
1667   gfc_add_modify_expr (&block, resvar, tmp);
1668
1669   /* Finish up the loop block and the loop.  */
1670   tmp = gfc_finish_block (&block);
1671   gfc_add_expr_to_block (&body, tmp);
1672
1673   gfc_trans_scalarizing_loops (&loop, &body);
1674   gfc_add_block_to_block (&se->pre, &loop.pre);
1675   gfc_add_block_to_block (&se->pre, &loop.post);
1676   gfc_cleanup_loop (&loop);
1677
1678   se->expr = resvar;
1679 }
1680
1681
1682 static void
1683 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1684 {
1685   stmtblock_t body;
1686   stmtblock_t block;
1687   stmtblock_t ifblock;
1688   stmtblock_t elseblock;
1689   tree limit;
1690   tree type;
1691   tree tmp;
1692   tree elsetmp;
1693   tree ifbody;
1694   gfc_loopinfo loop;
1695   gfc_actual_arglist *actual;
1696   gfc_ss *arrayss;
1697   gfc_ss *maskss;
1698   gfc_se arrayse;
1699   gfc_se maskse;
1700   gfc_expr *arrayexpr;
1701   gfc_expr *maskexpr;
1702   tree pos;
1703   int n;
1704
1705   if (se->ss)
1706     {
1707       gfc_conv_intrinsic_funcall (se, expr);
1708       return;
1709     }
1710
1711   /* Initialize the result.  */
1712   pos = gfc_create_var (gfc_array_index_type, "pos");
1713   type = gfc_typenode_for_spec (&expr->ts);
1714
1715   /* Walk the arguments.  */
1716   actual = expr->value.function.actual;
1717   arrayexpr = actual->expr;
1718   arrayss = gfc_walk_expr (arrayexpr);
1719   gcc_assert (arrayss != gfc_ss_terminator);
1720
1721   actual = actual->next->next;
1722   gcc_assert (actual);
1723   maskexpr = actual->expr;
1724   if (maskexpr && maskexpr->rank != 0)
1725     {
1726       maskss = gfc_walk_expr (maskexpr);
1727       gcc_assert (maskss != gfc_ss_terminator);
1728     }
1729   else
1730     maskss = NULL;
1731
1732   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1733   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1734   switch (arrayexpr->ts.type)
1735     {
1736     case BT_REAL:
1737       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1738       break;
1739
1740     case BT_INTEGER:
1741       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1742                                   arrayexpr->ts.kind);
1743       break;
1744
1745     default:
1746       gcc_unreachable ();
1747     }
1748
1749   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1750   if (op == GT_EXPR)
1751     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1752   gfc_add_modify_expr (&se->pre, limit, tmp);
1753
1754   /* Initialize the scalarizer.  */
1755   gfc_init_loopinfo (&loop);
1756   gfc_add_ss_to_loop (&loop, arrayss);
1757   if (maskss)
1758     gfc_add_ss_to_loop (&loop, maskss);
1759
1760   /* Initialize the loop.  */
1761   gfc_conv_ss_startstride (&loop);
1762   gfc_conv_loop_setup (&loop);
1763
1764   gcc_assert (loop.dimen == 1);
1765
1766   /* Initialize the position to zero, following Fortran 2003.  We are free
1767      to do this because Fortran 95 allows the result of an entirely false
1768      mask to be processor dependent.  */
1769   gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
1770
1771   gfc_mark_ss_chain_used (arrayss, 1);
1772   if (maskss)
1773     gfc_mark_ss_chain_used (maskss, 1);
1774   /* Generate the loop body.  */
1775   gfc_start_scalarized_body (&loop, &body);
1776
1777   /* If we have a mask, only check this element if the mask is set.  */
1778   if (maskss)
1779     {
1780       gfc_init_se (&maskse, NULL);
1781       gfc_copy_loopinfo_to_se (&maskse, &loop);
1782       maskse.ss = maskss;
1783       gfc_conv_expr_val (&maskse, maskexpr);
1784       gfc_add_block_to_block (&body, &maskse.pre);
1785
1786       gfc_start_block (&block);
1787     }
1788   else
1789     gfc_init_block (&block);
1790
1791   /* Compare with the current limit.  */
1792   gfc_init_se (&arrayse, NULL);
1793   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1794   arrayse.ss = arrayss;
1795   gfc_conv_expr_val (&arrayse, arrayexpr);
1796   gfc_add_block_to_block (&block, &arrayse.pre);
1797
1798   /* We do the following if this is a more extreme value.  */
1799   gfc_start_block (&ifblock);
1800
1801   /* Assign the value to the limit...  */
1802   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1803
1804   /* Remember where we are.  */
1805   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1806
1807   ifbody = gfc_finish_block (&ifblock);
1808
1809   /* If it is a more extreme value or pos is still zero.  */
1810   tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
1811                   build2 (op, boolean_type_node, arrayse.expr, limit),
1812                   build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
1813   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1814   gfc_add_expr_to_block (&block, tmp);
1815
1816   if (maskss)
1817     {
1818       /* We enclose the above in if (mask) {...}.  */
1819       tmp = gfc_finish_block (&block);
1820
1821       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1822     }
1823   else
1824     tmp = gfc_finish_block (&block);
1825   gfc_add_expr_to_block (&body, tmp);
1826
1827   gfc_trans_scalarizing_loops (&loop, &body);
1828
1829   /* For a scalar mask, enclose the loop in an if statement.  */
1830   if (maskexpr && maskss == NULL)
1831     {
1832       gfc_init_se (&maskse, NULL);
1833       gfc_conv_expr_val (&maskse, maskexpr);
1834       gfc_init_block (&block);
1835       gfc_add_block_to_block (&block, &loop.pre);
1836       gfc_add_block_to_block (&block, &loop.post);
1837       tmp = gfc_finish_block (&block);
1838
1839       /* For the else part of the scalar mask, just initialize
1840          the pos variable the same way as above.  */
1841
1842       gfc_init_block (&elseblock);
1843       gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
1844       elsetmp = gfc_finish_block (&elseblock);
1845
1846       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
1847       gfc_add_expr_to_block (&block, tmp);
1848       gfc_add_block_to_block (&se->pre, &block);
1849     }
1850   else
1851     {
1852       gfc_add_block_to_block (&se->pre, &loop.pre);
1853       gfc_add_block_to_block (&se->pre, &loop.post);
1854     }
1855   gfc_cleanup_loop (&loop);
1856
1857   /* Return a value in the range 1..SIZE(array).  */
1858   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1859                      gfc_index_one_node);
1860   tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp);
1861   /* And convert to the required type.  */
1862   se->expr = convert (type, tmp);
1863 }
1864
1865 static void
1866 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1867 {
1868   tree limit;
1869   tree type;
1870   tree tmp;
1871   tree ifbody;
1872   stmtblock_t body;
1873   stmtblock_t block;
1874   gfc_loopinfo loop;
1875   gfc_actual_arglist *actual;
1876   gfc_ss *arrayss;
1877   gfc_ss *maskss;
1878   gfc_se arrayse;
1879   gfc_se maskse;
1880   gfc_expr *arrayexpr;
1881   gfc_expr *maskexpr;
1882   int n;
1883
1884   if (se->ss)
1885     {
1886       gfc_conv_intrinsic_funcall (se, expr);
1887       return;
1888     }
1889
1890   type = gfc_typenode_for_spec (&expr->ts);
1891   /* Initialize the result.  */
1892   limit = gfc_create_var (type, "limit");
1893   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1894   switch (expr->ts.type)
1895     {
1896     case BT_REAL:
1897       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1898       break;
1899
1900     case BT_INTEGER:
1901       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1902       break;
1903
1904     default:
1905       gcc_unreachable ();
1906     }
1907
1908   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1909   if (op == GT_EXPR)
1910     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
1911   gfc_add_modify_expr (&se->pre, limit, tmp);
1912
1913   /* Walk the arguments.  */
1914   actual = expr->value.function.actual;
1915   arrayexpr = actual->expr;
1916   arrayss = gfc_walk_expr (arrayexpr);
1917   gcc_assert (arrayss != gfc_ss_terminator);
1918
1919   actual = actual->next->next;
1920   gcc_assert (actual);
1921   maskexpr = actual->expr;
1922   if (maskexpr && maskexpr->rank != 0)
1923     {
1924       maskss = gfc_walk_expr (maskexpr);
1925       gcc_assert (maskss != gfc_ss_terminator);
1926     }
1927   else
1928     maskss = NULL;
1929
1930   /* Initialize the scalarizer.  */
1931   gfc_init_loopinfo (&loop);
1932   gfc_add_ss_to_loop (&loop, arrayss);
1933   if (maskss)
1934     gfc_add_ss_to_loop (&loop, maskss);
1935
1936   /* Initialize the loop.  */
1937   gfc_conv_ss_startstride (&loop);
1938   gfc_conv_loop_setup (&loop);
1939
1940   gfc_mark_ss_chain_used (arrayss, 1);
1941   if (maskss)
1942     gfc_mark_ss_chain_used (maskss, 1);
1943   /* Generate the loop body.  */
1944   gfc_start_scalarized_body (&loop, &body);
1945
1946   /* If we have a mask, only add this element if the mask is set.  */
1947   if (maskss)
1948     {
1949       gfc_init_se (&maskse, NULL);
1950       gfc_copy_loopinfo_to_se (&maskse, &loop);
1951       maskse.ss = maskss;
1952       gfc_conv_expr_val (&maskse, maskexpr);
1953       gfc_add_block_to_block (&body, &maskse.pre);
1954
1955       gfc_start_block (&block);
1956     }
1957   else
1958     gfc_init_block (&block);
1959
1960   /* Compare with the current limit.  */
1961   gfc_init_se (&arrayse, NULL);
1962   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1963   arrayse.ss = arrayss;
1964   gfc_conv_expr_val (&arrayse, arrayexpr);
1965   gfc_add_block_to_block (&block, &arrayse.pre);
1966
1967   /* Assign the value to the limit...  */
1968   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1969
1970   /* If it is a more extreme value.  */
1971   tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1972   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1973   gfc_add_expr_to_block (&block, tmp);
1974   gfc_add_block_to_block (&block, &arrayse.post);
1975
1976   tmp = gfc_finish_block (&block);
1977   if (maskss)
1978     /* We enclose the above in if (mask) {...}.  */
1979     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1980   gfc_add_expr_to_block (&body, tmp);
1981
1982   gfc_trans_scalarizing_loops (&loop, &body);
1983
1984   /* For a scalar mask, enclose the loop in an if statement.  */
1985   if (maskexpr && maskss == NULL)
1986     {
1987       gfc_init_se (&maskse, NULL);
1988       gfc_conv_expr_val (&maskse, maskexpr);
1989       gfc_init_block (&block);
1990       gfc_add_block_to_block (&block, &loop.pre);
1991       gfc_add_block_to_block (&block, &loop.post);
1992       tmp = gfc_finish_block (&block);
1993
1994       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1995       gfc_add_expr_to_block (&block, tmp);
1996       gfc_add_block_to_block (&se->pre, &block);
1997     }
1998   else
1999     {
2000       gfc_add_block_to_block (&se->pre, &loop.pre);
2001       gfc_add_block_to_block (&se->pre, &loop.post);
2002     }
2003
2004   gfc_cleanup_loop (&loop);
2005
2006   se->expr = limit;
2007 }
2008
2009 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2010 static void
2011 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2012 {
2013   tree arg;
2014   tree arg2;
2015   tree type;
2016   tree tmp;
2017
2018   arg = gfc_conv_intrinsic_function_args (se, expr);
2019   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2020   arg = TREE_VALUE (arg);
2021   type = TREE_TYPE (arg);
2022
2023   tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2024   tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
2025   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2026                      build_int_cst (type, 0));
2027   type = gfc_typenode_for_spec (&expr->ts);
2028   se->expr = convert (type, tmp);
2029 }
2030
2031 /* Generate code to perform the specified operation.  */
2032 static void
2033 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2034 {
2035   tree arg;
2036   tree arg2;
2037   tree type;
2038
2039   arg = gfc_conv_intrinsic_function_args (se, expr);
2040   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2041   arg = TREE_VALUE (arg);
2042   type = TREE_TYPE (arg);
2043
2044   se->expr = fold_build2 (op, type, arg, arg2);
2045 }
2046
2047 /* Bitwise not.  */
2048 static void
2049 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2050 {
2051   tree arg;
2052
2053   arg = gfc_conv_intrinsic_function_args (se, expr);
2054   arg = TREE_VALUE (arg);
2055
2056   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2057 }
2058
2059 /* Set or clear a single bit.  */
2060 static void
2061 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2062 {
2063   tree arg;
2064   tree arg2;
2065   tree type;
2066   tree tmp;
2067   int op;
2068
2069   arg = gfc_conv_intrinsic_function_args (se, expr);
2070   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2071   arg = TREE_VALUE (arg);
2072   type = TREE_TYPE (arg);
2073
2074   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
2075   if (set)
2076     op = BIT_IOR_EXPR;
2077   else
2078     {
2079       op = BIT_AND_EXPR;
2080       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2081     }
2082   se->expr = fold_build2 (op, type, arg, tmp);
2083 }
2084
2085 /* Extract a sequence of bits.
2086     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2087 static void
2088 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2089 {
2090   tree arg;
2091   tree arg2;
2092   tree arg3;
2093   tree type;
2094   tree tmp;
2095   tree mask;
2096
2097   arg = gfc_conv_intrinsic_function_args (se, expr);
2098   arg2 = TREE_CHAIN (arg);
2099   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
2100   arg = TREE_VALUE (arg);
2101   arg2 = TREE_VALUE (arg2);
2102   type = TREE_TYPE (arg);
2103
2104   mask = build_int_cst (NULL_TREE, -1);
2105   mask = build2 (LSHIFT_EXPR, type, mask, arg3);
2106   mask = build1 (BIT_NOT_EXPR, type, mask);
2107
2108   tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
2109
2110   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2111 }
2112
2113 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2114                         ? 0
2115                         : ((shift >= 0) ? i << shift : i >> -shift)
2116    where all shifts are logical shifts.  */
2117 static void
2118 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2119 {
2120   tree arg;
2121   tree arg2;
2122   tree type;
2123   tree utype;
2124   tree tmp;
2125   tree width;
2126   tree num_bits;
2127   tree cond;
2128   tree lshift;
2129   tree rshift;
2130
2131   arg = gfc_conv_intrinsic_function_args (se, expr);
2132   arg2 = TREE_VALUE (TREE_CHAIN (arg));
2133   arg = TREE_VALUE (arg);
2134   type = TREE_TYPE (arg);
2135   utype = gfc_unsigned_type (type);
2136
2137   width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
2138
2139   /* Left shift if positive.  */
2140   lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
2141
2142   /* Right shift if negative.
2143      We convert to an unsigned type because we want a logical shift.
2144      The standard doesn't define the case of shifting negative
2145      numbers, and we try to be compatible with other compilers, most
2146      notably g77, here.  */
2147   rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2148                                        convert (utype, arg), width));
2149
2150   tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
2151                      build_int_cst (TREE_TYPE (arg2), 0));
2152   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2153
2154   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2155      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2156      special case.  */
2157   num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type));
2158   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2159
2160   se->expr = fold_build3 (COND_EXPR, type, cond,
2161                           build_int_cst (type, 0), tmp);
2162 }
2163
2164 /* Circular shift.  AKA rotate or barrel shift.  */
2165 static void
2166 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2167 {
2168   tree arg;
2169   tree arg2;
2170   tree arg3;
2171   tree type;
2172   tree tmp;
2173   tree lrot;
2174   tree rrot;
2175   tree zero;
2176
2177   arg = gfc_conv_intrinsic_function_args (se, expr);
2178   arg2 = TREE_CHAIN (arg);
2179   arg3 = TREE_CHAIN (arg2);
2180   if (arg3)
2181     {
2182       /* Use a library function for the 3 parameter version.  */
2183       tree int4type = gfc_get_int_type (4);
2184
2185       type = TREE_TYPE (TREE_VALUE (arg));
2186       /* We convert the first argument to at least 4 bytes, and
2187          convert back afterwards.  This removes the need for library
2188          functions for all argument sizes, and function will be
2189          aligned to at least 32 bits, so there's no loss.  */
2190       if (expr->ts.kind < 4)
2191         {
2192           tmp = convert (int4type, TREE_VALUE (arg));
2193           TREE_VALUE (arg) = tmp;
2194         }
2195       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2196          need loads of library  functions.  They cannot have values >
2197          BIT_SIZE (I) so the conversion is safe.  */
2198       TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
2199       TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
2200
2201       switch (expr->ts.kind)
2202         {
2203         case 1:
2204         case 2:
2205         case 4:
2206           tmp = gfor_fndecl_math_ishftc4;
2207           break;
2208         case 8:
2209           tmp = gfor_fndecl_math_ishftc8;
2210           break;
2211         case 16:
2212           tmp = gfor_fndecl_math_ishftc16;
2213           break;
2214         default:
2215           gcc_unreachable ();
2216         }
2217       se->expr = build_function_call_expr (tmp, arg);
2218       /* Convert the result back to the original type, if we extended
2219          the first argument's width above.  */
2220       if (expr->ts.kind < 4)
2221         se->expr = convert (type, se->expr);
2222
2223       return;
2224     }
2225   arg = TREE_VALUE (arg);
2226   arg2 = TREE_VALUE (arg2);
2227   type = TREE_TYPE (arg);
2228
2229   /* Rotate left if positive.  */
2230   lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
2231
2232   /* Rotate right if negative.  */
2233   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
2234   rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
2235
2236   zero = build_int_cst (TREE_TYPE (arg2), 0);
2237   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
2238   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2239
2240   /* Do nothing if shift == 0.  */
2241   tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero);
2242   se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
2243 }
2244
2245 /* The length of a character string.  */
2246 static void
2247 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2248 {
2249   tree len;
2250   tree type;
2251   tree decl;
2252   gfc_symbol *sym;
2253   gfc_se argse;
2254   gfc_expr *arg;
2255
2256   gcc_assert (!se->ss);
2257
2258   arg = expr->value.function.actual->expr;
2259
2260   type = gfc_typenode_for_spec (&expr->ts);
2261   switch (arg->expr_type)
2262     {
2263     case EXPR_CONSTANT:
2264       len = build_int_cst (NULL_TREE, arg->value.character.length);
2265       break;
2266
2267     case EXPR_ARRAY:
2268       /* Obtain the string length from the function used by
2269          trans-array.c(gfc_trans_array_constructor).  */
2270       len = NULL_TREE;
2271       get_array_ctor_strlen (arg->value.constructor, &len);
2272       break;
2273
2274     default:
2275         if (arg->expr_type == EXPR_VARIABLE
2276             && (arg->ref == NULL || (arg->ref->next == NULL
2277                                      && arg->ref->type == REF_ARRAY)))
2278           {
2279             /* This doesn't catch all cases.
2280                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2281                and the surrounding thread.  */
2282             sym = arg->symtree->n.sym;
2283             decl = gfc_get_symbol_decl (sym);
2284             if (decl == current_function_decl && sym->attr.function
2285                 && (sym->result == sym))
2286               decl = gfc_get_fake_result_decl (sym, 0);
2287
2288             len = sym->ts.cl->backend_decl;
2289             gcc_assert (len);
2290           }
2291         else
2292           {
2293             /* Anybody stupid enough to do this deserves inefficient code.  */
2294             gfc_init_se (&argse, se);
2295             gfc_conv_expr (&argse, arg);
2296             gfc_add_block_to_block (&se->pre, &argse.pre);
2297             gfc_add_block_to_block (&se->post, &argse.post);
2298             len = argse.string_length;
2299         }
2300       break;
2301     }
2302   se->expr = convert (type, len);
2303 }
2304
2305 /* The length of a character string not including trailing blanks.  */
2306 static void
2307 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2308 {
2309   tree args;
2310   tree type;
2311
2312   args = gfc_conv_intrinsic_function_args (se, expr);
2313   type = gfc_typenode_for_spec (&expr->ts);
2314   se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
2315   se->expr = convert (type, se->expr);
2316 }
2317
2318
2319 /* Returns the starting position of a substring within a string.  */
2320
2321 static void
2322 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2323 {
2324   tree logical4_type_node = gfc_get_logical_type (4);
2325   tree args;
2326   tree back;
2327   tree type;
2328   tree tmp;
2329
2330   args = gfc_conv_intrinsic_function_args (se, expr);
2331   type = gfc_typenode_for_spec (&expr->ts);
2332   tmp = gfc_advance_chain (args, 3);
2333   if (TREE_CHAIN (tmp) == NULL_TREE)
2334     {
2335       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2336                         NULL_TREE);
2337       TREE_CHAIN (tmp) = back;
2338     }
2339   else
2340     {
2341       back = TREE_CHAIN (tmp);
2342       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2343     }
2344
2345   se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
2346   se->expr = convert (type, se->expr);
2347 }
2348
2349 /* The ascii value for a single character.  */
2350 static void
2351 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2352 {
2353   tree arg;
2354   tree type;
2355
2356   arg = gfc_conv_intrinsic_function_args (se, expr);
2357   arg = TREE_VALUE (TREE_CHAIN (arg));
2358   gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2359   arg = build1 (NOP_EXPR, pchar_type_node, arg);
2360   type = gfc_typenode_for_spec (&expr->ts);
2361
2362   se->expr = build_fold_indirect_ref (arg);
2363   se->expr = convert (type, se->expr);
2364 }
2365
2366
2367 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
2368
2369 static void
2370 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2371 {
2372   tree arg;
2373   tree tsource;
2374   tree fsource;
2375   tree mask;
2376   tree type;
2377   tree len;
2378
2379   arg = gfc_conv_intrinsic_function_args (se, expr);
2380   if (expr->ts.type != BT_CHARACTER)
2381     {
2382       tsource = TREE_VALUE (arg);
2383       arg = TREE_CHAIN (arg);
2384       fsource = TREE_VALUE (arg);
2385       mask = TREE_VALUE (TREE_CHAIN (arg));
2386     }
2387   else
2388     {
2389       /* We do the same as in the non-character case, but the argument
2390          list is different because of the string length arguments. We
2391          also have to set the string length for the result.  */
2392       len = TREE_VALUE (arg);
2393       arg = TREE_CHAIN (arg);
2394       tsource = TREE_VALUE (arg);
2395       arg = TREE_CHAIN (TREE_CHAIN (arg));
2396       fsource = TREE_VALUE (arg);
2397       mask = TREE_VALUE (TREE_CHAIN (arg));
2398
2399       se->string_length = len;
2400     }
2401   type = TREE_TYPE (tsource);
2402   se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2403 }
2404
2405
2406 static void
2407 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2408 {
2409   gfc_actual_arglist *actual;
2410   tree args;
2411   tree type;
2412   tree fndecl;
2413   gfc_se argse;
2414   gfc_ss *ss;
2415
2416   gfc_init_se (&argse, NULL);
2417   actual = expr->value.function.actual;
2418
2419   ss = gfc_walk_expr (actual->expr);
2420   gcc_assert (ss != gfc_ss_terminator);
2421   argse.want_pointer = 1;
2422   argse.data_not_needed = 1;
2423   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2424   gfc_add_block_to_block (&se->pre, &argse.pre);
2425   gfc_add_block_to_block (&se->post, &argse.post);
2426   args = gfc_chainon_list (NULL_TREE, argse.expr);
2427
2428   actual = actual->next;
2429   if (actual->expr)
2430     {
2431       gfc_init_se (&argse, NULL);
2432       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2433       gfc_add_block_to_block (&se->pre, &argse.pre);
2434       args = gfc_chainon_list (args, argse.expr);
2435       fndecl = gfor_fndecl_size1;
2436     }
2437   else
2438     fndecl = gfor_fndecl_size0;
2439
2440   se->expr = build_function_call_expr (fndecl, args);
2441   type = gfc_typenode_for_spec (&expr->ts);
2442   se->expr = convert (type, se->expr);
2443 }
2444
2445
2446 /* Intrinsic string comparison functions.  */
2447
2448   static void
2449 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2450 {
2451   tree type;
2452   tree args;
2453   tree arg2;
2454
2455   args = gfc_conv_intrinsic_function_args (se, expr);
2456   arg2 = TREE_CHAIN (TREE_CHAIN (args));
2457
2458   se->expr = gfc_build_compare_string (TREE_VALUE (args),
2459                 TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
2460                 TREE_VALUE (TREE_CHAIN (arg2)));
2461
2462   type = gfc_typenode_for_spec (&expr->ts);
2463   se->expr = fold_build2 (op, type, se->expr,
2464                      build_int_cst (TREE_TYPE (se->expr), 0));
2465 }
2466
2467 /* Generate a call to the adjustl/adjustr library function.  */
2468 static void
2469 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2470 {
2471   tree args;
2472   tree len;
2473   tree type;
2474   tree var;
2475   tree tmp;
2476
2477   args = gfc_conv_intrinsic_function_args (se, expr);
2478   len = TREE_VALUE (args);
2479
2480   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2481   var = gfc_conv_string_tmp (se, type, len);
2482   args = tree_cons (NULL_TREE, var, args);
2483
2484   tmp = build_function_call_expr (fndecl, args);
2485   gfc_add_expr_to_block (&se->pre, tmp);
2486   se->expr = var;
2487   se->string_length = len;
2488 }
2489
2490
2491 /* A helper function for gfc_conv_intrinsic_array_transfer to compute
2492    the size of tree expressions in bytes.  */
2493 static tree
2494 gfc_size_in_bytes (gfc_se *se, gfc_expr *e)
2495 {
2496   tree tmp;
2497
2498   if (e->ts.type == BT_CHARACTER)
2499     tmp = se->string_length;
2500   else
2501     {
2502       if (e->rank)
2503         {
2504           tmp = gfc_get_element_type (TREE_TYPE (se->expr));
2505           tmp = size_in_bytes (tmp);
2506         }
2507       else
2508         tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr)));
2509     }
2510
2511   return fold_convert (gfc_array_index_type, tmp);
2512 }
2513
2514
2515 /* Array transfer statement.
2516      DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2517    where:
2518      typeof<DEST> = typeof<MOLD>
2519    and:
2520      N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2521               sizeof (DEST(0) * SIZE).  */
2522
2523 static void
2524 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2525 {
2526   tree tmp;
2527   tree extent;
2528   tree source;
2529   tree source_bytes;
2530   tree dest_word_len;
2531   tree size_words;
2532   tree size_bytes;
2533   tree upper;
2534   tree lower;
2535   tree stride;
2536   tree stmt;
2537   tree args;
2538   gfc_actual_arglist *arg;
2539   gfc_se argse;
2540   gfc_ss *ss;
2541   gfc_ss_info *info;
2542   stmtblock_t block;
2543   int n;
2544
2545   gcc_assert (se->loop);
2546   info = &se->ss->data.info;
2547
2548   /* Convert SOURCE.  The output from this stage is:-
2549         source_bytes = length of the source in bytes
2550         source = pointer to the source data.  */
2551   arg = expr->value.function.actual;
2552   gfc_init_se (&argse, NULL);
2553   ss = gfc_walk_expr (arg->expr);
2554
2555   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
2556
2557   /* Obtain the pointer to source and the length of source in bytes.  */
2558   if (ss == gfc_ss_terminator)
2559     {
2560       gfc_conv_expr_reference (&argse, arg->expr);
2561       source = argse.expr;
2562
2563       /* Obtain the source word length.  */
2564       tmp = gfc_size_in_bytes (&argse, arg->expr);
2565     }
2566   else
2567     {
2568       gfc_init_se (&argse, NULL);
2569       argse.want_pointer = 0;
2570       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2571       source = gfc_conv_descriptor_data_get (argse.expr);
2572
2573       /* Repack the source if not a full variable array.  */
2574       if (!(arg->expr->expr_type == EXPR_VARIABLE
2575               && arg->expr->ref->u.ar.type == AR_FULL))
2576         {
2577           tmp = build_fold_addr_expr (argse.expr);
2578           tmp = gfc_chainon_list (NULL_TREE, tmp);
2579           source = build_function_call_expr (gfor_fndecl_in_pack, tmp);
2580           source = gfc_evaluate_now (source, &argse.pre);
2581
2582           /* Free the temporary.  */
2583           gfc_start_block (&block);
2584           tmp = convert (pvoid_type_node, source);
2585           tmp = gfc_chainon_list (NULL_TREE, tmp);
2586           tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2587           gfc_add_expr_to_block (&block, tmp);
2588           stmt = gfc_finish_block (&block);
2589
2590           /* Clean up if it was repacked.  */
2591           gfc_init_block (&block);
2592           tmp = gfc_conv_array_data (argse.expr);
2593           tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
2594           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
2595           gfc_add_expr_to_block (&block, tmp);
2596           gfc_add_block_to_block (&block, &se->post);
2597           gfc_init_block (&se->post);
2598           gfc_add_block_to_block (&se->post, &block);
2599         }
2600
2601       /* Obtain the source word length.  */
2602       tmp = gfc_size_in_bytes (&argse, arg->expr);
2603
2604       /* Obtain the size of the array in bytes.  */
2605       extent = gfc_create_var (gfc_array_index_type, NULL);
2606       for (n = 0; n < arg->expr->rank; n++)
2607         {
2608           tree idx;
2609           idx = gfc_rank_cst[n];
2610           gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2611           stride = gfc_conv_descriptor_stride (argse.expr, idx);
2612           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2613           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2614           tmp = build2 (MINUS_EXPR, gfc_array_index_type,
2615                         upper, lower);
2616           gfc_add_modify_expr (&argse.pre, extent, tmp);
2617           tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2618                         extent, gfc_index_one_node);
2619           tmp = build2 (MULT_EXPR, gfc_array_index_type,
2620                         tmp, source_bytes);
2621         }
2622     }
2623
2624   gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2625   gfc_add_block_to_block (&se->pre, &argse.pre);
2626   gfc_add_block_to_block (&se->post, &argse.post);
2627
2628   /* Now convert MOLD.  The sole output is:
2629         dest_word_len = destination word length in bytes.  */
2630   arg = arg->next;
2631
2632   gfc_init_se (&argse, NULL);
2633   ss = gfc_walk_expr (arg->expr);
2634
2635   if (ss == gfc_ss_terminator)
2636     {
2637       gfc_conv_expr_reference (&argse, arg->expr);
2638
2639       /* Obtain the source word length.  */
2640       tmp = gfc_size_in_bytes (&argse, arg->expr);
2641     }
2642   else
2643     {
2644       gfc_init_se (&argse, NULL);
2645       argse.want_pointer = 0;
2646       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
2647
2648       /* Obtain the source word length.  */
2649       tmp = gfc_size_in_bytes (&argse, arg->expr);
2650     }
2651
2652   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
2653   gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
2654
2655   /* Finally convert SIZE, if it is present.  */
2656   arg = arg->next;
2657   size_words = gfc_create_var (gfc_array_index_type, NULL);
2658
2659   if (arg->expr)
2660     {
2661       gfc_init_se (&argse, NULL);
2662       gfc_conv_expr_reference (&argse, arg->expr);
2663       tmp = convert (gfc_array_index_type,
2664                          build_fold_indirect_ref (argse.expr));
2665       gfc_add_block_to_block (&se->pre, &argse.pre);
2666       gfc_add_block_to_block (&se->post, &argse.post);
2667     }
2668   else
2669     tmp = NULL_TREE;
2670
2671   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
2672   if (tmp != NULL_TREE)
2673     {
2674       tmp = build2 (MULT_EXPR, gfc_array_index_type,
2675                     tmp, dest_word_len);
2676       tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
2677     }
2678   else
2679     tmp = source_bytes;
2680
2681   gfc_add_modify_expr (&se->pre, size_bytes, tmp);
2682   gfc_add_modify_expr (&se->pre, size_words,
2683                        build2 (CEIL_DIV_EXPR, gfc_array_index_type,
2684                                size_bytes, dest_word_len));
2685
2686   /* Evaluate the bounds of the result.  If the loop range exists, we have
2687      to check if it is too large.  If so, we modify loop->to be consistent
2688      with min(size, size(source)).  Otherwise, size is made consistent with
2689      the loop range, so that the right number of bytes is transferred.*/
2690   n = se->loop->order[0];
2691   if (se->loop->to[n] != NULL_TREE)
2692     {
2693       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2694                          se->loop->to[n], se->loop->from[n]);
2695       tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2696                     tmp, gfc_index_one_node);
2697       tmp = build2 (MIN_EXPR, gfc_array_index_type,
2698                     tmp, size_words);
2699       gfc_add_modify_expr (&se->pre, size_words, tmp);
2700       gfc_add_modify_expr (&se->pre, size_bytes,
2701                            build2 (MULT_EXPR, gfc_array_index_type,
2702                            size_words, dest_word_len));
2703       upper = build2 (PLUS_EXPR, gfc_array_index_type,
2704                       size_words, se->loop->from[n]);
2705       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2706                       upper, gfc_index_one_node);
2707     }
2708   else
2709     {
2710       upper = build2 (MINUS_EXPR, gfc_array_index_type,
2711                       size_words, gfc_index_one_node);
2712       se->loop->from[n] = gfc_index_zero_node;
2713     }
2714
2715   se->loop->to[n] = upper;
2716
2717   /* Build a destination descriptor, using the pointer, source, as the
2718      data field.  This is already allocated so set callee_alloc.  */
2719   tmp = gfc_typenode_for_spec (&expr->ts);
2720   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
2721                                info, tmp, false, true, false, false);
2722
2723   /* Use memcpy to do the transfer.  */
2724   tmp = gfc_conv_descriptor_data_get (info->descriptor);
2725   args = gfc_chainon_list (NULL_TREE, tmp);
2726   tmp = fold_convert (pvoid_type_node, source);
2727   args = gfc_chainon_list (args, source);
2728   args = gfc_chainon_list (args, size_bytes);
2729   tmp = built_in_decls[BUILT_IN_MEMCPY];
2730   tmp = build_function_call_expr (tmp, args);
2731   gfc_add_expr_to_block (&se->pre, tmp);
2732
2733   se->expr = info->descriptor;
2734   if (expr->ts.type == BT_CHARACTER)
2735     se->string_length = dest_word_len;
2736 }
2737
2738
2739 /* Scalar transfer statement.
2740    TRANSFER (source, mold) = *(typeof<mold> *)&source.  */
2741
2742 static void
2743 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2744 {
2745   gfc_actual_arglist *arg;
2746   gfc_se argse;
2747   tree type;
2748   tree ptr;
2749   gfc_ss *ss;
2750
2751   /* Get a pointer to the source.  */
2752   arg = expr->value.function.actual;
2753   ss = gfc_walk_expr (arg->expr);
2754   gfc_init_se (&argse, NULL);
2755   if (ss == gfc_ss_terminator)
2756     gfc_conv_expr_reference (&argse, arg->expr);
2757   else
2758     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2759   gfc_add_block_to_block (&se->pre, &argse.pre);
2760   gfc_add_block_to_block (&se->post, &argse.post);
2761   ptr = argse.expr;
2762
2763   arg = arg->next;
2764   type = gfc_typenode_for_spec (&expr->ts);
2765   ptr = convert (build_pointer_type (type), ptr);
2766   if (expr->ts.type == BT_CHARACTER)
2767     {
2768       gfc_init_se (&argse, NULL);
2769       gfc_conv_expr (&argse, arg->expr);
2770       gfc_add_block_to_block (&se->pre, &argse.pre);
2771       gfc_add_block_to_block (&se->post, &argse.post);
2772       se->expr = ptr;
2773       se->string_length = argse.string_length;
2774     }
2775   else
2776     {
2777       se->expr = build_fold_indirect_ref (ptr);
2778     }
2779 }
2780
2781
2782 /* Generate code for the ALLOCATED intrinsic.
2783    Generate inline code that directly check the address of the argument.  */
2784
2785 static void
2786 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2787 {
2788   gfc_actual_arglist *arg1;
2789   gfc_se arg1se;
2790   gfc_ss *ss1;
2791   tree tmp;
2792
2793   gfc_init_se (&arg1se, NULL);
2794   arg1 = expr->value.function.actual;
2795   ss1 = gfc_walk_expr (arg1->expr);
2796   arg1se.descriptor_only = 1;
2797   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2798
2799   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
2800   tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2801                 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2802   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2803 }
2804
2805
2806 /* Generate code for the ASSOCIATED intrinsic.
2807    If both POINTER and TARGET are arrays, generate a call to library function
2808    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2809    In other cases, generate inline code that directly compare the address of
2810    POINTER with the address of TARGET.  */
2811
2812 static void
2813 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2814 {
2815   gfc_actual_arglist *arg1;
2816   gfc_actual_arglist *arg2;
2817   gfc_se arg1se;
2818   gfc_se arg2se;
2819   tree tmp2;
2820   tree tmp;
2821   tree args, fndecl;
2822   tree nonzero_charlen;
2823   tree nonzero_arraylen;
2824   gfc_ss *ss1, *ss2;
2825
2826   gfc_init_se (&arg1se, NULL);
2827   gfc_init_se (&arg2se, NULL);
2828   arg1 = expr->value.function.actual;
2829   arg2 = arg1->next;
2830   ss1 = gfc_walk_expr (arg1->expr);
2831
2832   if (!arg2->expr)
2833     {
2834       /* No optional target.  */
2835       if (ss1 == gfc_ss_terminator)
2836         {
2837           /* A pointer to a scalar.  */
2838           arg1se.want_pointer = 1;
2839           gfc_conv_expr (&arg1se, arg1->expr);
2840           tmp2 = arg1se.expr;
2841         }
2842       else
2843         {
2844           /* A pointer to an array.  */
2845           arg1se.descriptor_only = 1;
2846           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2847           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
2848         }
2849       gfc_add_block_to_block (&se->pre, &arg1se.pre);
2850       gfc_add_block_to_block (&se->post, &arg1se.post);
2851       tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2852                     fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2853       se->expr = tmp;
2854     }
2855   else
2856     {
2857       /* An optional target.  */
2858       ss2 = gfc_walk_expr (arg2->expr);
2859
2860       nonzero_charlen = NULL_TREE;
2861       if (arg1->expr->ts.type == BT_CHARACTER)
2862         nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
2863                                   arg1->expr->ts.cl->backend_decl,
2864                                   integer_zero_node);
2865
2866       if (ss1 == gfc_ss_terminator)
2867         {
2868           /* A pointer to a scalar.  */
2869           gcc_assert (ss2 == gfc_ss_terminator);
2870           arg1se.want_pointer = 1;
2871           gfc_conv_expr (&arg1se, arg1->expr);
2872           arg2se.want_pointer = 1;
2873           gfc_conv_expr (&arg2se, arg2->expr);
2874           gfc_add_block_to_block (&se->pre, &arg1se.pre);
2875           gfc_add_block_to_block (&se->post, &arg1se.post);
2876           tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2877           se->expr = tmp;
2878         }
2879       else
2880         {
2881
2882           /* An array pointer of zero length is not associated if target is
2883              present.  */
2884           arg1se.descriptor_only = 1;
2885           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2886           tmp = gfc_conv_descriptor_stride (arg1se.expr,
2887                                             gfc_rank_cst[arg1->expr->rank - 1]);
2888           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
2889                                  tmp, integer_zero_node);
2890
2891           /* A pointer to an array, call library function _gfor_associated.  */
2892           gcc_assert (ss2 != gfc_ss_terminator);
2893           args = NULL_TREE;
2894           arg1se.want_pointer = 1;
2895           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2896           args = gfc_chainon_list (args, arg1se.expr);
2897
2898           arg2se.want_pointer = 1;
2899           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2900           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2901           gfc_add_block_to_block (&se->post, &arg2se.post);
2902           args = gfc_chainon_list (args, arg2se.expr);
2903           fndecl = gfor_fndecl_associated;
2904           se->expr = build_function_call_expr (fndecl, args);
2905           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2906                              se->expr, nonzero_arraylen);
2907
2908         }
2909
2910       /* If target is present zero character length pointers cannot
2911          be associated.  */
2912       if (nonzero_charlen != NULL_TREE)
2913         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
2914                            se->expr, nonzero_charlen);
2915     }
2916
2917   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2918 }
2919
2920
2921 /* Scan a string for any one of the characters in a set of characters.  */
2922
2923 static void
2924 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2925 {
2926   tree logical4_type_node = gfc_get_logical_type (4);
2927   tree args;
2928   tree back;
2929   tree type;
2930   tree tmp;
2931
2932   args = gfc_conv_intrinsic_function_args (se, expr);
2933   type = gfc_typenode_for_spec (&expr->ts);
2934   tmp = gfc_advance_chain (args, 3);
2935   if (TREE_CHAIN (tmp) == NULL_TREE)
2936     {
2937       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2938                         NULL_TREE);
2939       TREE_CHAIN (tmp) = back;
2940     }
2941   else
2942     {
2943       back = TREE_CHAIN (tmp);
2944       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2945     }
2946
2947   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
2948   se->expr = convert (type, se->expr);
2949 }
2950
2951
2952 /* Verify that a set of characters contains all the characters in a string
2953    by identifying the position of the first character in a string of
2954    characters that does not appear in a given set of characters.  */
2955
2956 static void
2957 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2958 {
2959   tree logical4_type_node = gfc_get_logical_type (4);
2960   tree args;
2961   tree back;
2962   tree type;
2963   tree tmp;
2964
2965   args = gfc_conv_intrinsic_function_args (se, expr);
2966   type = gfc_typenode_for_spec (&expr->ts);
2967   tmp = gfc_advance_chain (args, 3);
2968   if (TREE_CHAIN (tmp) == NULL_TREE)
2969     {
2970       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
2971                         NULL_TREE);
2972       TREE_CHAIN (tmp) = back;
2973     }
2974   else
2975     {
2976       back = TREE_CHAIN (tmp);
2977       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
2978     }
2979
2980   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
2981   se->expr = convert (type, se->expr);
2982 }
2983
2984 /* Prepare components and related information of a real number which is
2985    the first argument of a elemental functions to manipulate reals.  */
2986
2987 static void
2988 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2989                   real_compnt_info * rcs, int all)
2990 {
2991    tree arg;
2992    tree masktype;
2993    tree tmp;
2994    tree wbits;
2995    tree one;
2996    tree exponent, fraction;
2997    int n;
2998    gfc_expr *a1;
2999
3000    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
3001      gfc_todo_error ("Non-IEEE floating format");
3002
3003    gcc_assert (expr->expr_type == EXPR_FUNCTION);
3004
3005    arg = gfc_conv_intrinsic_function_args (se, expr);
3006    arg = TREE_VALUE (arg);
3007    rcs->type = TREE_TYPE (arg);
3008
3009    /* Force arg'type to integer by unaffected convert  */
3010    a1 = expr->value.function.actual->expr;
3011    masktype = gfc_get_int_type (a1->ts.kind);
3012    rcs->mtype = masktype;
3013    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
3014    arg = gfc_create_var (masktype, "arg");
3015    gfc_add_modify_expr(&se->pre, arg, tmp);
3016    rcs->arg = arg;
3017
3018    /* Calculate the numbers of bits of exponent, fraction and word  */
3019    n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
3020    tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
3021    rcs->fdigits = convert (masktype, tmp);
3022    wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
3023    wbits = convert (masktype, wbits);
3024    rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp);
3025
3026    /* Form masks for exponent/fraction/sign  */
3027    one = gfc_build_const (masktype, integer_one_node);
3028    rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits);
3029    rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits);
3030    rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1);
3031    rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one);
3032    /* Form bias.  */
3033    tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one);
3034    tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp);
3035    rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one);
3036
3037    if (all)
3038      {
3039        /* exponent, and fraction  */
3040        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
3041        tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
3042        exponent = gfc_create_var (masktype, "exponent");
3043        gfc_add_modify_expr(&se->pre, exponent, tmp);
3044        rcs->expn = exponent;
3045
3046        tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
3047        fraction = gfc_create_var (masktype, "fraction");
3048        gfc_add_modify_expr(&se->pre, fraction, tmp);
3049        rcs->frac = fraction;
3050      }
3051 }
3052
3053 /* Build a call to __builtin_clz.  */
3054
3055 static tree
3056 call_builtin_clz (tree result_type, tree op0)
3057 {
3058   tree fn, parms, call;
3059   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
3060
3061   if (op0_mode == TYPE_MODE (integer_type_node))
3062     fn = built_in_decls[BUILT_IN_CLZ];
3063   else if (op0_mode == TYPE_MODE (long_integer_type_node))
3064     fn = built_in_decls[BUILT_IN_CLZL];
3065   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
3066     fn = built_in_decls[BUILT_IN_CLZLL];
3067   else
3068     gcc_unreachable ();
3069
3070   parms = tree_cons (NULL, op0, NULL);
3071   call = build_function_call_expr (fn, parms);
3072
3073   return convert (result_type, call);
3074 }
3075
3076
3077 /* Generate code for SPACING (X) intrinsic function.
3078    SPACING (X) = POW (2, e-p)
3079
3080    We generate:
3081
3082     t = expn - fdigits // e - p.
3083     res = t << fdigits // Form the exponent. Fraction is zero.
3084     if (t < 0) // The result is out of range. Denormalized case.
3085       res = tiny(X)
3086  */
3087
3088 static void
3089 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3090 {
3091    tree arg;
3092    tree masktype;
3093    tree tmp, t1, cond;
3094    tree tiny, zero;
3095    tree fdigits;
3096    real_compnt_info rcs;
3097
3098    prepare_arg_info (se, expr, &rcs, 0);
3099    arg = rcs.arg;
3100    masktype = rcs.mtype;
3101    fdigits = rcs.fdigits;
3102    tiny = rcs.f1;
3103    zero = gfc_build_const (masktype, integer_zero_node);
3104    tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
3105    tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
3106    tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
3107    cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
3108    t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3109    tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
3110    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3111
3112    se->expr = tmp;
3113 }
3114
3115 /* Generate code for RRSPACING (X) intrinsic function.
3116    RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
3117
3118    So the result's exponent is p. And if X is normalized, X's fraction part
3119    is the result's fraction. If X is denormalized, to get the X's fraction we
3120    shift X's fraction part to left until the first '1' is removed.
3121
3122    We generate:
3123
3124     if (expn == 0 && frac == 0)
3125        res = 0;
3126     else
3127     {
3128        // edigits is the number of exponent bits. Add the sign bit.
3129        sedigits = edigits + 1;
3130
3131        if (expn == 0) // Denormalized case.
3132        {
3133          t1 = leadzero (frac);
3134          frac = frac << (t1 + 1); //Remove the first '1'.
3135          frac = frac >> (sedigits); //Form the fraction.
3136        }
3137
3138        //fdigits is the number of fraction bits. Form the exponent.
3139        t = bias + fdigits;
3140
3141        res = (t << fdigits) | frac;
3142     }
3143 */
3144
3145 static void
3146 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3147 {
3148    tree masktype;
3149    tree tmp, t1, t2, cond, cond2;
3150    tree one, zero;
3151    tree fdigits, fraction;
3152    real_compnt_info rcs;
3153
3154    prepare_arg_info (se, expr, &rcs, 1);
3155    masktype = rcs.mtype;
3156    fdigits = rcs.fdigits;
3157    fraction = rcs.frac;
3158    one = gfc_build_const (masktype, integer_one_node);
3159    zero = gfc_build_const (masktype, integer_zero_node);
3160    t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
3161
3162    t1 = call_builtin_clz (masktype, fraction);
3163    tmp = build2 (PLUS_EXPR, masktype, t1, one);
3164    tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
3165    tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
3166    cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
3167    fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
3168
3169    tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits);
3170    tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
3171    tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
3172
3173    cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
3174    cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
3175    tmp = build3 (COND_EXPR, masktype, cond,
3176                  build_int_cst (masktype, 0), tmp);
3177
3178    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
3179    se->expr = tmp;
3180 }
3181
3182 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3183
3184 static void
3185 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3186 {
3187   tree args;
3188
3189   args = gfc_conv_intrinsic_function_args (se, expr);
3190   args = TREE_VALUE (args);
3191   args = build_fold_addr_expr (args);
3192   args = tree_cons (NULL_TREE, args, NULL_TREE);
3193   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3194 }
3195
3196 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3197
3198 static void
3199 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3200 {
3201   gfc_actual_arglist *actual;
3202   tree args;
3203   gfc_se argse;
3204
3205   args = NULL_TREE;
3206   for (actual = expr->value.function.actual; actual; actual = actual->next)
3207     {
3208       gfc_init_se (&argse, se);
3209
3210       /* Pass a NULL pointer for an absent arg.  */
3211       if (actual->expr == NULL)
3212         argse.expr = null_pointer_node;
3213       else
3214         gfc_conv_expr_reference (&argse, actual->expr);
3215
3216       gfc_add_block_to_block (&se->pre, &argse.pre);
3217       gfc_add_block_to_block (&se->post, &argse.post);
3218       args = gfc_chainon_list (args, argse.expr);
3219     }
3220   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3221 }
3222
3223
3224 /* Generate code for TRIM (A) intrinsic function.  */
3225
3226 static void
3227 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3228 {
3229   tree gfc_int4_type_node = gfc_get_int_type (4);
3230   tree var;
3231   tree len;
3232   tree addr;
3233   tree tmp;
3234   tree arglist;
3235   tree type;
3236   tree cond;
3237
3238   arglist = NULL_TREE;
3239
3240   type = build_pointer_type (gfc_character1_type_node);
3241   var = gfc_create_var (type, "pstr");
3242   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3243   len = gfc_create_var (gfc_int4_type_node, "len");
3244
3245   tmp = gfc_conv_intrinsic_function_args (se, expr);
3246   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3247   arglist = gfc_chainon_list (arglist, addr);
3248   arglist = chainon (arglist, tmp);
3249
3250   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3251   gfc_add_expr_to_block (&se->pre, tmp);
3252
3253   /* Free the temporary afterwards, if necessary.  */
3254   cond = build2 (GT_EXPR, boolean_type_node, len,
3255                  build_int_cst (TREE_TYPE (len), 0));
3256   arglist = gfc_chainon_list (NULL_TREE, var);
3257   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3258   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3259   gfc_add_expr_to_block (&se->post, tmp);
3260
3261   se->expr = var;
3262   se->string_length = len;
3263 }
3264
3265
3266 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3267
3268 static void
3269 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3270 {
3271   tree gfc_int4_type_node = gfc_get_int_type (4);
3272   tree tmp;
3273   tree len;
3274   tree args;
3275   tree arglist;
3276   tree ncopies;
3277   tree var;
3278   tree type;
3279
3280   args = gfc_conv_intrinsic_function_args (se, expr);
3281   len = TREE_VALUE (args);
3282   tmp = gfc_advance_chain (args, 2);
3283   ncopies = TREE_VALUE (tmp);
3284   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3285   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3286   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3287
3288   arglist = NULL_TREE;
3289   arglist = gfc_chainon_list (arglist, var);
3290   arglist = chainon (arglist, args);
3291   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3292   gfc_add_expr_to_block (&se->pre, tmp);
3293
3294   se->expr = var;
3295   se->string_length = len;
3296 }
3297
3298
3299 /* Generate code for the IARGC intrinsic.  */
3300
3301 static void
3302 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3303 {
3304   tree tmp;
3305   tree fndecl;
3306   tree type;
3307
3308   /* Call the library function.  This always returns an INTEGER(4).  */
3309   fndecl = gfor_fndecl_iargc;
3310   tmp = build_function_call_expr (fndecl, NULL_TREE);
3311
3312   /* Convert it to the required type.  */
3313   type = gfc_typenode_for_spec (&expr->ts);
3314   tmp = fold_convert (type, tmp);
3315
3316   se->expr = tmp;
3317 }
3318
3319
3320 /* The loc intrinsic returns the address of its argument as
3321    gfc_index_integer_kind integer.  */
3322
3323 static void
3324 gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
3325 {
3326   tree temp_var;
3327   gfc_expr *arg_expr;
3328   gfc_ss *ss;
3329
3330   gcc_assert (!se->ss);
3331
3332   arg_expr = expr->value.function.actual->expr;
3333   ss = gfc_walk_expr (arg_expr);
3334   if (ss == gfc_ss_terminator)
3335     gfc_conv_expr_reference (se, arg_expr);
3336   else
3337     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3338   se->expr= convert (gfc_unsigned_type (long_integer_type_node),
3339                      se->expr);
3340
3341   /* Create a temporary variable for loc return value.  Without this,
3342      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3343   temp_var = gfc_create_var (gfc_unsigned_type (long_integer_type_node),
3344                              NULL);
3345   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3346   se->expr = temp_var;
3347 }
3348
3349 /* Generate code for an intrinsic function.  Some map directly to library
3350    calls, others get special handling.  In some cases the name of the function
3351    used depends on the type specifiers.  */
3352
3353 void
3354 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3355 {
3356   gfc_intrinsic_sym *isym;
3357   const char *name;
3358   int lib;
3359
3360   isym = expr->value.function.isym;
3361
3362   name = &expr->value.function.name[2];
3363
3364   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3365     {
3366       lib = gfc_is_intrinsic_libcall (expr);
3367       if (lib != 0)
3368         {
3369           if (lib == 1)
3370             se->ignore_optional = 1;
3371           gfc_conv_intrinsic_funcall (se, expr);
3372           return;
3373         }
3374     }
3375
3376   switch (expr->value.function.isym->generic_id)
3377     {
3378     case GFC_ISYM_NONE:
3379       gcc_unreachable ();
3380
3381     case GFC_ISYM_REPEAT:
3382       gfc_conv_intrinsic_repeat (se, expr);
3383       break;
3384
3385     case GFC_ISYM_TRIM:
3386       gfc_conv_intrinsic_trim (se, expr);
3387       break;
3388
3389     case GFC_ISYM_SI_KIND:
3390       gfc_conv_intrinsic_si_kind (se, expr);
3391       break;
3392
3393     case GFC_ISYM_SR_KIND:
3394       gfc_conv_intrinsic_sr_kind (se, expr);
3395       break;
3396
3397     case GFC_ISYM_EXPONENT:
3398       gfc_conv_intrinsic_exponent (se, expr);
3399       break;
3400
3401     case GFC_ISYM_SPACING:
3402       gfc_conv_intrinsic_spacing (se, expr);
3403       break;
3404
3405     case GFC_ISYM_RRSPACING:
3406       gfc_conv_intrinsic_rrspacing (se, expr);
3407       break;
3408
3409     case GFC_ISYM_SCAN:
3410       gfc_conv_intrinsic_scan (se, expr);
3411       break;
3412
3413     case GFC_ISYM_VERIFY:
3414       gfc_conv_intrinsic_verify (se, expr);
3415       break;
3416
3417     case GFC_ISYM_ALLOCATED:
3418       gfc_conv_allocated (se, expr);
3419       break;
3420
3421     case GFC_ISYM_ASSOCIATED:
3422       gfc_conv_associated(se, expr);
3423       break;
3424
3425     case GFC_ISYM_ABS:
3426       gfc_conv_intrinsic_abs (se, expr);
3427       break;
3428
3429     case GFC_ISYM_ADJUSTL:
3430       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3431       break;
3432
3433     case GFC_ISYM_ADJUSTR:
3434       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3435       break;
3436
3437     case GFC_ISYM_AIMAG:
3438       gfc_conv_intrinsic_imagpart (se, expr);
3439       break;
3440
3441     case GFC_ISYM_AINT:
3442       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
3443       break;
3444
3445     case GFC_ISYM_ALL:
3446       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3447       break;
3448
3449     case GFC_ISYM_ANINT:
3450       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
3451       break;
3452
3453     case GFC_ISYM_AND:
3454       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3455       break;
3456
3457     case GFC_ISYM_ANY:
3458       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3459       break;
3460
3461     case GFC_ISYM_BTEST:
3462       gfc_conv_intrinsic_btest (se, expr);
3463       break;
3464
3465     case GFC_ISYM_ACHAR:
3466     case GFC_ISYM_CHAR:
3467       gfc_conv_intrinsic_char (se, expr);
3468       break;
3469
3470     case GFC_ISYM_CONVERSION:
3471     case GFC_ISYM_REAL:
3472     case GFC_ISYM_LOGICAL:
3473     case GFC_ISYM_DBLE:
3474       gfc_conv_intrinsic_conversion (se, expr);
3475       break;
3476
3477       /* Integer conversions are handled separately to make sure we get the
3478          correct rounding mode.  */
3479     case GFC_ISYM_INT:
3480       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
3481       break;
3482
3483     case GFC_ISYM_NINT:
3484       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
3485       break;
3486
3487     case GFC_ISYM_CEILING:
3488       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
3489       break;
3490
3491     case GFC_ISYM_FLOOR:
3492       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
3493       break;
3494
3495     case GFC_ISYM_MOD:
3496       gfc_conv_intrinsic_mod (se, expr, 0);
3497       break;
3498
3499     case GFC_ISYM_MODULO:
3500       gfc_conv_intrinsic_mod (se, expr, 1);
3501       break;
3502
3503     case GFC_ISYM_CMPLX:
3504       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3505       break;
3506
3507     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3508       gfc_conv_intrinsic_iargc (se, expr);
3509       break;
3510
3511     case GFC_ISYM_COMPLEX:
3512       gfc_conv_intrinsic_cmplx (se, expr, 1);
3513       break;
3514
3515     case GFC_ISYM_CONJG:
3516       gfc_conv_intrinsic_conjg (se, expr);
3517       break;
3518
3519     case GFC_ISYM_COUNT:
3520       gfc_conv_intrinsic_count (se, expr);
3521       break;
3522
3523     case GFC_ISYM_CTIME:
3524       gfc_conv_intrinsic_ctime (se, expr);
3525       break;
3526
3527     case GFC_ISYM_DIM:
3528       gfc_conv_intrinsic_dim (se, expr);
3529       break;
3530
3531     case GFC_ISYM_DOT_PRODUCT:
3532       gfc_conv_intrinsic_dot_product (se, expr);
3533       break;
3534
3535     case GFC_ISYM_DPROD:
3536       gfc_conv_intrinsic_dprod (se, expr);
3537       break;
3538
3539     case GFC_ISYM_FDATE:
3540       gfc_conv_intrinsic_fdate (se, expr);
3541       break;
3542
3543     case GFC_ISYM_IAND:
3544       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3545       break;
3546
3547     case GFC_ISYM_IBCLR:
3548       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3549       break;
3550
3551     case GFC_ISYM_IBITS:
3552       gfc_conv_intrinsic_ibits (se, expr);
3553       break;
3554
3555     case GFC_ISYM_IBSET:
3556       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3557       break;
3558
3559     case GFC_ISYM_IACHAR:
3560     case GFC_ISYM_ICHAR:
3561       /* We assume ASCII character sequence.  */
3562       gfc_conv_intrinsic_ichar (se, expr);
3563       break;
3564
3565     case GFC_ISYM_IARGC:
3566       gfc_conv_intrinsic_iargc (se, expr);
3567       break;
3568
3569     case GFC_ISYM_IEOR:
3570       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3571       break;
3572
3573     case GFC_ISYM_INDEX:
3574       gfc_conv_intrinsic_index (se, expr);
3575       break;
3576
3577     case GFC_ISYM_IOR:
3578       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3579       break;
3580
3581     case GFC_ISYM_ISHFT:
3582       gfc_conv_intrinsic_ishft (se, expr);
3583       break;
3584
3585     case GFC_ISYM_ISHFTC:
3586       gfc_conv_intrinsic_ishftc (se, expr);
3587       break;
3588
3589     case GFC_ISYM_LBOUND:
3590       gfc_conv_intrinsic_bound (se, expr, 0);
3591       break;
3592
3593     case GFC_ISYM_TRANSPOSE:
3594       if (se->ss && se->ss->useflags)
3595         {
3596           gfc_conv_tmp_array_ref (se);
3597           gfc_advance_se_ss_chain (se);
3598         }
3599       else
3600         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3601       break;
3602
3603     case GFC_ISYM_LEN:
3604       gfc_conv_intrinsic_len (se, expr);
3605       break;
3606
3607     case GFC_ISYM_LEN_TRIM:
3608       gfc_conv_intrinsic_len_trim (se, expr);
3609       break;
3610
3611     case GFC_ISYM_LGE:
3612       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3613       break;
3614
3615     case GFC_ISYM_LGT:
3616       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3617       break;
3618
3619     case GFC_ISYM_LLE:
3620       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3621       break;
3622
3623     case GFC_ISYM_LLT:
3624       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3625       break;
3626
3627     case GFC_ISYM_MAX:
3628       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3629       break;
3630
3631     case GFC_ISYM_MAXLOC:
3632       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3633       break;
3634
3635     case GFC_ISYM_MAXVAL:
3636       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3637       break;
3638
3639     case GFC_ISYM_MERGE:
3640       gfc_conv_intrinsic_merge (se, expr);
3641       break;
3642
3643     case GFC_ISYM_MIN:
3644       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3645       break;
3646
3647     case GFC_ISYM_MINLOC:
3648       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3649       break;
3650
3651     case GFC_ISYM_MINVAL:
3652       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3653       break;
3654
3655     case GFC_ISYM_NOT:
3656       gfc_conv_intrinsic_not (se, expr);
3657       break;
3658
3659     case GFC_ISYM_OR:
3660       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3661       break;
3662
3663     case GFC_ISYM_PRESENT:
3664       gfc_conv_intrinsic_present (se, expr);
3665       break;
3666
3667     case GFC_ISYM_PRODUCT:
3668       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3669       break;
3670
3671     case GFC_ISYM_SIGN:
3672       gfc_conv_intrinsic_sign (se, expr);
3673       break;
3674
3675     case GFC_ISYM_SIZE:
3676       gfc_conv_intrinsic_size (se, expr);
3677       break;
3678
3679     case GFC_ISYM_SUM:
3680       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3681       break;
3682
3683     case GFC_ISYM_TRANSFER:
3684       if (se->ss)
3685         {
3686           if (se->ss->useflags)
3687             {
3688               /* Access the previously obtained result.  */
3689               gfc_conv_tmp_array_ref (se);
3690               gfc_advance_se_ss_chain (se);
3691               break;
3692             }
3693           else
3694             gfc_conv_intrinsic_array_transfer (se, expr);
3695         }
3696       else
3697         gfc_conv_intrinsic_transfer (se, expr);
3698       break;
3699
3700     case GFC_ISYM_TTYNAM:
3701       gfc_conv_intrinsic_ttynam (se, expr);
3702       break;
3703
3704     case GFC_ISYM_UBOUND:
3705       gfc_conv_intrinsic_bound (se, expr, 1);
3706       break;
3707
3708     case GFC_ISYM_XOR:
3709       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3710       break;
3711
3712     case GFC_ISYM_LOC:
3713       gfc_conv_intrinsic_loc (se, expr);
3714       break;
3715
3716     case GFC_ISYM_CHDIR:
3717     case GFC_ISYM_ETIME:
3718     case GFC_ISYM_FGET:
3719     case GFC_ISYM_FGETC:
3720     case GFC_ISYM_FNUM:
3721     case GFC_ISYM_FPUT:
3722     case GFC_ISYM_FPUTC:
3723     case GFC_ISYM_FSTAT:
3724     case GFC_ISYM_FTELL:
3725     case GFC_ISYM_GETCWD:
3726     case GFC_ISYM_GETGID:
3727     case GFC_ISYM_GETPID:
3728     case GFC_ISYM_GETUID:
3729     case GFC_ISYM_HOSTNM:
3730     case GFC_ISYM_KILL:
3731     case GFC_ISYM_IERRNO:
3732     case GFC_ISYM_IRAND:
3733     case GFC_ISYM_ISATTY:
3734     case GFC_ISYM_LINK:
3735     case GFC_ISYM_MALLOC:
3736     case GFC_ISYM_MATMUL:
3737     case GFC_ISYM_RAND:
3738     case GFC_ISYM_RENAME:
3739     case GFC_ISYM_SECOND:
3740     case GFC_ISYM_SECNDS:
3741     case GFC_ISYM_SIGNAL:
3742     case GFC_ISYM_STAT:
3743     case GFC_ISYM_SYMLNK:
3744     case GFC_ISYM_SYSTEM:
3745     case GFC_ISYM_TIME:
3746     case GFC_ISYM_TIME8:
3747     case GFC_ISYM_UMASK:
3748     case GFC_ISYM_UNLINK:
3749       gfc_conv_intrinsic_funcall (se, expr);
3750       break;
3751
3752     default:
3753       gfc_conv_intrinsic_lib_function (se, expr);
3754       break;
3755     }
3756 }
3757
3758
3759 /* This generates code to execute before entering the scalarization loop.
3760    Currently does nothing.  */
3761
3762 void
3763 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3764 {
3765   switch (ss->expr->value.function.isym->generic_id)
3766     {
3767     case GFC_ISYM_UBOUND:
3768     case GFC_ISYM_LBOUND:
3769       break;
3770
3771     default:
3772       gcc_unreachable ();
3773     }
3774 }
3775
3776
3777 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3778    inside the scalarization loop.  */
3779
3780 static gfc_ss *
3781 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3782 {
3783   gfc_ss *newss;
3784
3785   /* The two argument version returns a scalar.  */
3786   if (expr->value.function.actual->next->expr)
3787     return ss;
3788
3789   newss = gfc_get_ss ();
3790   newss->type = GFC_SS_INTRINSIC;
3791   newss->expr = expr;
3792   newss->next = ss;
3793   newss->data.info.dimen = 1;
3794
3795   return newss;
3796 }
3797
3798
3799 /* Walk an intrinsic array libcall.  */
3800
3801 static gfc_ss *
3802 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3803 {
3804   gfc_ss *newss;
3805
3806   gcc_assert (expr->rank > 0);
3807
3808   newss = gfc_get_ss ();
3809   newss->type = GFC_SS_FUNCTION;
3810   newss->expr = expr;
3811   newss->next = ss;
3812   newss->data.info.dimen = expr->rank;
3813
3814   return newss;
3815 }
3816
3817
3818 /* Returns nonzero if the specified intrinsic function call maps directly to a
3819    an external library call.  Should only be used for functions that return
3820    arrays.  */
3821
3822 int
3823 gfc_is_intrinsic_libcall (gfc_expr * expr)
3824 {
3825   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3826   gcc_assert (expr->rank > 0);
3827
3828   switch (expr->value.function.isym->generic_id)
3829     {
3830     case GFC_ISYM_ALL:
3831     case GFC_ISYM_ANY:
3832     case GFC_ISYM_COUNT:
3833     case GFC_ISYM_MATMUL:
3834     case GFC_ISYM_MAXLOC:
3835     case GFC_ISYM_MAXVAL:
3836     case GFC_ISYM_MINLOC:
3837     case GFC_ISYM_MINVAL:
3838     case GFC_ISYM_PRODUCT:
3839     case GFC_ISYM_SUM:
3840     case GFC_ISYM_SHAPE:
3841     case GFC_ISYM_SPREAD:
3842     case GFC_ISYM_TRANSPOSE:
3843       /* Ignore absent optional parameters.  */
3844       return 1;
3845
3846     case GFC_ISYM_RESHAPE:
3847     case GFC_ISYM_CSHIFT:
3848     case GFC_ISYM_EOSHIFT:
3849     case GFC_ISYM_PACK:
3850     case GFC_ISYM_UNPACK:
3851       /* Pass absent optional parameters.  */
3852       return 2;
3853
3854     default:
3855       return 0;
3856     }
3857 }
3858
3859 /* Walk an intrinsic function.  */
3860 gfc_ss *
3861 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3862                              gfc_intrinsic_sym * isym)
3863 {
3864   gcc_assert (isym);
3865
3866   if (isym->elemental)
3867     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3868
3869   if (expr->rank == 0)
3870     return ss;
3871
3872   if (gfc_is_intrinsic_libcall (expr))
3873     return gfc_walk_intrinsic_libfunc (ss, expr);
3874
3875   /* Special cases.  */
3876   switch (isym->generic_id)
3877     {
3878     case GFC_ISYM_LBOUND:
3879     case GFC_ISYM_UBOUND:
3880       return gfc_walk_intrinsic_bound (ss, expr);
3881
3882     case GFC_ISYM_TRANSFER:
3883       return gfc_walk_intrinsic_libfunc (ss, expr);
3884
3885     default:
3886       /* This probably meant someone forgot to add an intrinsic to the above
3887          list(s) when they implemented it, or something's gone horribly wrong.
3888        */
3889       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3890                       expr->value.function.name);
3891     }
3892 }
3893
3894 #include "gt-fortran-trans-intrinsic.h"