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 (type, -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           tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3146                          null_pointer_node);
3147           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3148         }
3149       else
3150         {
3151
3152           /* An array pointer of zero length is not associated if target is
3153              present.  */
3154           arg1se.descriptor_only = 1;
3155           gfc_conv_expr_lhs (&arg1se, arg1->expr);
3156           tmp = gfc_conv_descriptor_stride (arg1se.expr,
3157                                             gfc_rank_cst[arg1->expr->rank - 1]);
3158           nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3159                                  tmp, integer_zero_node);
3160
3161           /* A pointer to an array, call library function _gfor_associated.  */
3162           gcc_assert (ss2 != gfc_ss_terminator);
3163           args = NULL_TREE;
3164           arg1se.want_pointer = 1;
3165           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3166           args = gfc_chainon_list (args, arg1se.expr);
3167
3168           arg2se.want_pointer = 1;
3169           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3170           gfc_add_block_to_block (&se->pre, &arg2se.pre);
3171           gfc_add_block_to_block (&se->post, &arg2se.post);
3172           args = gfc_chainon_list (args, arg2se.expr);
3173           fndecl = gfor_fndecl_associated;
3174           se->expr = build_function_call_expr (fndecl, args);
3175           se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3176                              se->expr, nonzero_arraylen);
3177
3178         }
3179
3180       /* If target is present zero character length pointers cannot
3181          be associated.  */
3182       if (nonzero_charlen != NULL_TREE)
3183         se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3184                            se->expr, nonzero_charlen);
3185     }
3186
3187   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3188 }
3189
3190
3191 /* Scan a string for any one of the characters in a set of characters.  */
3192
3193 static void
3194 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3195 {
3196   tree logical4_type_node = gfc_get_logical_type (4);
3197   tree args;
3198   tree back;
3199   tree type;
3200   tree tmp;
3201
3202   args = gfc_conv_intrinsic_function_args (se, expr);
3203   type = gfc_typenode_for_spec (&expr->ts);
3204   tmp = gfc_advance_chain (args, 3);
3205   if (TREE_CHAIN (tmp) == NULL_TREE)
3206     {
3207       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3208                         NULL_TREE);
3209       TREE_CHAIN (tmp) = back;
3210     }
3211   else
3212     {
3213       back = TREE_CHAIN (tmp);
3214       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3215     }
3216
3217   se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
3218   se->expr = convert (type, se->expr);
3219 }
3220
3221
3222 /* Verify that a set of characters contains all the characters in a string
3223    by identifying the position of the first character in a string of
3224    characters that does not appear in a given set of characters.  */
3225
3226 static void
3227 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3228 {
3229   tree logical4_type_node = gfc_get_logical_type (4);
3230   tree args;
3231   tree back;
3232   tree type;
3233   tree tmp;
3234
3235   args = gfc_conv_intrinsic_function_args (se, expr);
3236   type = gfc_typenode_for_spec (&expr->ts);
3237   tmp = gfc_advance_chain (args, 3);
3238   if (TREE_CHAIN (tmp) == NULL_TREE)
3239     {
3240       back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
3241                         NULL_TREE);
3242       TREE_CHAIN (tmp) = back;
3243     }
3244   else
3245     {
3246       back = TREE_CHAIN (tmp);
3247       TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
3248     }
3249
3250   se->expr = build_function_call_expr (gfor_fndecl_string_verify, args);
3251   se->expr = convert (type, se->expr);
3252 }
3253
3254
3255 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
3256
3257 static void
3258 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3259 {
3260   tree args;
3261
3262   args = gfc_conv_intrinsic_function_args (se, expr);
3263   args = TREE_VALUE (args);
3264   args = build_fold_addr_expr (args);
3265   args = tree_cons (NULL_TREE, args, NULL_TREE);
3266   se->expr = build_function_call_expr (gfor_fndecl_si_kind, args);
3267 }
3268
3269 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
3270
3271 static void
3272 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3273 {
3274   gfc_actual_arglist *actual;
3275   tree args;
3276   gfc_se argse;
3277
3278   args = NULL_TREE;
3279   for (actual = expr->value.function.actual; actual; actual = actual->next)
3280     {
3281       gfc_init_se (&argse, se);
3282
3283       /* Pass a NULL pointer for an absent arg.  */
3284       if (actual->expr == NULL)
3285         argse.expr = null_pointer_node;
3286       else
3287         gfc_conv_expr_reference (&argse, actual->expr);
3288
3289       gfc_add_block_to_block (&se->pre, &argse.pre);
3290       gfc_add_block_to_block (&se->post, &argse.post);
3291       args = gfc_chainon_list (args, argse.expr);
3292     }
3293   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3294 }
3295
3296
3297 /* Generate code for TRIM (A) intrinsic function.  */
3298
3299 static void
3300 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3301 {
3302   tree gfc_int4_type_node = gfc_get_int_type (4);
3303   tree var;
3304   tree len;
3305   tree addr;
3306   tree tmp;
3307   tree arglist;
3308   tree type;
3309   tree cond;
3310
3311   arglist = NULL_TREE;
3312
3313   type = build_pointer_type (gfc_character1_type_node);
3314   var = gfc_create_var (type, "pstr");
3315   addr = gfc_build_addr_expr (ppvoid_type_node, var);
3316   len = gfc_create_var (gfc_int4_type_node, "len");
3317
3318   tmp = gfc_conv_intrinsic_function_args (se, expr);
3319   arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
3320   arglist = gfc_chainon_list (arglist, addr);
3321   arglist = chainon (arglist, tmp);
3322
3323   tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
3324   gfc_add_expr_to_block (&se->pre, tmp);
3325
3326   /* Free the temporary afterwards, if necessary.  */
3327   cond = build2 (GT_EXPR, boolean_type_node, len,
3328                  build_int_cst (TREE_TYPE (len), 0));
3329   arglist = gfc_chainon_list (NULL_TREE, var);
3330   tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist);
3331   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3332   gfc_add_expr_to_block (&se->post, tmp);
3333
3334   se->expr = var;
3335   se->string_length = len;
3336 }
3337
3338
3339 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
3340
3341 static void
3342 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3343 {
3344   tree gfc_int4_type_node = gfc_get_int_type (4);
3345   tree tmp;
3346   tree len;
3347   tree args;
3348   tree arglist;
3349   tree ncopies;
3350   tree var;
3351   tree type;
3352
3353   args = gfc_conv_intrinsic_function_args (se, expr);
3354   len = TREE_VALUE (args);
3355   tmp = gfc_advance_chain (args, 2);
3356   ncopies = TREE_VALUE (tmp);
3357   len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
3358   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3359   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
3360
3361   arglist = NULL_TREE;
3362   arglist = gfc_chainon_list (arglist, var);
3363   arglist = chainon (arglist, args);
3364   tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist);
3365   gfc_add_expr_to_block (&se->pre, tmp);
3366
3367   se->expr = var;
3368   se->string_length = len;
3369 }
3370
3371
3372 /* Generate code for the IARGC intrinsic.  */
3373
3374 static void
3375 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3376 {
3377   tree tmp;
3378   tree fndecl;
3379   tree type;
3380
3381   /* Call the library function.  This always returns an INTEGER(4).  */
3382   fndecl = gfor_fndecl_iargc;
3383   tmp = build_function_call_expr (fndecl, NULL_TREE);
3384
3385   /* Convert it to the required type.  */
3386   type = gfc_typenode_for_spec (&expr->ts);
3387   tmp = fold_convert (type, tmp);
3388
3389   se->expr = tmp;
3390 }
3391
3392
3393 /* The loc intrinsic returns the address of its argument as
3394    gfc_index_integer_kind integer.  */
3395
3396 static void
3397 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3398 {
3399   tree temp_var;
3400   gfc_expr *arg_expr;
3401   gfc_ss *ss;
3402
3403   gcc_assert (!se->ss);
3404
3405   arg_expr = expr->value.function.actual->expr;
3406   ss = gfc_walk_expr (arg_expr);
3407   if (ss == gfc_ss_terminator)
3408     gfc_conv_expr_reference (se, arg_expr);
3409   else
3410     gfc_conv_array_parameter (se, arg_expr, ss, 1);
3411   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3412
3413   /* Create a temporary variable for loc return value.  Without this,
3414      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
3415   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3416   gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3417   se->expr = temp_var;
3418 }
3419
3420 /* Generate code for an intrinsic function.  Some map directly to library
3421    calls, others get special handling.  In some cases the name of the function
3422    used depends on the type specifiers.  */
3423
3424 void
3425 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3426 {
3427   gfc_intrinsic_sym *isym;
3428   const char *name;
3429   int lib;
3430
3431   isym = expr->value.function.isym;
3432
3433   name = &expr->value.function.name[2];
3434
3435   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3436     {
3437       lib = gfc_is_intrinsic_libcall (expr);
3438       if (lib != 0)
3439         {
3440           if (lib == 1)
3441             se->ignore_optional = 1;
3442           gfc_conv_intrinsic_funcall (se, expr);
3443           return;
3444         }
3445     }
3446
3447   switch (expr->value.function.isym->generic_id)
3448     {
3449     case GFC_ISYM_NONE:
3450       gcc_unreachable ();
3451
3452     case GFC_ISYM_REPEAT:
3453       gfc_conv_intrinsic_repeat (se, expr);
3454       break;
3455
3456     case GFC_ISYM_TRIM:
3457       gfc_conv_intrinsic_trim (se, expr);
3458       break;
3459
3460     case GFC_ISYM_SI_KIND:
3461       gfc_conv_intrinsic_si_kind (se, expr);
3462       break;
3463
3464     case GFC_ISYM_SR_KIND:
3465       gfc_conv_intrinsic_sr_kind (se, expr);
3466       break;
3467
3468     case GFC_ISYM_EXPONENT:
3469       gfc_conv_intrinsic_exponent (se, expr);
3470       break;
3471
3472     case GFC_ISYM_SCAN:
3473       gfc_conv_intrinsic_scan (se, expr);
3474       break;
3475
3476     case GFC_ISYM_VERIFY:
3477       gfc_conv_intrinsic_verify (se, expr);
3478       break;
3479
3480     case GFC_ISYM_ALLOCATED:
3481       gfc_conv_allocated (se, expr);
3482       break;
3483
3484     case GFC_ISYM_ASSOCIATED:
3485       gfc_conv_associated(se, expr);
3486       break;
3487
3488     case GFC_ISYM_ABS:
3489       gfc_conv_intrinsic_abs (se, expr);
3490       break;
3491
3492     case GFC_ISYM_ADJUSTL:
3493       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3494       break;
3495
3496     case GFC_ISYM_ADJUSTR:
3497       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3498       break;
3499
3500     case GFC_ISYM_AIMAG:
3501       gfc_conv_intrinsic_imagpart (se, expr);
3502       break;
3503
3504     case GFC_ISYM_AINT:
3505       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3506       break;
3507
3508     case GFC_ISYM_ALL:
3509       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3510       break;
3511
3512     case GFC_ISYM_ANINT:
3513       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3514       break;
3515
3516     case GFC_ISYM_AND:
3517       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3518       break;
3519
3520     case GFC_ISYM_ANY:
3521       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3522       break;
3523
3524     case GFC_ISYM_BTEST:
3525       gfc_conv_intrinsic_btest (se, expr);
3526       break;
3527
3528     case GFC_ISYM_ACHAR:
3529     case GFC_ISYM_CHAR:
3530       gfc_conv_intrinsic_char (se, expr);
3531       break;
3532
3533     case GFC_ISYM_CONVERSION:
3534     case GFC_ISYM_REAL:
3535     case GFC_ISYM_LOGICAL:
3536     case GFC_ISYM_DBLE:
3537       gfc_conv_intrinsic_conversion (se, expr);
3538       break;
3539
3540       /* Integer conversions are handled separately to make sure we get the
3541          correct rounding mode.  */
3542     case GFC_ISYM_INT:
3543     case GFC_ISYM_INT2:
3544     case GFC_ISYM_INT8:
3545     case GFC_ISYM_LONG:
3546       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3547       break;
3548
3549     case GFC_ISYM_NINT:
3550       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3551       break;
3552
3553     case GFC_ISYM_CEILING:
3554       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3555       break;
3556
3557     case GFC_ISYM_FLOOR:
3558       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3559       break;
3560
3561     case GFC_ISYM_MOD:
3562       gfc_conv_intrinsic_mod (se, expr, 0);
3563       break;
3564
3565     case GFC_ISYM_MODULO:
3566       gfc_conv_intrinsic_mod (se, expr, 1);
3567       break;
3568
3569     case GFC_ISYM_CMPLX:
3570       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3571       break;
3572
3573     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3574       gfc_conv_intrinsic_iargc (se, expr);
3575       break;
3576
3577     case GFC_ISYM_COMPLEX:
3578       gfc_conv_intrinsic_cmplx (se, expr, 1);
3579       break;
3580
3581     case GFC_ISYM_CONJG:
3582       gfc_conv_intrinsic_conjg (se, expr);
3583       break;
3584
3585     case GFC_ISYM_COUNT:
3586       gfc_conv_intrinsic_count (se, expr);
3587       break;
3588
3589     case GFC_ISYM_CTIME:
3590       gfc_conv_intrinsic_ctime (se, expr);
3591       break;
3592
3593     case GFC_ISYM_DIM:
3594       gfc_conv_intrinsic_dim (se, expr);
3595       break;
3596
3597     case GFC_ISYM_DOT_PRODUCT:
3598       gfc_conv_intrinsic_dot_product (se, expr);
3599       break;
3600
3601     case GFC_ISYM_DPROD:
3602       gfc_conv_intrinsic_dprod (se, expr);
3603       break;
3604
3605     case GFC_ISYM_FDATE:
3606       gfc_conv_intrinsic_fdate (se, expr);
3607       break;
3608
3609     case GFC_ISYM_IAND:
3610       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3611       break;
3612
3613     case GFC_ISYM_IBCLR:
3614       gfc_conv_intrinsic_singlebitop (se, expr, 0);
3615       break;
3616
3617     case GFC_ISYM_IBITS:
3618       gfc_conv_intrinsic_ibits (se, expr);
3619       break;
3620
3621     case GFC_ISYM_IBSET:
3622       gfc_conv_intrinsic_singlebitop (se, expr, 1);
3623       break;
3624
3625     case GFC_ISYM_IACHAR:
3626     case GFC_ISYM_ICHAR:
3627       /* We assume ASCII character sequence.  */
3628       gfc_conv_intrinsic_ichar (se, expr);
3629       break;
3630
3631     case GFC_ISYM_IARGC:
3632       gfc_conv_intrinsic_iargc (se, expr);
3633       break;
3634
3635     case GFC_ISYM_IEOR:
3636       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3637       break;
3638
3639     case GFC_ISYM_INDEX:
3640       gfc_conv_intrinsic_index (se, expr);
3641       break;
3642
3643     case GFC_ISYM_IOR:
3644       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3645       break;
3646
3647     case GFC_ISYM_LSHIFT:
3648       gfc_conv_intrinsic_rlshift (se, expr, 0);
3649       break;
3650
3651     case GFC_ISYM_RSHIFT:
3652       gfc_conv_intrinsic_rlshift (se, expr, 1);
3653       break;
3654
3655     case GFC_ISYM_ISHFT:
3656       gfc_conv_intrinsic_ishft (se, expr);
3657       break;
3658
3659     case GFC_ISYM_ISHFTC:
3660       gfc_conv_intrinsic_ishftc (se, expr);
3661       break;
3662
3663     case GFC_ISYM_LBOUND:
3664       gfc_conv_intrinsic_bound (se, expr, 0);
3665       break;
3666
3667     case GFC_ISYM_TRANSPOSE:
3668       if (se->ss && se->ss->useflags)
3669         {
3670           gfc_conv_tmp_array_ref (se);
3671           gfc_advance_se_ss_chain (se);
3672         }
3673       else
3674         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3675       break;
3676
3677     case GFC_ISYM_LEN:
3678       gfc_conv_intrinsic_len (se, expr);
3679       break;
3680
3681     case GFC_ISYM_LEN_TRIM:
3682       gfc_conv_intrinsic_len_trim (se, expr);
3683       break;
3684
3685     case GFC_ISYM_LGE:
3686       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3687       break;
3688
3689     case GFC_ISYM_LGT:
3690       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3691       break;
3692
3693     case GFC_ISYM_LLE:
3694       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3695       break;
3696
3697     case GFC_ISYM_LLT:
3698       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3699       break;
3700
3701     case GFC_ISYM_MAX:
3702       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3703       break;
3704
3705     case GFC_ISYM_MAXLOC:
3706       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
3707       break;
3708
3709     case GFC_ISYM_MAXVAL:
3710       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
3711       break;
3712
3713     case GFC_ISYM_MERGE:
3714       gfc_conv_intrinsic_merge (se, expr);
3715       break;
3716
3717     case GFC_ISYM_MIN:
3718       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
3719       break;
3720
3721     case GFC_ISYM_MINLOC:
3722       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
3723       break;
3724
3725     case GFC_ISYM_MINVAL:
3726       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
3727       break;
3728
3729     case GFC_ISYM_NOT:
3730       gfc_conv_intrinsic_not (se, expr);
3731       break;
3732
3733     case GFC_ISYM_OR:
3734       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3735       break;
3736
3737     case GFC_ISYM_PRESENT:
3738       gfc_conv_intrinsic_present (se, expr);
3739       break;
3740
3741     case GFC_ISYM_PRODUCT:
3742       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
3743       break;
3744
3745     case GFC_ISYM_SIGN:
3746       gfc_conv_intrinsic_sign (se, expr);
3747       break;
3748
3749     case GFC_ISYM_SIZE:
3750       gfc_conv_intrinsic_size (se, expr);
3751       break;
3752
3753     case GFC_ISYM_SUM:
3754       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
3755       break;
3756
3757     case GFC_ISYM_TRANSFER:
3758       if (se->ss)
3759         {
3760           if (se->ss->useflags)
3761             {
3762               /* Access the previously obtained result.  */
3763               gfc_conv_tmp_array_ref (se);
3764               gfc_advance_se_ss_chain (se);
3765               break;
3766             }
3767           else
3768             gfc_conv_intrinsic_array_transfer (se, expr);
3769         }
3770       else
3771         gfc_conv_intrinsic_transfer (se, expr);
3772       break;
3773
3774     case GFC_ISYM_TTYNAM:
3775       gfc_conv_intrinsic_ttynam (se, expr);
3776       break;
3777
3778     case GFC_ISYM_UBOUND:
3779       gfc_conv_intrinsic_bound (se, expr, 1);
3780       break;
3781
3782     case GFC_ISYM_XOR:
3783       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3784       break;
3785
3786     case GFC_ISYM_LOC:
3787       gfc_conv_intrinsic_loc (se, expr);
3788       break;
3789
3790     case GFC_ISYM_ACCESS:
3791     case GFC_ISYM_CHDIR:
3792     case GFC_ISYM_CHMOD:
3793     case GFC_ISYM_ETIME:
3794     case GFC_ISYM_FGET:
3795     case GFC_ISYM_FGETC:
3796     case GFC_ISYM_FNUM:
3797     case GFC_ISYM_FPUT:
3798     case GFC_ISYM_FPUTC:
3799     case GFC_ISYM_FSTAT:
3800     case GFC_ISYM_FTELL:
3801     case GFC_ISYM_GETCWD:
3802     case GFC_ISYM_GETGID:
3803     case GFC_ISYM_GETPID:
3804     case GFC_ISYM_GETUID:
3805     case GFC_ISYM_HOSTNM:
3806     case GFC_ISYM_KILL:
3807     case GFC_ISYM_IERRNO:
3808     case GFC_ISYM_IRAND:
3809     case GFC_ISYM_ISATTY:
3810     case GFC_ISYM_LINK:
3811     case GFC_ISYM_LSTAT:
3812     case GFC_ISYM_MALLOC:
3813     case GFC_ISYM_MATMUL:
3814     case GFC_ISYM_MCLOCK:
3815     case GFC_ISYM_MCLOCK8:
3816     case GFC_ISYM_RAND:
3817     case GFC_ISYM_RENAME:
3818     case GFC_ISYM_SECOND:
3819     case GFC_ISYM_SECNDS:
3820     case GFC_ISYM_SIGNAL:
3821     case GFC_ISYM_STAT:
3822     case GFC_ISYM_SYMLNK:
3823     case GFC_ISYM_SYSTEM:
3824     case GFC_ISYM_TIME:
3825     case GFC_ISYM_TIME8:
3826     case GFC_ISYM_UMASK:
3827     case GFC_ISYM_UNLINK:
3828       gfc_conv_intrinsic_funcall (se, expr);
3829       break;
3830
3831     default:
3832       gfc_conv_intrinsic_lib_function (se, expr);
3833       break;
3834     }
3835 }
3836
3837
3838 /* This generates code to execute before entering the scalarization loop.
3839    Currently does nothing.  */
3840
3841 void
3842 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3843 {
3844   switch (ss->expr->value.function.isym->generic_id)
3845     {
3846     case GFC_ISYM_UBOUND:
3847     case GFC_ISYM_LBOUND:
3848       break;
3849
3850     default:
3851       gcc_unreachable ();
3852     }
3853 }
3854
3855
3856 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3857    inside the scalarization loop.  */
3858
3859 static gfc_ss *
3860 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3861 {
3862   gfc_ss *newss;
3863
3864   /* The two argument version returns a scalar.  */
3865   if (expr->value.function.actual->next->expr)
3866     return ss;
3867
3868   newss = gfc_get_ss ();
3869   newss->type = GFC_SS_INTRINSIC;
3870   newss->expr = expr;
3871   newss->next = ss;
3872   newss->data.info.dimen = 1;
3873
3874   return newss;
3875 }
3876
3877
3878 /* Walk an intrinsic array libcall.  */
3879
3880 static gfc_ss *
3881 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3882 {
3883   gfc_ss *newss;
3884
3885   gcc_assert (expr->rank > 0);
3886
3887   newss = gfc_get_ss ();
3888   newss->type = GFC_SS_FUNCTION;
3889   newss->expr = expr;
3890   newss->next = ss;
3891   newss->data.info.dimen = expr->rank;
3892
3893   return newss;
3894 }
3895
3896
3897 /* Returns nonzero if the specified intrinsic function call maps directly to a
3898    an external library call.  Should only be used for functions that return
3899    arrays.  */
3900
3901 int
3902 gfc_is_intrinsic_libcall (gfc_expr * expr)
3903 {
3904   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3905   gcc_assert (expr->rank > 0);
3906
3907   switch (expr->value.function.isym->generic_id)
3908     {
3909     case GFC_ISYM_ALL:
3910     case GFC_ISYM_ANY:
3911     case GFC_ISYM_COUNT:
3912     case GFC_ISYM_MATMUL:
3913     case GFC_ISYM_MAXLOC:
3914     case GFC_ISYM_MAXVAL:
3915     case GFC_ISYM_MINLOC:
3916     case GFC_ISYM_MINVAL:
3917     case GFC_ISYM_PRODUCT:
3918     case GFC_ISYM_SUM:
3919     case GFC_ISYM_SHAPE:
3920     case GFC_ISYM_SPREAD:
3921     case GFC_ISYM_TRANSPOSE:
3922       /* Ignore absent optional parameters.  */
3923       return 1;
3924
3925     case GFC_ISYM_RESHAPE:
3926     case GFC_ISYM_CSHIFT:
3927     case GFC_ISYM_EOSHIFT:
3928     case GFC_ISYM_PACK:
3929     case GFC_ISYM_UNPACK:
3930       /* Pass absent optional parameters.  */
3931       return 2;
3932
3933     default:
3934       return 0;
3935     }
3936 }
3937
3938 /* Walk an intrinsic function.  */
3939 gfc_ss *
3940 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3941                              gfc_intrinsic_sym * isym)
3942 {
3943   gcc_assert (isym);
3944
3945   if (isym->elemental)
3946     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
3947
3948   if (expr->rank == 0)
3949     return ss;
3950
3951   if (gfc_is_intrinsic_libcall (expr))
3952     return gfc_walk_intrinsic_libfunc (ss, expr);
3953
3954   /* Special cases.  */
3955   switch (isym->generic_id)
3956     {
3957     case GFC_ISYM_LBOUND:
3958     case GFC_ISYM_UBOUND:
3959       return gfc_walk_intrinsic_bound (ss, expr);
3960
3961     case GFC_ISYM_TRANSFER:
3962       return gfc_walk_intrinsic_libfunc (ss, expr);
3963
3964     default:
3965       /* This probably meant someone forgot to add an intrinsic to the above
3966          list(s) when they implemented it, or something's gone horribly wrong.
3967        */
3968       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3969                       expr->value.function.name);
3970     }
3971 }
3972
3973 #include "gt-fortran-trans-intrinsic.h"