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