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