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