gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004 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, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, 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 <stdio.h>
  30 #include <string.h>
  31 #include "ggc.h"
  32 #include "toplev.h"
  33 #include "real.h"
  34 #include "tree-gimple.h"
  35 #include "flags.h"
  36 #include <gmp.h>
  37 #include <assert.h>
  38 #include "gfortran.h"
  39 #include "intrinsic.h"
  40 #include "trans.h"
  41 #include "trans-const.h"
  42 #include "trans-types.h"
  43 #include "trans-array.h"
  44 #include "defaults.h"
  45 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  46 #include "trans-stmt.h"
  47
  48 /* This maps fortran intrinsic math functions to external library or GCC
  49    builtin functions.  */
  50 typedef struct gfc_intrinsic_map_t      GTY(())
  51 {
  52   /* The explicit enum is required to work around inadequacies in the
  53      garbage collection/gengtype parsing mechanism.  */
  54   enum gfc_generic_isym_id id;
  55
  56   /* Enum value from the "language-independent", aka C-centric, part
  57      of gcc, or END_BUILTINS of no such value set.  */
  58   /* ??? There are now complex variants in builtins.def, though we
  59      don't currently do anything with them.  */
  60   enum built_in_function code4;
  61   enum built_in_function code8;
  62
  63   /* True if the naming pattern is to prepend "c" for complex and
  64      append "f" for kind=4.  False if the naming pattern is to
  65      prepend "_gfortran_" and append "[rc][48]".  */
  66   bool libm_name;
  67
  68   /* True if a complex version of the function exists.  */
  69   bool complex_available;
  70
  71   /* True if the function should be marked const.  */
  72   bool is_constant;
  73
  74   /* The base library name of this function.  */
  75   const char *name;
  76
  77   /* Cache decls created for the various operand types.  */
  78   tree real4_decl;
  79   tree real8_decl;
  80   tree complex4_decl;
  81   tree complex8_decl;
  82 }
  83 gfc_intrinsic_map_t;
  84
  85 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  86    defines complex variants of all of the entries in mathbuiltins.def
  87    except for atan2.  */
  88 #define DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \
  89   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
  90     NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  91
  92 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  93   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
  94     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
  95
  96 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
  97   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
  98     NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
  99
 100 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 101 {
 102   /* Functions built into gcc itself.  */
 103 #include "mathbuiltins.def"
 104
 105   /* Functions in libm.  */
 106   /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
 107      pattern for other mathbuiltins.def entries.  At present we have no
 108      optimizations for this in the common sources.  */
 109   LIBM_FUNCTION (SCALE, "scalbn", false),
 110
 111   /* Functions in libgfortran.  */
 112   LIBF_FUNCTION (FRACTION, "fraction", false),
 113   LIBF_FUNCTION (NEAREST, "nearest", false),
 114   LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
 115
 116   /* End the list.  */
 117   LIBF_FUNCTION (NONE, NULL, false)
 118 };
 119 #undef DEFINE_MATH_BUILTIN
 120 #undef LIBM_FUNCTION
 121 #undef LIBF_FUNCTION
 122
 123 /* Structure for storing components of a floating number to be used by
 124    elemental functions to manipulate reals.  */
 125 typedef struct
 126 {
 127   tree arg;     /* Variable tree to view convert to integer.   */
 128   tree expn;    /* Variable tree to save exponent.  */
 129   tree frac;    /* Variable tree to save fraction.  */
 130   tree smask;   /* Constant tree of sign's mask.  */
 131   tree emask;   /* Constant tree of exponent's mask.  */
 132   tree fmask;   /* Constant tree of fraction's mask.  */
 133   tree edigits; /* Constant tree of bit numbers of exponent.  */
 134   tree fdigits; /* Constant tree of bit numbers of fraction.  */
 135   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 136   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 137   tree type;    /* Type tree of arg1.  */
 138   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 139 }
 140 real_compnt_info;
 141
 142
 143 /* Evaluate the arguments to an intrinsic function.  */
 144
 145 static tree
 146 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
 147 {
 148   gfc_actual_arglist *actual;
 149   tree args;
 150   gfc_se argse;
 151
 152   args = NULL_TREE;
 153   for (actual = expr->value.function.actual; actual; actual = actual->next)
 154     {
 155       /* Skip ommitted optional arguments.  */
 156       if (!actual->expr)
 157         continue;
 158
 159       /* Evaluate the parameter.  This will substitute scalarized
 160          references automatically. */
 161       gfc_init_se (&argse, se);
 162
 163       if (actual->expr->ts.type == BT_CHARACTER)
 164         {
 165           gfc_conv_expr (&argse, actual->expr);
 166           gfc_conv_string_parameter (&argse);
 167           args = gfc_chainon_list (args, argse.string_length);
 168         }
 169       else
 170         gfc_conv_expr_val (&argse, actual->expr);
 171
 172       gfc_add_block_to_block (&se->pre, &argse.pre);
 173       gfc_add_block_to_block (&se->post, &argse.post);
 174       args = gfc_chainon_list (args, argse.expr);
 175     }
 176   return args;
 177 }
 178
 179
 180 /* Conversions between different types are output by the frontend as
 181    intrinsic functions.  We implement these directly with inline code.  */
 182
 183 static void
 184 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 185 {
 186   tree type;
 187   tree arg;
 188
 189   /* Evaluate the argument.  */
 190   type = gfc_typenode_for_spec (&expr->ts);
 191   assert (expr->value.function.actual->expr);
 192   arg = gfc_conv_intrinsic_function_args (se, expr);
 193   arg = TREE_VALUE (arg);
 194
 195   /* Conversion from complex to non-complex involves taking the real
 196      component of the value.  */
 197   if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 198       && expr->ts.type != BT_COMPLEX)
 199     {
 200       tree artype;
 201
 202       artype = TREE_TYPE (TREE_TYPE (arg));
 203       arg = build1 (REALPART_EXPR, artype, arg);
 204     }
 205
 206   se->expr = convert (type, arg);
 207 }
 208
 209
 210 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 211    TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 212    Similarly for CEILING.  */
 213
 214 static tree
 215 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 216 {
 217   tree tmp;
 218   tree cond;
 219   tree argtype;
 220   tree intval;
 221
 222   argtype = TREE_TYPE (arg);
 223   arg = gfc_evaluate_now (arg, pblock);
 224
 225   intval = convert (type, arg);
 226   intval = gfc_evaluate_now (intval, pblock);
 227
 228   tmp = convert (argtype, intval);
 229   cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 230
 231   tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node);
 232   tmp = build (COND_EXPR, type, cond, intval, tmp);
 233   return tmp;
 234 }
 235
 236
 237 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
 238    NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)).  */
 239
 240 static tree
 241 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
 242 {
 243   tree tmp;
 244   tree cond;
 245   tree neg;
 246   tree pos;
 247   tree argtype;
 248   REAL_VALUE_TYPE r;
 249
 250   argtype = TREE_TYPE (arg);
 251   arg = gfc_evaluate_now (arg, pblock);
 252
 253   real_from_string (&r, "0.5");
 254   pos = build_real (argtype, r);
 255
 256   real_from_string (&r, "-0.5");
 257   neg = build_real (argtype, r);
 258
 259   tmp = gfc_build_const (argtype, integer_zero_node);
 260   cond = fold (build (GT_EXPR, boolean_type_node, arg, tmp));
 261
 262   tmp = fold (build (COND_EXPR, argtype, cond, pos, neg));
 263   tmp = fold (build (PLUS_EXPR, argtype, arg, tmp));
 264   return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
 265 }
 266
 267
 268 /* Convert a real to an integer using a specific rounding mode.
 269    Ideally we would just build the corresponding GENERIC node,
 270    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 271
 272 static tree
 273 build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
 274 {
 275   switch (op)
 276     {
 277     case FIX_FLOOR_EXPR:
 278       return build_fixbound_expr (pblock, arg, type, 0);
 279       break;
 280
 281     case FIX_CEIL_EXPR:
 282       return build_fixbound_expr (pblock, arg, type, 1);
 283       break;
 284
 285     case FIX_ROUND_EXPR:
 286       return build_round_expr (pblock, arg, type);
 287
 288     default:
 289       return build1 (op, type, arg);
 290     }
 291 }
 292
 293
 294 /* Round a real value using the specified rounding mode.
 295    We use a temporary integer of that same kind size as the result.
 296    Values larger than can be represented by this kind are unchanged, as
 297    will not be accurate enough to represent the rounding.
 298     huge = HUGE (KIND (a))
 299     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 300    */
 301
 302 static void
 303 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
 304 {
 305   tree type;
 306   tree itype;
 307   tree arg;
 308   tree tmp;
 309   tree cond;
 310   mpf_t huge;
 311   int n;
 312   int kind;
 313
 314   kind = expr->ts.kind;
 315
 316   n = END_BUILTINS;
 317   /* We have builtin functions for some cases.  */
 318   switch (op)
 319     {
 320     case FIX_ROUND_EXPR:
 321       switch (kind)
 322         {
 323         case 4:
 324           n = BUILT_IN_ROUNDF;
 325           break;
 326
 327         case 8:
 328           n = BUILT_IN_ROUND;
 329           break;
 330         }
 331       break;
 332
 333     case FIX_FLOOR_EXPR:
 334       switch (kind)
 335         {
 336         case 4:
 337           n = BUILT_IN_FLOORF;
 338           break;
 339
 340         case 8:
 341           n = BUILT_IN_FLOOR;
 342           break;
 343         }
 344     }
 345
 346   /* Evaluate the argument.  */
 347   assert (expr->value.function.actual->expr);
 348   arg = gfc_conv_intrinsic_function_args (se, expr);
 349
 350   /* Use a builtin function if one exists.  */
 351   if (n != END_BUILTINS)
 352     {
 353       tmp = built_in_decls[n];
 354       se->expr = gfc_build_function_call (tmp, arg);
 355       return;
 356     }
 357
 358   /* This code is probably redundant, but we'll keep it lying around just
 359      in case.  */
 360   type = gfc_typenode_for_spec (&expr->ts);
 361   arg = TREE_VALUE (arg);
 362   arg = gfc_evaluate_now (arg, &se->pre);
 363
 364   /* Test if the value is too large to handle sensibly.  */
 365   mpf_init (huge);
 366   n = gfc_validate_kind (BT_INTEGER, kind);
 367   mpf_set_z (huge, gfc_integer_kinds[n].huge);
 368   tmp = gfc_conv_mpf_to_tree (huge, kind);
 369   cond = build (LT_EXPR, boolean_type_node, arg, tmp);
 370
 371   mpf_neg (huge, huge);
 372   tmp = gfc_conv_mpf_to_tree (huge, kind);
 373   tmp = build (GT_EXPR, boolean_type_node, arg, tmp);
 374   cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 375   itype = gfc_get_int_type (kind);
 376
 377   tmp = build_fix_expr (&se->pre, arg, itype, op);
 378   tmp = convert (type, tmp);
 379   se->expr = build (COND_EXPR, type, cond, tmp, arg);
 380 }
 381
 382
 383 /* Convert to an integer using the specified rounding mode.  */
 384
 385 static void
 386 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
 387 {
 388   tree type;
 389   tree arg;
 390
 391   /* Evaluate the argument.  */
 392   type = gfc_typenode_for_spec (&expr->ts);
 393   assert (expr->value.function.actual->expr);
 394   arg = gfc_conv_intrinsic_function_args (se, expr);
 395   arg = TREE_VALUE (arg);
 396
 397   if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
 398     {
 399       /* Conversion to a different integer kind.  */
 400       se->expr = convert (type, arg);
 401     }
 402   else
 403     {
 404       /* Conversion from complex to non-complex involves taking the real
 405          component of the value.  */
 406       if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
 407           && expr->ts.type != BT_COMPLEX)
 408         {
 409           tree artype;
 410
 411           artype = TREE_TYPE (TREE_TYPE (arg));
 412           arg = build1 (REALPART_EXPR, artype, arg);
 413         }
 414
 415       se->expr = build_fix_expr (&se->pre, arg, type, op);
 416     }
 417 }
 418
 419
 420 /* Get the imaginary component of a value.  */
 421
 422 static void
 423 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 424 {
 425   tree arg;
 426
 427   arg = gfc_conv_intrinsic_function_args (se, expr);
 428   arg = TREE_VALUE (arg);
 429   se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 430 }
 431
 432
 433 /* Get the complex conjugate of a value.  */
 434
 435 static void
 436 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 437 {
 438   tree arg;
 439
 440   arg = gfc_conv_intrinsic_function_args (se, expr);
 441   arg = TREE_VALUE (arg);
 442   se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 443 }
 444
 445
 446 /* Initialize function decls for library functions.  The external functions
 447    are created as required.  Builtin functions are added here.  */
 448
 449 void
 450 gfc_build_intrinsic_lib_fndecls (void)
 451 {
 452   gfc_intrinsic_map_t *m;
 453
 454   /* Add GCC builtin functions.  */
 455   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 456     {
 457       if (m->code4 != END_BUILTINS)
 458         m->real4_decl = built_in_decls[m->code4];
 459       if (m->code8 != END_BUILTINS)
 460         m->real8_decl = built_in_decls[m->code8];
 461     }
 462 }
 463
 464
 465 /* Create a fndecl for a simple intrinsic library function.  */
 466
 467 static tree
 468 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 469 {
 470   tree type;
 471   tree argtypes;
 472   tree fndecl;
 473   gfc_actual_arglist *actual;
 474   tree *pdecl;
 475   gfc_typespec *ts;
 476   char name[GFC_MAX_SYMBOL_LEN + 3];
 477
 478   ts = &expr->ts;
 479   if (ts->type == BT_REAL)
 480     {
 481       switch (ts->kind)
 482         {
 483         case 4:
 484           pdecl = &m->real4_decl;
 485           break;
 486         case 8:
 487           pdecl = &m->real8_decl;
 488           break;
 489         default:
 490           abort ();
 491         }
 492     }
 493   else if (ts->type == BT_COMPLEX)
 494     {
 495       if (!m->complex_available)
 496         abort ();
 497
 498       switch (ts->kind)
 499         {
 500         case 4:
 501           pdecl = &m->complex4_decl;
 502           break;
 503         case 8:
 504           pdecl = &m->complex8_decl;
 505           break;
 506         default:
 507           abort ();
 508         }
 509     }
 510   else
 511     abort ();
 512
 513   if (*pdecl)
 514     return *pdecl;
 515
 516   if (m->libm_name)
 517     {
 518       if (ts->kind != 4 && ts->kind != 8)
 519         abort ();
 520       snprintf (name, sizeof (name), "%s%s%s",
 521                 ts->type == BT_COMPLEX ? "c" : "",
 522                 m->name,
 523                 ts->kind == 4 ? "f" : "");
 524     }
 525   else
 526     {
 527       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 528                 ts->type == BT_COMPLEX ? 'c' : 'r',
 529                 ts->kind);
 530     }
 531
 532   argtypes = NULL_TREE;
 533   for (actual = expr->value.function.actual; actual; actual = actual->next)
 534     {
 535       type = gfc_typenode_for_spec (&actual->expr->ts);
 536       argtypes = gfc_chainon_list (argtypes, type);
 537     }
 538   argtypes = gfc_chainon_list (argtypes, void_type_node);
 539   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 540   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 541
 542   /* Mark the decl as external.  */
 543   DECL_EXTERNAL (fndecl) = 1;
 544   TREE_PUBLIC (fndecl) = 1;
 545
 546   /* Mark it __attribute__((const)), if possible.  */
 547   TREE_READONLY (fndecl) = m->is_constant;
 548
 549   rest_of_decl_compilation (fndecl, NULL, 1, 0);
 550
 551   (*pdecl) = fndecl;
 552   return fndecl;
 553 }
 554
 555
 556 /* Convert an intrinsic function into an external or builtin call.  */
 557
 558 static void
 559 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 560 {
 561   gfc_intrinsic_map_t *m;
 562   tree args;
 563   tree fndecl;
 564   gfc_generic_isym_id id;
 565
 566   id = expr->value.function.isym->generic_id;
 567   /* Find the entry for this function.  */
 568   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 569     {
 570       if (id == m->id)
 571         break;
 572     }
 573
 574   if (m->id == GFC_ISYM_NONE)
 575     {
 576       internal_error ("Intrinsic function %s(%d) not recognized",
 577                       expr->value.function.name, id);
 578     }
 579
 580   /* Get the decl and generate the call.  */
 581   args = gfc_conv_intrinsic_function_args (se, expr);
 582   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 583   se->expr = gfc_build_function_call (fndecl, args);
 584 }
 585
 586 /* Generate code for EXPONENT(X) intrinsic function.  */
 587
 588 static void
 589 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
 590 {
 591   tree args, fndecl;
 592   gfc_expr *a1;
 593
 594   args = gfc_conv_intrinsic_function_args (se, expr);
 595
 596   a1 = expr->value.function.actual->expr;
 597   switch (a1->ts.kind)
 598     {
 599     case 4:
 600       fndecl = gfor_fndecl_math_exponent4;
 601       break;
 602     case 8:
 603       fndecl = gfor_fndecl_math_exponent8;
 604       break;
 605     default:
 606       abort ();
 607     }
 608
 609   se->expr = gfc_build_function_call (fndecl, args);
 610 }
 611
 612 /* Evaluate a single upper or lower bound.  */
 613 /* TODO: bound intrinsic generates way too much unneccessary code.  */
 614
 615 static void
 616 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 617 {
 618   gfc_actual_arglist *arg;
 619   gfc_actual_arglist *arg2;
 620   tree desc;
 621   tree type;
 622   tree bound;
 623   tree tmp;
 624   tree cond;
 625   gfc_se argse;
 626   gfc_ss *ss;
 627   int i;
 628
 629   gfc_init_se (&argse, NULL);
 630   arg = expr->value.function.actual;
 631   arg2 = arg->next;
 632
 633   if (se->ss)
 634     {
 635       /* Create an implicit second parameter from the loop variable.  */
 636       assert (!arg2->expr);
 637       assert (se->loop->dimen == 1);
 638       assert (se->ss->expr == expr);
 639       gfc_advance_se_ss_chain (se);
 640       bound = se->loop->loopvar[0];
 641       bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
 642                            se->loop->from[0]));
 643     }
 644   else
 645     {
 646       /* use the passed argument.  */
 647       assert (arg->next->expr);
 648       gfc_init_se (&argse, NULL);
 649       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 650       gfc_add_block_to_block (&se->pre, &argse.pre);
 651       bound = argse.expr;
 652       /* Convert from one based to zero based.  */
 653       bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
 654                     integer_one_node));
 655     }
 656
 657   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 658   /* Get a descriptor for the first parameter.  */
 659   ss = gfc_walk_expr (arg->expr);
 660   assert (ss != gfc_ss_terminator);
 661   argse.want_pointer = 0;
 662   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 663   gfc_add_block_to_block (&se->pre, &argse.pre);
 664   gfc_add_block_to_block (&se->post, &argse.post);
 665
 666   desc = argse.expr;
 667
 668   if (INTEGER_CST_P (bound))
 669     {
 670       assert (TREE_INT_CST_HIGH (bound) == 0);
 671       i = TREE_INT_CST_LOW (bound);
 672       assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
 673     }
 674   else
 675     {
 676       if (flag_bounds_check)
 677         {
 678           bound = gfc_evaluate_now (bound, &se->pre);
 679           cond = fold (build (LT_EXPR, boolean_type_node, bound,
 680                               integer_zero_node));
 681           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 682           tmp = fold (build (GE_EXPR, boolean_type_node, bound, tmp));
 683           cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
 684           gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
 685         }
 686     }
 687
 688   if (upper)
 689     se->expr = gfc_conv_descriptor_ubound(desc, bound);
 690   else
 691     se->expr = gfc_conv_descriptor_lbound(desc, bound);
 692
 693   type = gfc_typenode_for_spec (&expr->ts);
 694   se->expr = convert (type, se->expr);
 695 }
 696
 697
 698 static void
 699 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
 700 {
 701   tree args;
 702   tree val;
 703   tree fndecl;
 704
 705   args = gfc_conv_intrinsic_function_args (se, expr);
 706   assert (args && TREE_CHAIN (args) == NULL_TREE);
 707   val = TREE_VALUE (args);
 708
 709   switch (expr->value.function.actual->expr->ts.type)
 710     {
 711     case BT_INTEGER:
 712     case BT_REAL:
 713       se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
 714       break;
 715
 716     case BT_COMPLEX:
 717       switch (expr->ts.kind)
 718         {
 719         case 4:
 720           fndecl = gfor_fndecl_math_cabsf;
 721           break;
 722         case 8:
 723           fndecl = gfor_fndecl_math_cabs;
 724           break;
 725         default:
 726           abort ();
 727         }
 728       se->expr = gfc_build_function_call (fndecl, args);
 729       break;
 730
 731     default:
 732       abort ();
 733     }
 734 }
 735
 736
 737 /* Create a complex value from one or two real components.  */
 738
 739 static void
 740 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
 741 {
 742   tree arg;
 743   tree real;
 744   tree imag;
 745   tree type;
 746
 747   type = gfc_typenode_for_spec (&expr->ts);
 748   arg = gfc_conv_intrinsic_function_args (se, expr);
 749   real = convert (TREE_TYPE (type), TREE_VALUE (arg));
 750   if (both)
 751     imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
 752   else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
 753     {
 754       arg = TREE_VALUE (arg);
 755       imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 756       imag = convert (TREE_TYPE (type), imag);
 757     }
 758   else
 759     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
 760
 761   se->expr = fold (build (COMPLEX_EXPR, type, real, imag));
 762 }
 763
 764 /* Remainder function MOD(A, P) = A - INT(A / P) * P.
 765    MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P.  */
 766 /* TODO: MOD(x, 0)  */
 767
 768 static void
 769 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
 770 {
 771   tree arg;
 772   tree arg2;
 773   tree type;
 774   tree itype;
 775   tree tmp;
 776   tree zero;
 777   tree test;
 778   tree test2;
 779   mpf_t huge;
 780   int n;
 781
 782   arg = gfc_conv_intrinsic_function_args (se, expr);
 783   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 784   arg = TREE_VALUE (arg);
 785   type = TREE_TYPE (arg);
 786
 787   switch (expr->ts.type)
 788     {
 789     case BT_INTEGER:
 790       /* Integer case is easy, we've got a builtin op.  */
 791       se->expr = build (TRUNC_MOD_EXPR, type, arg, arg2);
 792       break;
 793
 794     case BT_REAL:
 795       /* Real values we have to do the hard way.  */
 796       arg = gfc_evaluate_now (arg, &se->pre);
 797       arg2 = gfc_evaluate_now (arg2, &se->pre);
 798
 799       tmp = build (RDIV_EXPR, type, arg, arg2);
 800       /* Test if the value is too large to handle sensibly.  */
 801       mpf_init (huge);
 802       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind);
 803       mpf_set_z (huge, gfc_integer_kinds[n].huge);
 804       test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
 805       test2 = build (LT_EXPR, boolean_type_node, tmp, test);
 806
 807       mpf_neg (huge, huge);
 808       test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
 809       test = build (GT_EXPR, boolean_type_node, tmp, test);
 810       test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2);
 811
 812       itype = gfc_get_int_type (expr->ts.kind);
 813       tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
 814       tmp = convert (type, tmp);
 815       tmp = build (COND_EXPR, type, test2, tmp, arg);
 816       tmp = build (MULT_EXPR, type, tmp, arg2);
 817       se->expr = build (MINUS_EXPR, type, arg, tmp);
 818       break;
 819
 820     default:
 821       abort ();
 822     }
 823
 824   if (modulo)
 825     {
 826      zero = gfc_build_const (type, integer_zero_node);
 827      /* Build !(A > 0 .xor. P > 0).  */
 828      test = build (GT_EXPR, boolean_type_node, arg, zero);
 829      test2 = build (GT_EXPR, boolean_type_node, arg2, zero);
 830      test = build (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
 831      test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test);
 832      /* Build (A == 0) .or. !(A > 0 .xor. P > 0).  */
 833      test2 = build (EQ_EXPR, boolean_type_node, arg, zero);
 834      test = build (TRUTH_OR_EXPR, boolean_type_node, test, test2);
 835
 836      se->expr = build (COND_EXPR, type, test, se->expr,
 837                build (PLUS_EXPR, type, se->expr, arg2));
 838     }
 839 }
 840
 841 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
 842
 843 static void
 844 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
 845 {
 846   tree arg;
 847   tree arg2;
 848   tree val;
 849   tree tmp;
 850   tree type;
 851   tree zero;
 852
 853   arg = gfc_conv_intrinsic_function_args (se, expr);
 854   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 855   arg = TREE_VALUE (arg);
 856   type = TREE_TYPE (arg);
 857
 858   val = build (MINUS_EXPR, type, arg, arg2);
 859   val = gfc_evaluate_now (val, &se->pre);
 860
 861   zero = gfc_build_const (type, integer_zero_node);
 862   tmp = build (LE_EXPR, boolean_type_node, val, zero);
 863   se->expr = build (COND_EXPR, type, tmp, zero, val);
 864 }
 865
 866
 867 /* SIGN(A, B) is absolute value of A times sign of B.
 868    The real value versions use library functions to ensure the correct
 869    handling of negative zero.  Integer case implemented as:
 870    SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
 871   */
 872
 873 static void
 874 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
 875 {
 876   tree tmp;
 877   tree arg;
 878   tree arg2;
 879   tree type;
 880   tree zero;
 881   tree testa;
 882   tree testb;
 883
 884
 885   arg = gfc_conv_intrinsic_function_args (se, expr);
 886   if (expr->ts.type == BT_REAL)
 887     {
 888       switch (expr->ts.kind)
 889         {
 890         case 4:
 891           tmp = gfor_fndecl_math_sign4;
 892           break;
 893         case 8:
 894           tmp = gfor_fndecl_math_sign8;
 895           break;
 896         default:
 897           abort ();
 898         }
 899       se->expr = gfc_build_function_call (tmp, arg);
 900       return;
 901     }
 902
 903   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 904   arg = TREE_VALUE (arg);
 905   type = TREE_TYPE (arg);
 906   zero = gfc_build_const (type, integer_zero_node);
 907
 908   testa = fold (build (GE_EXPR, boolean_type_node, arg, zero));
 909   testb = fold (build (GE_EXPR, boolean_type_node, arg2, zero));
 910   tmp = fold (build (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
 911   se->expr = fold (build (COND_EXPR, type, tmp,
 912                           build1 (NEGATE_EXPR, type, arg), arg));
 913 }
 914
 915
 916 /* Test for the presence of an optional argument.  */
 917
 918 static void
 919 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
 920 {
 921   gfc_expr *arg;
 922
 923   arg = expr->value.function.actual->expr;
 924   assert (arg->expr_type == EXPR_VARIABLE);
 925   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
 926   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
 927 }
 928
 929
 930 /* Calculate the double precision product of two single precision values.  */
 931
 932 static void
 933 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
 934 {
 935   tree arg;
 936   tree arg2;
 937   tree type;
 938
 939   arg = gfc_conv_intrinsic_function_args (se, expr);
 940   arg2 = TREE_VALUE (TREE_CHAIN (arg));
 941   arg = TREE_VALUE (arg);
 942
 943   /* Convert the args to double precision before multiplying.  */
 944   type = gfc_typenode_for_spec (&expr->ts);
 945   arg = convert (type, arg);
 946   arg2 = convert (type, arg2);
 947   se->expr = build (MULT_EXPR, type, arg, arg2);
 948 }
 949
 950
 951 /* Return a length one character string containing an ascii character.  */
 952
 953 static void
 954 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
 955 {
 956   tree arg;
 957   tree var;
 958   tree type;
 959
 960   arg = gfc_conv_intrinsic_function_args (se, expr);
 961   arg = TREE_VALUE (arg);
 962
 963   /* We currently don't support character types != 1.  */
 964   assert (expr->ts.kind == 1);
 965   type = gfc_character1_type_node;
 966   var = gfc_create_var (type, "char");
 967
 968   arg = convert (type, arg);
 969   gfc_add_modify_expr (&se->pre, var, arg);
 970   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
 971   se->string_length = integer_one_node;
 972 }
 973
 974
 975 /* Get the minimum/maximum value of all the parameters.
 976     minmax (a1, a2, a3, ...)
 977     {
 978       if (a2 .op. a1)
 979         mvar = a2;
 980       else
 981         mvar = a1;
 982       if (a3 .op. mvar)
 983         mvar = a3;
 984       ...
 985       return mvar
 986     }
 987  */
 988
 989 /* TODO: Mismatching types can occur when specific names are used.
 990    These should be handled during resolution.  */
 991 static void
 992 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
 993 {
 994   tree limit;
 995   tree tmp;
 996   tree mvar;
 997   tree val;
 998   tree thencase;
 999   tree elsecase;
1000   tree arg;
1001   tree type;
1002
1003   arg = gfc_conv_intrinsic_function_args (se, expr);
1004   type = gfc_typenode_for_spec (&expr->ts);
1005
1006   limit = TREE_VALUE (arg);
1007   if (TREE_TYPE (limit) != type)
1008     limit = convert (type, limit);
1009   /* Only evaluate the argument once.  */
1010   if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1011     limit = gfc_evaluate_now(limit, &se->pre);
1012
1013   mvar = gfc_create_var (type, "M");
1014   elsecase = build_v (MODIFY_EXPR, mvar, limit);
1015   for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1016     {
1017       val = TREE_VALUE (arg);
1018       if (TREE_TYPE (val) != type)
1019         val = convert (type, val);
1020
1021       /* Only evaluate the argument once.  */
1022       if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1023         val = gfc_evaluate_now(val, &se->pre);
1024
1025       thencase = build_v (MODIFY_EXPR, mvar, convert (type, val));
1026
1027       tmp = build (op, boolean_type_node, val, limit);
1028       tmp = build_v (COND_EXPR, tmp, thencase, elsecase);
1029       gfc_add_expr_to_block (&se->pre, tmp);
1030       elsecase = build_empty_stmt ();
1031       limit = mvar;
1032     }
1033   se->expr = mvar;
1034 }
1035
1036
1037 /* Create a symbol node for this intrinsic.  The symbol form the frontend
1038    is for the generic name.  */
1039
1040 static gfc_symbol *
1041 gfc_get_symbol_for_expr (gfc_expr * expr)
1042 {
1043   gfc_symbol *sym;
1044
1045   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1046   assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1047   sym = gfc_new_symbol (expr->value.function.name, NULL);
1048
1049   sym->ts = expr->ts;
1050   sym->attr.external = 1;
1051   sym->attr.function = 1;
1052   sym->attr.always_explicit = 1;
1053   sym->attr.proc = PROC_INTRINSIC;
1054   sym->attr.flavor = FL_PROCEDURE;
1055   sym->result = sym;
1056   if (expr->rank > 0)
1057     {
1058       sym->attr.dimension = 1;
1059       sym->as = gfc_get_array_spec ();
1060       sym->as->type = AS_ASSUMED_SHAPE;
1061       sym->as->rank = expr->rank;
1062     }
1063
1064   /* TODO: proper argument lists for external intrinsics.  */
1065   return sym;
1066 }
1067
1068 /* Generate a call to an external intrinsic function.  */
1069 static void
1070 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1071 {
1072   gfc_symbol *sym;
1073
1074   assert (!se->ss || se->ss->expr == expr);
1075
1076   if (se->ss)
1077     assert (expr->rank > 0);
1078   else
1079     assert (expr->rank == 0);
1080
1081   sym = gfc_get_symbol_for_expr (expr);
1082   gfc_conv_function_call (se, sym, expr->value.function.actual);
1083   gfc_free (sym);
1084 }
1085
1086 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1087    Implemented as
1088     any(a)
1089     {
1090       forall (i=...)
1091         if (a[i] != 0)
1092           return 1
1093       end forall
1094       return 0
1095     }
1096     all(a)
1097     {
1098       forall (i=...)
1099         if (a[i] == 0)
1100           return 0
1101       end forall
1102       return 1
1103     }
1104  */
1105 static void
1106 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1107 {
1108   tree resvar;
1109   stmtblock_t block;
1110   stmtblock_t body;
1111   tree type;
1112   tree tmp;
1113   tree found;
1114   gfc_loopinfo loop;
1115   gfc_actual_arglist *actual;
1116   gfc_ss *arrayss;
1117   gfc_se arrayse;
1118   tree exit_label;
1119
1120   if (se->ss)
1121     {
1122       gfc_conv_intrinsic_funcall (se, expr);
1123       return;
1124     }
1125
1126   actual = expr->value.function.actual;
1127   type = gfc_typenode_for_spec (&expr->ts);
1128   /* Initialize the result.  */
1129   resvar = gfc_create_var (type, "test");
1130   if (op == EQ_EXPR)
1131     tmp = convert (type, boolean_true_node);
1132   else
1133     tmp = convert (type, boolean_false_node);
1134   gfc_add_modify_expr (&se->pre, resvar, tmp);
1135
1136   /* Walk the arguments.  */
1137   arrayss = gfc_walk_expr (actual->expr);
1138   assert (arrayss != gfc_ss_terminator);
1139
1140   /* Initialize the scalarizer.  */
1141   gfc_init_loopinfo (&loop);
1142   exit_label = gfc_build_label_decl (NULL_TREE);
1143   TREE_USED (exit_label) = 1;
1144   gfc_add_ss_to_loop (&loop, arrayss);
1145
1146   /* Initialize the loop.  */
1147   gfc_conv_ss_startstride (&loop);
1148   gfc_conv_loop_setup (&loop);
1149
1150   gfc_mark_ss_chain_used (arrayss, 1);
1151   /* Generate the loop body.  */
1152   gfc_start_scalarized_body (&loop, &body);
1153
1154   /* If the condition matches then set the return value.  */
1155   gfc_start_block (&block);
1156   if (op == EQ_EXPR)
1157     tmp = convert (type, boolean_false_node);
1158   else
1159     tmp = convert (type, boolean_true_node);
1160   gfc_add_modify_expr (&block, resvar, tmp);
1161
1162   /* And break out of the loop.  */
1163   tmp = build1_v (GOTO_EXPR, exit_label);
1164   gfc_add_expr_to_block (&block, tmp);
1165
1166   found = gfc_finish_block (&block);
1167
1168   /* Check this element.  */
1169   gfc_init_se (&arrayse, NULL);
1170   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1171   arrayse.ss = arrayss;
1172   gfc_conv_expr_val (&arrayse, actual->expr);
1173
1174   gfc_add_block_to_block (&body, &arrayse.pre);
1175   tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node);
1176   tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ());
1177   gfc_add_expr_to_block (&body, tmp);
1178   gfc_add_block_to_block (&body, &arrayse.post);
1179
1180   gfc_trans_scalarizing_loops (&loop, &body);
1181
1182   /* Add the exit label.  */
1183   tmp = build1_v (LABEL_EXPR, exit_label);
1184   gfc_add_expr_to_block (&loop.pre, tmp);
1185
1186   gfc_add_block_to_block (&se->pre, &loop.pre);
1187   gfc_add_block_to_block (&se->pre, &loop.post);
1188   gfc_cleanup_loop (&loop);
1189
1190   se->expr = resvar;
1191 }
1192
1193 /* COUNT(A) = Number of true elements in A.  */
1194 static void
1195 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1196 {
1197   tree resvar;
1198   tree type;
1199   stmtblock_t body;
1200   tree tmp;
1201   gfc_loopinfo loop;
1202   gfc_actual_arglist *actual;
1203   gfc_ss *arrayss;
1204   gfc_se arrayse;
1205
1206   if (se->ss)
1207     {
1208       gfc_conv_intrinsic_funcall (se, expr);
1209       return;
1210     }
1211
1212   actual = expr->value.function.actual;
1213
1214   type = gfc_typenode_for_spec (&expr->ts);
1215   /* Initialize the result.  */
1216   resvar = gfc_create_var (type, "count");
1217   gfc_add_modify_expr (&se->pre, resvar, integer_zero_node);
1218
1219   /* Walk the arguments.  */
1220   arrayss = gfc_walk_expr (actual->expr);
1221   assert (arrayss != gfc_ss_terminator);
1222
1223   /* Initialize the scalarizer.  */
1224   gfc_init_loopinfo (&loop);
1225   gfc_add_ss_to_loop (&loop, arrayss);
1226
1227   /* Initialize the loop.  */
1228   gfc_conv_ss_startstride (&loop);
1229   gfc_conv_loop_setup (&loop);
1230
1231   gfc_mark_ss_chain_used (arrayss, 1);
1232   /* Generate the loop body.  */
1233   gfc_start_scalarized_body (&loop, &body);
1234
1235   tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node);
1236   tmp = build_v (MODIFY_EXPR, resvar, tmp);
1237
1238   gfc_init_se (&arrayse, NULL);
1239   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1240   arrayse.ss = arrayss;
1241   gfc_conv_expr_val (&arrayse, actual->expr);
1242   tmp = build_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1243
1244   gfc_add_block_to_block (&body, &arrayse.pre);
1245   gfc_add_expr_to_block (&body, tmp);
1246   gfc_add_block_to_block (&body, &arrayse.post);
1247
1248   gfc_trans_scalarizing_loops (&loop, &body);
1249
1250   gfc_add_block_to_block (&se->pre, &loop.pre);
1251   gfc_add_block_to_block (&se->pre, &loop.post);
1252   gfc_cleanup_loop (&loop);
1253
1254   se->expr = resvar;
1255 }
1256
1257 /* Inline implementation of the sum and product intrinsics.  */
1258 static void
1259 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1260 {
1261   tree resvar;
1262   tree type;
1263   stmtblock_t body;
1264   stmtblock_t block;
1265   tree tmp;
1266   gfc_loopinfo loop;
1267   gfc_actual_arglist *actual;
1268   gfc_ss *arrayss;
1269   gfc_ss *maskss;
1270   gfc_se arrayse;
1271   gfc_se maskse;
1272   gfc_expr *arrayexpr;
1273   gfc_expr *maskexpr;
1274
1275   if (se->ss)
1276     {
1277       gfc_conv_intrinsic_funcall (se, expr);
1278       return;
1279     }
1280
1281   type = gfc_typenode_for_spec (&expr->ts);
1282   /* Initialize the result.  */
1283   resvar = gfc_create_var (type, "val");
1284   if (op == PLUS_EXPR)
1285     tmp = gfc_build_const (type, integer_zero_node);
1286   else
1287     tmp = gfc_build_const (type, integer_one_node);
1288
1289   gfc_add_modify_expr (&se->pre, resvar, tmp);
1290
1291   /* Walk the arguments.  */
1292   actual = expr->value.function.actual;
1293   arrayexpr = actual->expr;
1294   arrayss = gfc_walk_expr (arrayexpr);
1295   assert (arrayss != gfc_ss_terminator);
1296
1297   actual = actual->next->next;
1298   assert (actual);
1299   maskexpr = actual->expr;
1300   if (maskexpr)
1301     {
1302       maskss = gfc_walk_expr (maskexpr);
1303       assert (maskss != gfc_ss_terminator);
1304     }
1305   else
1306     maskss = NULL;
1307
1308   /* Initialize the scalarizer.  */
1309   gfc_init_loopinfo (&loop);
1310   gfc_add_ss_to_loop (&loop, arrayss);
1311   if (maskss)
1312     gfc_add_ss_to_loop (&loop, maskss);
1313
1314   /* Initialize the loop.  */
1315   gfc_conv_ss_startstride (&loop);
1316   gfc_conv_loop_setup (&loop);
1317
1318   gfc_mark_ss_chain_used (arrayss, 1);
1319   if (maskss)
1320     gfc_mark_ss_chain_used (maskss, 1);
1321   /* Generate the loop body.  */
1322   gfc_start_scalarized_body (&loop, &body);
1323
1324   /* If we have a mask, only add this element if the mask is set.  */
1325   if (maskss)
1326     {
1327       gfc_init_se (&maskse, NULL);
1328       gfc_copy_loopinfo_to_se (&maskse, &loop);
1329       maskse.ss = maskss;
1330       gfc_conv_expr_val (&maskse, maskexpr);
1331       gfc_add_block_to_block (&body, &maskse.pre);
1332
1333       gfc_start_block (&block);
1334     }
1335   else
1336     gfc_init_block (&block);
1337
1338   /* Do the actual summation/product.  */
1339   gfc_init_se (&arrayse, NULL);
1340   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1341   arrayse.ss = arrayss;
1342   gfc_conv_expr_val (&arrayse, arrayexpr);
1343   gfc_add_block_to_block (&block, &arrayse.pre);
1344
1345   tmp = build (op, type, resvar, arrayse.expr);
1346   gfc_add_modify_expr (&block, resvar, tmp);
1347   gfc_add_block_to_block (&block, &arrayse.post);
1348
1349   if (maskss)
1350     {
1351       /* We enclose the above in if (mask) {...} .  */
1352       tmp = gfc_finish_block (&block);
1353
1354       tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1355     }
1356   else
1357     tmp = gfc_finish_block (&block);
1358   gfc_add_expr_to_block (&body, tmp);
1359
1360   gfc_trans_scalarizing_loops (&loop, &body);
1361   gfc_add_block_to_block (&se->pre, &loop.pre);
1362   gfc_add_block_to_block (&se->pre, &loop.post);
1363   gfc_cleanup_loop (&loop);
1364
1365   se->expr = resvar;
1366 }
1367
1368 static void
1369 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1370 {
1371   stmtblock_t body;
1372   stmtblock_t block;
1373   stmtblock_t ifblock;
1374   tree limit;
1375   tree type;
1376   tree tmp;
1377   tree ifbody;
1378   tree cond;
1379   gfc_loopinfo loop;
1380   gfc_actual_arglist *actual;
1381   gfc_ss *arrayss;
1382   gfc_ss *maskss;
1383   gfc_se arrayse;
1384   gfc_se maskse;
1385   gfc_expr *arrayexpr;
1386   gfc_expr *maskexpr;
1387   tree pos;
1388   int n;
1389
1390   if (se->ss)
1391     {
1392       gfc_conv_intrinsic_funcall (se, expr);
1393       return;
1394     }
1395
1396   /* Initialize the result.  */
1397   pos = gfc_create_var (gfc_array_index_type, "pos");
1398   type = gfc_typenode_for_spec (&expr->ts);
1399
1400   /* Walk the arguments.  */
1401   actual = expr->value.function.actual;
1402   arrayexpr = actual->expr;
1403   arrayss = gfc_walk_expr (arrayexpr);
1404   assert (arrayss != gfc_ss_terminator);
1405
1406   actual = actual->next->next;
1407   assert (actual);
1408   maskexpr = actual->expr;
1409   if (maskexpr)
1410     {
1411       maskss = gfc_walk_expr (maskexpr);
1412       assert (maskss != gfc_ss_terminator);
1413     }
1414   else
1415     maskss = NULL;
1416
1417   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1418   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind);
1419   switch (arrayexpr->ts.type)
1420     {
1421     case BT_REAL:
1422       tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1423       break;
1424
1425     case BT_INTEGER:
1426       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1427                                   arrayexpr->ts.kind);
1428       break;
1429
1430     default:
1431       abort ();
1432     }
1433
1434   /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval.  */
1435   if (op == GT_EXPR)
1436     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1437   gfc_add_modify_expr (&se->pre, limit, tmp);
1438
1439   /* Initialize the scalarizer.  */
1440   gfc_init_loopinfo (&loop);
1441   gfc_add_ss_to_loop (&loop, arrayss);
1442   if (maskss)
1443     gfc_add_ss_to_loop (&loop, maskss);
1444
1445   /* Initialize the loop.  */
1446   gfc_conv_ss_startstride (&loop);
1447   gfc_conv_loop_setup (&loop);
1448
1449   assert (loop.dimen == 1);
1450
1451   /* Initialize the position to the first element.  If the array has zero
1452      size we need to return zero.  Otherwise use the first element of the
1453      array, in case all elements are equal to the limit.
1454      ie. pos = (ubound >= lbound) ? lbound, lbound - 1;  */
1455   tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
1456                      loop.from[0], integer_one_node));
1457   cond = fold (build (GE_EXPR, boolean_type_node,
1458                       loop.to[0], loop.from[0]));
1459   tmp = fold (build (COND_EXPR, gfc_array_index_type, cond,
1460                      loop.from[0], tmp));
1461   gfc_add_modify_expr (&loop.pre, pos, tmp);
1462
1463   gfc_mark_ss_chain_used (arrayss, 1);
1464   if (maskss)
1465     gfc_mark_ss_chain_used (maskss, 1);
1466   /* Generate the loop body.  */
1467   gfc_start_scalarized_body (&loop, &body);
1468
1469   /* If we have a mask, only check this element if the mask is set.  */
1470   if (maskss)
1471     {
1472       gfc_init_se (&maskse, NULL);
1473       gfc_copy_loopinfo_to_se (&maskse, &loop);
1474       maskse.ss = maskss;
1475       gfc_conv_expr_val (&maskse, maskexpr);
1476       gfc_add_block_to_block (&body, &maskse.pre);
1477
1478       gfc_start_block (&block);
1479     }
1480   else
1481     gfc_init_block (&block);
1482
1483   /* Compare with the current limit.  */
1484   gfc_init_se (&arrayse, NULL);
1485   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1486   arrayse.ss = arrayss;
1487   gfc_conv_expr_val (&arrayse, arrayexpr);
1488   gfc_add_block_to_block (&block, &arrayse.pre);
1489
1490   /* We do the following if this is a more extreme value.  */
1491   gfc_start_block (&ifblock);
1492
1493   /* Assign the value to the limit...  */
1494   gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1495
1496   /* Remember where we are.  */
1497   gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1498
1499   ifbody = gfc_finish_block (&ifblock);
1500
1501   /* If it is a more extreme value.  */
1502   tmp = build (op, boolean_type_node, arrayse.expr, limit);
1503   tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1504   gfc_add_expr_to_block (&block, tmp);
1505
1506   if (maskss)
1507     {
1508       /* We enclose the above in if (mask) {...}.  */
1509       tmp = gfc_finish_block (&block);
1510
1511       tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1512     }
1513   else
1514     tmp = gfc_finish_block (&block);
1515   gfc_add_expr_to_block (&body, tmp);
1516
1517   gfc_trans_scalarizing_loops (&loop, &body);
1518
1519   gfc_add_block_to_block (&se->pre, &loop.pre);
1520   gfc_add_block_to_block (&se->pre, &loop.post);
1521   gfc_cleanup_loop (&loop);
1522
1523   /* Return a value in the range 1..SIZE(array).  */
1524   tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1525                      integer_one_node));
1526   tmp = fold (build (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1527   /* And convert to the required type.  */
1528   se->expr = convert (type, tmp);
1529 }
1530
1531 static void
1532 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1533 {
1534   tree limit;
1535   tree type;
1536   tree tmp;
1537   tree ifbody;
1538   stmtblock_t body;
1539   stmtblock_t block;
1540   gfc_loopinfo loop;
1541   gfc_actual_arglist *actual;
1542   gfc_ss *arrayss;
1543   gfc_ss *maskss;
1544   gfc_se arrayse;
1545   gfc_se maskse;
1546   gfc_expr *arrayexpr;
1547   gfc_expr *maskexpr;
1548   int n;
1549
1550   if (se->ss)
1551     {
1552       gfc_conv_intrinsic_funcall (se, expr);
1553       return;
1554     }
1555
1556   type = gfc_typenode_for_spec (&expr->ts);
1557   /* Initialize the result.  */
1558   limit = gfc_create_var (type, "limit");
1559   n = gfc_validate_kind (expr->ts.type, expr->ts.kind);
1560   switch (expr->ts.type)
1561     {
1562     case BT_REAL:
1563       tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1564       break;
1565
1566     case BT_INTEGER:
1567       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1568       break;
1569
1570     default:
1571       abort ();
1572     }
1573
1574   /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval.  */
1575   if (op == GT_EXPR)
1576     tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1577   gfc_add_modify_expr (&se->pre, limit, tmp);
1578
1579   /* Walk the arguments.  */
1580   actual = expr->value.function.actual;
1581   arrayexpr = actual->expr;
1582   arrayss = gfc_walk_expr (arrayexpr);
1583   assert (arrayss != gfc_ss_terminator);
1584
1585   actual = actual->next->next;
1586   assert (actual);
1587   maskexpr = actual->expr;
1588   if (maskexpr)
1589     {
1590       maskss = gfc_walk_expr (maskexpr);
1591       assert (maskss != gfc_ss_terminator);
1592     }
1593   else
1594     maskss = NULL;
1595
1596   /* Initialize the scalarizer.  */
1597   gfc_init_loopinfo (&loop);
1598   gfc_add_ss_to_loop (&loop, arrayss);
1599   if (maskss)
1600     gfc_add_ss_to_loop (&loop, maskss);
1601
1602   /* Initialize the loop.  */
1603   gfc_conv_ss_startstride (&loop);
1604   gfc_conv_loop_setup (&loop);
1605
1606   gfc_mark_ss_chain_used (arrayss, 1);
1607   if (maskss)
1608     gfc_mark_ss_chain_used (maskss, 1);
1609   /* Generate the loop body.  */
1610   gfc_start_scalarized_body (&loop, &body);
1611
1612   /* If we have a mask, only add this element if the mask is set.  */
1613   if (maskss)
1614     {
1615       gfc_init_se (&maskse, NULL);
1616       gfc_copy_loopinfo_to_se (&maskse, &loop);
1617       maskse.ss = maskss;
1618       gfc_conv_expr_val (&maskse, maskexpr);
1619       gfc_add_block_to_block (&body, &maskse.pre);
1620
1621       gfc_start_block (&block);
1622     }
1623   else
1624     gfc_init_block (&block);
1625
1626   /* Compare with the current limit.  */
1627   gfc_init_se (&arrayse, NULL);
1628   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1629   arrayse.ss = arrayss;
1630   gfc_conv_expr_val (&arrayse, arrayexpr);
1631   gfc_add_block_to_block (&block, &arrayse.pre);
1632
1633   /* Assign the value to the limit...  */
1634   ifbody = build_v (MODIFY_EXPR, limit, arrayse.expr);
1635
1636   /* If it is a more extreme value.  */
1637   tmp = build (op, boolean_type_node, arrayse.expr, limit);
1638   tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1639   gfc_add_expr_to_block (&block, tmp);
1640   gfc_add_block_to_block (&block, &arrayse.post);
1641
1642   tmp = gfc_finish_block (&block);
1643   if (maskss)
1644     {
1645       /* We enclose the above in if (mask) {...}.  */
1646       tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1647     }
1648   gfc_add_expr_to_block (&body, tmp);
1649
1650   gfc_trans_scalarizing_loops (&loop, &body);
1651
1652   gfc_add_block_to_block (&se->pre, &loop.pre);
1653   gfc_add_block_to_block (&se->pre, &loop.post);
1654   gfc_cleanup_loop (&loop);
1655
1656   se->expr = limit;
1657 }
1658
1659 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
1660 static void
1661 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1662 {
1663   tree arg;
1664   tree arg2;
1665   tree type;
1666   tree tmp;
1667
1668   arg = gfc_conv_intrinsic_function_args (se, expr);
1669   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1670   arg = TREE_VALUE (arg);
1671   type = TREE_TYPE (arg);
1672
1673   tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2);
1674   tmp = build (BIT_AND_EXPR, type, arg, tmp);
1675   tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node));
1676   type = gfc_typenode_for_spec (&expr->ts);
1677   se->expr = convert (type, tmp);
1678 }
1679
1680 /* Generate code to perform the specified operation.  */
1681 static void
1682 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1683 {
1684   tree arg;
1685   tree arg2;
1686   tree type;
1687
1688   arg = gfc_conv_intrinsic_function_args (se, expr);
1689   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1690   arg = TREE_VALUE (arg);
1691   type = TREE_TYPE (arg);
1692
1693   se->expr = fold (build (op, type, arg, arg2));
1694 }
1695
1696 /* Bitwise not.  */
1697 static void
1698 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1699 {
1700   tree arg;
1701
1702   arg = gfc_conv_intrinsic_function_args (se, expr);
1703   arg = TREE_VALUE (arg);
1704
1705   se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1706 }
1707
1708 /* Set or clear a single bit.  */
1709 static void
1710 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1711 {
1712   tree arg;
1713   tree arg2;
1714   tree type;
1715   tree tmp;
1716   int op;
1717
1718   arg = gfc_conv_intrinsic_function_args (se, expr);
1719   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1720   arg = TREE_VALUE (arg);
1721   type = TREE_TYPE (arg);
1722
1723   tmp = fold (build (LSHIFT_EXPR, type, integer_one_node, arg2));
1724   if (set)
1725     op = BIT_IOR_EXPR;
1726   else
1727     {
1728       op = BIT_AND_EXPR;
1729       tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1730     }
1731   se->expr = fold (build (op, type, arg, tmp));
1732 }
1733
1734 /* Extract a sequence of bits.
1735     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
1736 static void
1737 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1738 {
1739   tree arg;
1740   tree arg2;
1741   tree arg3;
1742   tree type;
1743   tree tmp;
1744   tree mask;
1745
1746   arg = gfc_conv_intrinsic_function_args (se, expr);
1747   arg2 = TREE_CHAIN (arg);
1748   arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1749   arg = TREE_VALUE (arg);
1750   arg2 = TREE_VALUE (arg2);
1751   type = TREE_TYPE (arg);
1752
1753   mask = build_int_2 (-1, ~(unsigned HOST_WIDE_INT) 0);
1754   mask = build (LSHIFT_EXPR, type, mask, arg3);
1755   mask = build1 (BIT_NOT_EXPR, type, mask);
1756
1757   tmp = build (RSHIFT_EXPR, type, arg, arg2);
1758
1759   se->expr = fold (build (BIT_AND_EXPR, type, tmp, mask));
1760 }
1761
1762 /* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift.  */
1763 static void
1764 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1765 {
1766   tree arg;
1767   tree arg2;
1768   tree type;
1769   tree tmp;
1770   tree lshift;
1771   tree rshift;
1772
1773   arg = gfc_conv_intrinsic_function_args (se, expr);
1774   arg2 = TREE_VALUE (TREE_CHAIN (arg));
1775   arg = TREE_VALUE (arg);
1776   type = TREE_TYPE (arg);
1777
1778   /* Left shift if positive.  */
1779   lshift = build (LSHIFT_EXPR, type, arg, arg2);
1780
1781   /* Right shift if negative.  This will perform an arithmetic shift as
1782      we are dealing with signed integers.  Section 13.5.7 allows this.  */
1783   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1784   rshift = build (RSHIFT_EXPR, type, arg, tmp);
1785
1786   tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
1787   rshift = build (COND_EXPR, type, tmp, lshift, rshift);
1788
1789   /* Do nothing if shift == 0.  */
1790   tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
1791   se->expr = build (COND_EXPR, type, tmp, arg, rshift);
1792 }
1793
1794 /* Circular shift.  AKA rotate or barrel shift.  */
1795 static void
1796 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1797 {
1798   tree arg;
1799   tree arg2;
1800   tree arg3;
1801   tree type;
1802   tree tmp;
1803   tree lrot;
1804   tree rrot;
1805
1806   arg = gfc_conv_intrinsic_function_args (se, expr);
1807   arg2 = TREE_CHAIN (arg);
1808   arg3 = TREE_CHAIN (arg2);
1809   if (arg3)
1810     {
1811       /* Use a library function for the 3 parameter version.  */
1812       type = TREE_TYPE (TREE_VALUE (arg));
1813       /* Convert all args to the same type otherwise we need loads of library
1814          functions.  SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
1815          conversion is safe.  */
1816       tmp = convert (type, TREE_VALUE (arg2));
1817       TREE_VALUE (arg2) = tmp;
1818       tmp = convert (type, TREE_VALUE (arg3));
1819       TREE_VALUE (arg3) = tmp;
1820
1821       switch (expr->ts.kind)
1822         {
1823         case 4:
1824           tmp = gfor_fndecl_math_ishftc4;
1825           break;
1826         case 8:
1827           tmp = gfor_fndecl_math_ishftc8;
1828           break;
1829         default:
1830           abort ();
1831         }
1832       se->expr = gfc_build_function_call (tmp, arg);
1833       return;
1834     }
1835   arg = TREE_VALUE (arg);
1836   arg2 = TREE_VALUE (arg2);
1837   type = TREE_TYPE (arg);
1838
1839   /* Rotate left if positive.  */
1840   lrot = build (LROTATE_EXPR, type, arg, arg2);
1841
1842   /* Rotate right if negative.  */
1843   tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
1844   rrot = build (RROTATE_EXPR, type, arg, tmp);
1845
1846   tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
1847   rrot = build (COND_EXPR, type, tmp, lrot, rrot);
1848
1849   /* Do nothing if shift == 0.  */
1850   tmp = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
1851   se->expr = build (COND_EXPR, type, tmp, arg, rrot);
1852 }
1853
1854 /* The length of a character string.  */
1855 static void
1856 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1857 {
1858   tree len;
1859   tree type;
1860   tree decl;
1861   gfc_symbol *sym;
1862   gfc_se argse;
1863   gfc_expr *arg;
1864
1865   assert (!se->ss);
1866
1867   arg = expr->value.function.actual->expr;
1868
1869   type = gfc_typenode_for_spec (&expr->ts);
1870   switch (arg->expr_type)
1871     {
1872     case EXPR_CONSTANT:
1873       len = build_int_2 (arg->value.character.length, 0);
1874       break;
1875
1876     default:
1877         if (arg->expr_type == EXPR_VARIABLE
1878             && (arg->ref == NULL || (arg->ref->next == NULL
1879                                      && arg->ref->type == REF_ARRAY)))
1880           {
1881             /* This doesn't catch all cases.
1882                See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1883                and the surrounding thread.  */
1884             sym = arg->symtree->n.sym;
1885             decl = gfc_get_symbol_decl (sym);
1886             if (decl == current_function_decl && sym->attr.function
1887                 && (sym->result == sym))
1888               decl = gfc_get_fake_result_decl (sym);
1889
1890             len = sym->ts.cl->backend_decl;
1891             assert (len);
1892           }
1893         else
1894           {
1895             /* Anybody stupid enough to do this deserves inefficient code.  */
1896             gfc_init_se (&argse, se);
1897             gfc_conv_expr (&argse, arg);
1898             gfc_add_block_to_block (&se->pre, &argse.pre);
1899             gfc_add_block_to_block (&se->post, &argse.post);
1900             len = argse.string_length;
1901         }
1902       break;
1903     }
1904   se->expr = convert (type, len);
1905 }
1906
1907 /* The length of a character string not including trailing blanks.  */
1908 static void
1909 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1910 {
1911   tree args;
1912   tree type;
1913
1914   args = gfc_conv_intrinsic_function_args (se, expr);
1915   type = gfc_typenode_for_spec (&expr->ts);
1916   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1917   se->expr = convert (type, se->expr);
1918 }
1919
1920
1921 /* Returns the starting position of a substring within a string.  */
1922
1923 static void
1924 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1925 {
1926   tree args;
1927   tree back;
1928   tree type;
1929   tree tmp;
1930
1931   args = gfc_conv_intrinsic_function_args (se, expr);
1932   type = gfc_typenode_for_spec (&expr->ts);
1933   tmp = gfc_advance_chain (args, 3);
1934   if (TREE_CHAIN (tmp) == NULL_TREE)
1935     {
1936       back = convert (gfc_logical4_type_node, integer_one_node);
1937       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1938       TREE_CHAIN (tmp) = back;
1939     }
1940   else
1941     {
1942       back = TREE_CHAIN (tmp);
1943       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1944     }
1945
1946   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1947   se->expr = convert (type, se->expr);
1948 }
1949
1950 /* The ascii value for a single character.  */
1951 static void
1952 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1953 {
1954   tree arg;
1955   tree type;
1956
1957   arg = gfc_conv_intrinsic_function_args (se, expr);
1958   arg = TREE_VALUE (TREE_CHAIN (arg));
1959   assert (POINTER_TYPE_P (TREE_TYPE (arg)));
1960   arg = build1 (NOP_EXPR, pchar_type_node, arg);
1961   type = gfc_typenode_for_spec (&expr->ts);
1962
1963   se->expr = gfc_build_indirect_ref (arg);
1964   se->expr = convert (type, se->expr);
1965 }
1966
1967
1968 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
1969
1970 static void
1971 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
1972 {
1973   tree arg;
1974   tree tsource;
1975   tree fsource;
1976   tree mask;
1977   tree type;
1978
1979   arg = gfc_conv_intrinsic_function_args (se, expr);
1980   tsource = TREE_VALUE (arg);
1981   arg = TREE_CHAIN (arg);
1982   fsource = TREE_VALUE (arg);
1983   arg = TREE_CHAIN (arg);
1984   mask = TREE_VALUE (arg);
1985
1986   type = TREE_TYPE (tsource);
1987   se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource));
1988 }
1989
1990
1991 static void
1992 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
1993 {
1994   gfc_actual_arglist *actual;
1995   tree args;
1996   tree type;
1997   tree fndecl;
1998   gfc_se argse;
1999   gfc_ss *ss;
2000
2001   gfc_init_se (&argse, NULL);
2002   actual = expr->value.function.actual;
2003
2004   ss = gfc_walk_expr (actual->expr);
2005   assert (ss != gfc_ss_terminator);
2006   argse.want_pointer = 1;
2007   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2008   gfc_add_block_to_block (&se->pre, &argse.pre);
2009   gfc_add_block_to_block (&se->post, &argse.post);
2010   args = gfc_chainon_list (NULL_TREE, argse.expr);
2011
2012   actual = actual->next;
2013   if (actual->expr)
2014     {
2015       gfc_init_se (&argse, NULL);
2016       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2017       gfc_add_block_to_block (&se->pre, &argse.pre);
2018       args = gfc_chainon_list (args, argse.expr);
2019       fndecl = gfor_fndecl_size1;
2020     }
2021   else
2022     fndecl = gfor_fndecl_size0;
2023
2024   se->expr = gfc_build_function_call (fndecl, args);
2025   type = gfc_typenode_for_spec (&expr->ts);
2026   se->expr = convert (type, se->expr);
2027 }
2028
2029
2030 /* Intrinsic string comparison functions.  */
2031
2032   static void
2033 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2034 {
2035   tree type;
2036   tree args;
2037
2038   args = gfc_conv_intrinsic_function_args (se, expr);
2039   /* Build a call for the comparison.  */
2040   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2041
2042   type = gfc_typenode_for_spec (&expr->ts);
2043   se->expr = build (op, type, se->expr, integer_zero_node);
2044 }
2045
2046 /* Generate a call to the adjustl/adjustr library function.  */
2047 static void
2048 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2049 {
2050   tree args;
2051   tree len;
2052   tree type;
2053   tree var;
2054   tree tmp;
2055
2056   args = gfc_conv_intrinsic_function_args (se, expr);
2057   len = TREE_VALUE (args);
2058
2059   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2060   var = gfc_conv_string_tmp (se, type, len);
2061   args = tree_cons (NULL_TREE, var, args);
2062
2063   tmp = gfc_build_function_call (fndecl, args);
2064   gfc_add_expr_to_block (&se->pre, tmp);
2065   se->expr = var;
2066   se->string_length = len;
2067 }
2068
2069
2070 /* Scalar transfer statement.
2071    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2072
2073 static void
2074 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2075 {
2076   gfc_actual_arglist *arg;
2077   gfc_se argse;
2078   tree type;
2079   tree ptr;
2080   gfc_ss *ss;
2081
2082   assert (!se->ss);
2083
2084   /* Get a pointer to the source.  */
2085   arg = expr->value.function.actual;
2086   ss = gfc_walk_expr (arg->expr);
2087   gfc_init_se (&argse, NULL);
2088   if (ss == gfc_ss_terminator)
2089     gfc_conv_expr_reference (&argse, arg->expr);
2090   else
2091     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2092   gfc_add_block_to_block (&se->pre, &argse.pre);
2093   gfc_add_block_to_block (&se->post, &argse.post);
2094   ptr = argse.expr;
2095
2096   arg = arg->next;
2097   type = gfc_typenode_for_spec (&expr->ts);
2098   ptr = convert (build_pointer_type (type), ptr);
2099   if (expr->ts.type == BT_CHARACTER)
2100     {
2101       gfc_init_se (&argse, NULL);
2102       gfc_conv_expr (&argse, arg->expr);
2103       gfc_add_block_to_block (&se->pre, &argse.pre);
2104       gfc_add_block_to_block (&se->post, &argse.post);
2105       se->expr = ptr;
2106       se->string_length = argse.string_length;
2107     }
2108   else
2109     {
2110       se->expr = gfc_build_indirect_ref (ptr);
2111     }
2112 }
2113
2114
2115 /* Generate code for the ALLOCATED intrinsic.
2116    Generate inline code that directly check the address of the argument.  */
2117
2118 static void
2119 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2120 {
2121   gfc_actual_arglist *arg1;
2122   gfc_se arg1se;
2123   gfc_ss *ss1;
2124   tree tmp;
2125
2126   gfc_init_se (&arg1se, NULL);
2127   arg1 = expr->value.function.actual;
2128   ss1 = gfc_walk_expr (arg1->expr);
2129   arg1se.descriptor_only = 1;
2130   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2131
2132   tmp = gfc_conv_descriptor_data (arg1se.expr);
2133   tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
2134   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2135 }
2136
2137
2138 /* Generate code for the ASSOCIATED intrinsic.
2139    If both POINTER and TARGET are arrays, generate a call to library function
2140    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2141    In other cases, generate inline code that directly compare the address of
2142    POINTER with the address of TARGET.  */
2143
2144 static void
2145 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2146 {
2147   gfc_actual_arglist *arg1;
2148   gfc_actual_arglist *arg2;
2149   gfc_se arg1se;
2150   gfc_se arg2se;
2151   tree tmp2;
2152   tree tmp;
2153   tree args, fndecl;
2154   gfc_ss *ss1, *ss2;
2155
2156   gfc_init_se (&arg1se, NULL);
2157   gfc_init_se (&arg2se, NULL);
2158   arg1 = expr->value.function.actual;
2159   arg2 = arg1->next;
2160   ss1 = gfc_walk_expr (arg1->expr);
2161
2162   if (!arg2->expr)
2163     {
2164       /* No optional target.  */
2165       if (ss1 == gfc_ss_terminator)
2166         {
2167           /* A pointer to a scalar.  */
2168           arg1se.want_pointer = 1;
2169           gfc_conv_expr (&arg1se, arg1->expr);
2170           tmp2 = arg1se.expr;
2171         }
2172       else
2173         {
2174           /* A pointer to an array.  */
2175           arg1se.descriptor_only = 1;
2176           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2177           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2178         }
2179       tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
2180       se->expr = tmp;
2181     }
2182   else
2183     {
2184       /* An optional target.  */
2185       ss2 = gfc_walk_expr (arg2->expr);
2186       if (ss1 == gfc_ss_terminator)
2187         {
2188           /* A pointer to a scalar.  */
2189           assert (ss2 == gfc_ss_terminator);
2190           arg1se.want_pointer = 1;
2191           gfc_conv_expr (&arg1se, arg1->expr);
2192           arg2se.want_pointer = 1;
2193           gfc_conv_expr (&arg2se, arg2->expr);
2194           tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2195           se->expr = tmp;
2196         }
2197       else
2198         {
2199           /* A pointer to an array, call library function _gfor_associated.  */
2200           assert (ss2 != gfc_ss_terminator);
2201           args = NULL_TREE;
2202           arg1se.want_pointer = 1;
2203           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2204           args = gfc_chainon_list (args, arg1se.expr);
2205           arg2se.want_pointer = 1;
2206           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2207           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2208           gfc_add_block_to_block (&se->post, &arg2se.post);
2209           args = gfc_chainon_list (args, arg2se.expr);
2210           fndecl = gfor_fndecl_associated;
2211           se->expr = gfc_build_function_call (fndecl, args);
2212         }
2213      }
2214   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2215 }
2216
2217
2218 /* Scan a string for any one of the characters in a set of characters.   */
2219
2220 static void
2221 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2222 {
2223   tree args;
2224   tree back;
2225   tree type;
2226   tree tmp;
2227
2228   args = gfc_conv_intrinsic_function_args (se, expr);
2229   type = gfc_typenode_for_spec (&expr->ts);
2230   tmp = gfc_advance_chain (args, 3);
2231   if (TREE_CHAIN (tmp) == NULL_TREE)
2232     {
2233       back = convert (gfc_logical4_type_node, integer_one_node);
2234       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2235       TREE_CHAIN (tmp) = back;
2236     }
2237   else
2238     {
2239       back = TREE_CHAIN (tmp);
2240       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2241     }
2242
2243   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2244   se->expr = convert (type, se->expr);
2245 }
2246
2247
2248 /* Verify that a set of characters contains all the characters in a string
2249    by indentifying the position of the first character in a string of
2250    characters that does not appear in a given set of characters.  */
2251
2252 static void
2253 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2254 {
2255   tree args;
2256   tree back;
2257   tree type;
2258   tree tmp;
2259
2260   args = gfc_conv_intrinsic_function_args (se, expr);
2261   type = gfc_typenode_for_spec (&expr->ts);
2262   tmp = gfc_advance_chain (args, 3);
2263   if (TREE_CHAIN (tmp) == NULL_TREE)
2264     {
2265       back = convert (gfc_logical4_type_node, integer_one_node);
2266       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2267       TREE_CHAIN (tmp) = back;
2268     }
2269   else
2270     {
2271       back = TREE_CHAIN (tmp);
2272       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2273     }
2274
2275   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2276   se->expr = convert (type, se->expr);
2277 }
2278
2279 /* Prepare components and related information of a real number which is
2280    the first argument of a elemental functions to manipulate reals.  */
2281
2282 static
2283 void prepare_arg_info (gfc_se * se, gfc_expr * expr,
2284                        real_compnt_info * rcs, int all)
2285 {
2286    tree arg;
2287    tree masktype;
2288    tree tmp;
2289    tree wbits;
2290    tree one;
2291    tree exponent, fraction;
2292    int n;
2293    gfc_expr *a1;
2294
2295    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2296      gfc_todo_error ("Non-IEEE floating format");
2297
2298    assert (expr->expr_type == EXPR_FUNCTION);
2299
2300    arg = gfc_conv_intrinsic_function_args (se, expr);
2301    arg = TREE_VALUE (arg);
2302    rcs->type = TREE_TYPE (arg);
2303
2304    /* Force arg'type to integer by unaffected convert  */
2305    a1 = expr->value.function.actual->expr;
2306    masktype = gfc_get_int_type (a1->ts.kind);
2307    rcs->mtype = masktype;
2308    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2309    arg = gfc_create_var (masktype, "arg");
2310    gfc_add_modify_expr(&se->pre, arg, tmp);
2311    rcs->arg = arg;
2312
2313    /* Caculate the numbers of bits of exponent, fraction and word  */
2314    n = gfc_validate_kind (a1->ts.type, a1->ts.kind);
2315    tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0);
2316    rcs->fdigits = convert (masktype, tmp);
2317    wbits = build_int_2 (TYPE_PRECISION (rcs->type) - 1, 0);
2318    wbits = convert (masktype, wbits);
2319    rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp));
2320
2321    /* Form masks for exponent/fraction/sign  */
2322    one = gfc_build_const (masktype, integer_one_node);
2323    rcs->smask = fold (build (LSHIFT_EXPR, masktype, one, wbits));
2324    rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2325    rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2326    rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one));
2327    /* Form bias.  */
2328    tmp = fold (build (MINUS_EXPR, masktype, rcs->edigits, one));
2329    tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp));
2330    rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one));
2331
2332    if (all)
2333    {
2334      /* exponent, and fraction  */
2335      tmp = build (BIT_AND_EXPR, masktype, arg, rcs->emask);
2336      tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2337      exponent = gfc_create_var (masktype, "exponent");
2338      gfc_add_modify_expr(&se->pre, exponent, tmp);
2339      rcs->expn = exponent;
2340
2341      tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2342      fraction = gfc_create_var (masktype, "fraction");
2343      gfc_add_modify_expr(&se->pre, fraction, tmp);
2344      rcs->frac = fraction;
2345   }
2346 }
2347
2348 /* Build a call to __builtin_clz.  */
2349
2350 static tree
2351 call_builtin_clz (tree result_type, tree op0)
2352 {
2353   tree fn, parms, call;
2354   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2355
2356   if (op0_mode == TYPE_MODE (integer_type_node))
2357     fn = built_in_decls[BUILT_IN_CLZ];
2358   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2359     fn = built_in_decls[BUILT_IN_CLZL];
2360   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2361     fn = built_in_decls[BUILT_IN_CLZLL];
2362   else
2363     abort ();
2364
2365   parms = tree_cons (NULL, op0, NULL);
2366   call = gfc_build_function_call (fn, parms);
2367
2368   return convert (result_type, call);
2369 }
2370
2371 /* Generate code for SPACING (X) intrinsic function. We generate:
2372
2373     t = expn - (BITS_OF_FRACTION)
2374     res = t << (BITS_OF_FRACTION)
2375     if (t < 0)
2376       res = tiny(X)
2377 */
2378
2379 static void
2380 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2381 {
2382    tree arg;
2383    tree masktype;
2384    tree tmp, t1, cond;
2385    tree tiny, zero;
2386    tree fdigits;
2387    real_compnt_info rcs;
2388
2389    prepare_arg_info (se, expr, &rcs, 0);
2390    arg = rcs.arg;
2391    masktype = rcs.mtype;
2392    fdigits = rcs.fdigits;
2393    tiny = rcs.f1;
2394    zero = gfc_build_const (masktype, integer_zero_node);
2395    tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg);
2396    tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits);
2397    tmp = build (MINUS_EXPR, masktype, tmp, fdigits);
2398    cond = build (LE_EXPR, boolean_type_node, tmp, zero);
2399    t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2400    tmp = build (COND_EXPR, masktype, cond, tiny, t1);
2401    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2402
2403    se->expr = tmp;
2404 }
2405
2406 /* Generate code for RRSPACING (X) intrinsic function. We generate:
2407
2408     if (expn == 0 && frac == 0)
2409        res = 0;
2410     else
2411     {
2412        sedigits = edigits + 1;
2413        if (expn == 0)
2414        {
2415          t1 = leadzero (frac);
2416          frac = frac << (t1 + sedigits);
2417          frac = frac >> (sedigits);
2418        }
2419        t = bias + BITS_OF_FRACTION_OF;
2420        res = (t << BITS_OF_FRACTION_OF) | frac;
2421 */
2422
2423 static void
2424 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2425 {
2426    tree masktype;
2427    tree tmp, t1, t2, cond, cond2;
2428    tree one, zero;
2429    tree fdigits, fraction;
2430    real_compnt_info rcs;
2431
2432    prepare_arg_info (se, expr, &rcs, 1);
2433    masktype = rcs.mtype;
2434    fdigits = rcs.fdigits;
2435    fraction = rcs.frac;
2436    one = gfc_build_const (masktype, integer_one_node);
2437    zero = gfc_build_const (masktype, integer_zero_node);
2438    t2 = build (PLUS_EXPR, masktype, rcs.edigits, one);
2439
2440    t1 = call_builtin_clz (masktype, fraction);
2441    tmp = build (PLUS_EXPR, masktype, t1, one);
2442    tmp = build (LSHIFT_EXPR, masktype, fraction, tmp);
2443    tmp = build (RSHIFT_EXPR, masktype, tmp, t2);
2444    cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2445    fraction = build (COND_EXPR, masktype, cond, tmp, fraction);
2446
2447    tmp = build (PLUS_EXPR, masktype, rcs.bias, fdigits);
2448    tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2449    tmp = build (BIT_IOR_EXPR, masktype, tmp, fraction);
2450
2451    cond2 = build (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2452    cond = build (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2453    tmp = build (COND_EXPR, masktype, cond, integer_zero_node, tmp);
2454
2455    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2456    se->expr = tmp;
2457 }
2458
2459 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2460
2461 static void
2462 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2463 {
2464   tree args;
2465
2466   args = gfc_conv_intrinsic_function_args (se, expr);
2467   args = TREE_VALUE (args);
2468   args = gfc_build_addr_expr (NULL, args);
2469   args = tree_cons (NULL_TREE, args, NULL_TREE);
2470   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2471 }
2472
2473 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2474
2475 static void
2476 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2477 {
2478   gfc_actual_arglist *actual;
2479   tree args;
2480   gfc_se argse;
2481
2482   args = NULL_TREE;
2483   for (actual = expr->value.function.actual; actual; actual = actual->next)
2484     {
2485       gfc_init_se (&argse, se);
2486
2487       /* Pass a NULL pointer for an absent arg.  */
2488       if (actual->expr == NULL)
2489         argse.expr = null_pointer_node;
2490       else
2491         gfc_conv_expr_reference (&argse, actual->expr);
2492
2493       gfc_add_block_to_block (&se->pre, &argse.pre);
2494       gfc_add_block_to_block (&se->post, &argse.post);
2495       args = gfc_chainon_list (args, argse.expr);
2496     }
2497   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2498 }
2499
2500
2501 /* Generate code for TRIM (A) intrinsic function.  */
2502
2503 static void
2504 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2505 {
2506   tree var;
2507   tree len;
2508   tree addr;
2509   tree tmp;
2510   tree arglist;
2511   tree type;
2512   tree cond;
2513
2514   arglist = NULL_TREE;
2515
2516   type = build_pointer_type (gfc_character1_type_node);
2517   var = gfc_create_var (type, "pstr");
2518   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2519   len = gfc_create_var (gfc_int4_type_node, "len");
2520
2521   tmp = gfc_conv_intrinsic_function_args (se, expr);
2522   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2523   arglist = gfc_chainon_list (arglist, addr);
2524   arglist = chainon (arglist, tmp);
2525
2526   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2527   gfc_add_expr_to_block (&se->pre, tmp);
2528
2529   /* Free the temporary afterwards, if necessary.  */
2530   cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
2531   arglist = gfc_chainon_list (NULL_TREE, var);
2532   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2533   tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2534   gfc_add_expr_to_block (&se->post, tmp);
2535
2536   se->expr = var;
2537   se->string_length = len;
2538 }
2539
2540
2541 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2542
2543 static void
2544 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2545 {
2546   tree tmp;
2547   tree len;
2548   tree args;
2549   tree arglist;
2550   tree ncopies;
2551   tree var;
2552   tree type;
2553
2554   args = gfc_conv_intrinsic_function_args (se, expr);
2555   len = TREE_VALUE (args);
2556   tmp = gfc_advance_chain (args, 2);
2557   ncopies = TREE_VALUE (tmp);
2558   len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2559   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2560   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2561
2562   arglist = NULL_TREE;
2563   arglist = gfc_chainon_list (arglist, var);
2564   arglist = chainon (arglist, args);
2565   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2566   gfc_add_expr_to_block (&se->pre, tmp);
2567
2568   se->expr = var;
2569   se->string_length = len;
2570 }
2571
2572
2573 /* Generate code for an intrinsic function.  Some map directly to library
2574    calls, others get special handling.  In some cases the name of the function
2575    used depends on the type specifiers.  */
2576
2577 void
2578 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2579 {
2580   gfc_intrinsic_sym *isym;
2581   char *name;
2582   int lib;
2583
2584   isym = expr->value.function.isym;
2585
2586   name = &expr->value.function.name[2];
2587
2588   if (expr->rank > 0)
2589     {
2590       lib = gfc_is_intrinsic_libcall (expr);
2591       if (lib != 0)
2592         {
2593           if (lib == 1)
2594             se->ignore_optional = 1;
2595           gfc_conv_intrinsic_funcall (se, expr);
2596           return;
2597         }
2598     }
2599
2600   switch (expr->value.function.isym->generic_id)
2601     {
2602     case GFC_ISYM_NONE:
2603       abort ();
2604
2605     case GFC_ISYM_REPEAT:
2606       gfc_conv_intrinsic_repeat (se, expr);
2607       break;
2608
2609     case GFC_ISYM_TRIM:
2610       gfc_conv_intrinsic_trim (se, expr);
2611       break;
2612
2613     case GFC_ISYM_SI_KIND:
2614       gfc_conv_intrinsic_si_kind (se, expr);
2615       break;
2616
2617     case GFC_ISYM_SR_KIND:
2618       gfc_conv_intrinsic_sr_kind (se, expr);
2619       break;
2620
2621     case GFC_ISYM_EXPONENT:
2622       gfc_conv_intrinsic_exponent (se, expr);
2623       break;
2624
2625     case GFC_ISYM_SPACING:
2626       gfc_conv_intrinsic_spacing (se, expr);
2627       break;
2628
2629     case GFC_ISYM_RRSPACING:
2630       gfc_conv_intrinsic_rrspacing (se, expr);
2631       break;
2632
2633     case GFC_ISYM_SCAN:
2634       gfc_conv_intrinsic_scan (se, expr);
2635       break;
2636
2637     case GFC_ISYM_VERIFY:
2638       gfc_conv_intrinsic_verify (se, expr);
2639       break;
2640
2641     case GFC_ISYM_ALLOCATED:
2642       gfc_conv_allocated (se, expr);
2643       break;
2644
2645     case GFC_ISYM_ASSOCIATED:
2646       gfc_conv_associated(se, expr);
2647       break;
2648
2649     case GFC_ISYM_ABS:
2650       gfc_conv_intrinsic_abs (se, expr);
2651       break;
2652
2653     case GFC_ISYM_ADJUSTL:
2654       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2655       break;
2656
2657     case GFC_ISYM_ADJUSTR:
2658       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2659       break;
2660
2661     case GFC_ISYM_AIMAG:
2662       gfc_conv_intrinsic_imagpart (se, expr);
2663       break;
2664
2665     case GFC_ISYM_AINT:
2666       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2667       break;
2668
2669     case GFC_ISYM_ALL:
2670       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2671       break;
2672
2673     case GFC_ISYM_ANINT:
2674       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2675       break;
2676
2677     case GFC_ISYM_ANY:
2678       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2679       break;
2680
2681     case GFC_ISYM_BTEST:
2682       gfc_conv_intrinsic_btest (se, expr);
2683       break;
2684
2685     case GFC_ISYM_ACHAR:
2686     case GFC_ISYM_CHAR:
2687       gfc_conv_intrinsic_char (se, expr);
2688       break;
2689
2690     case GFC_ISYM_CONVERSION:
2691     case GFC_ISYM_REAL:
2692     case GFC_ISYM_LOGICAL:
2693     case GFC_ISYM_DBLE:
2694       gfc_conv_intrinsic_conversion (se, expr);
2695       break;
2696
2697       /* Integer conversions are handled seperately to make sure we get the
2698          correct rounding mode.  */
2699     case GFC_ISYM_INT:
2700       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2701       break;
2702
2703     case GFC_ISYM_NINT:
2704       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2705       break;
2706
2707     case GFC_ISYM_CEILING:
2708       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2709       break;
2710
2711     case GFC_ISYM_FLOOR:
2712       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2713       break;
2714
2715     case GFC_ISYM_MOD:
2716       gfc_conv_intrinsic_mod (se, expr, 0);
2717       break;
2718
2719     case GFC_ISYM_MODULO:
2720       gfc_conv_intrinsic_mod (se, expr, 1);
2721       break;
2722
2723     case GFC_ISYM_CMPLX:
2724       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2725       break;
2726
2727     case GFC_ISYM_CONJG:
2728       gfc_conv_intrinsic_conjg (se, expr);
2729       break;
2730
2731     case GFC_ISYM_COUNT:
2732       gfc_conv_intrinsic_count (se, expr);
2733       break;
2734
2735     case GFC_ISYM_DIM:
2736       gfc_conv_intrinsic_dim (se, expr);
2737       break;
2738
2739     case GFC_ISYM_DPROD:
2740       gfc_conv_intrinsic_dprod (se, expr);
2741       break;
2742
2743     case GFC_ISYM_IAND:
2744       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2745       break;
2746
2747     case GFC_ISYM_IBCLR:
2748       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2749       break;
2750
2751     case GFC_ISYM_IBITS:
2752       gfc_conv_intrinsic_ibits (se, expr);
2753       break;
2754
2755     case GFC_ISYM_IBSET:
2756       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2757       break;
2758
2759     case GFC_ISYM_IACHAR:
2760     case GFC_ISYM_ICHAR:
2761       /* We assume ASCII character sequence.  */
2762       gfc_conv_intrinsic_ichar (se, expr);
2763       break;
2764
2765     case GFC_ISYM_IEOR:
2766       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2767       break;
2768
2769     case GFC_ISYM_INDEX:
2770       gfc_conv_intrinsic_index (se, expr);
2771       break;
2772
2773     case GFC_ISYM_IOR:
2774       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2775       break;
2776
2777     case GFC_ISYM_ISHFT:
2778       gfc_conv_intrinsic_ishft (se, expr);
2779       break;
2780
2781     case GFC_ISYM_ISHFTC:
2782       gfc_conv_intrinsic_ishftc (se, expr);
2783       break;
2784
2785     case GFC_ISYM_LBOUND:
2786       gfc_conv_intrinsic_bound (se, expr, 0);
2787       break;
2788
2789     case GFC_ISYM_LEN:
2790       gfc_conv_intrinsic_len (se, expr);
2791       break;
2792
2793     case GFC_ISYM_LEN_TRIM:
2794       gfc_conv_intrinsic_len_trim (se, expr);
2795       break;
2796
2797     case GFC_ISYM_LGE:
2798       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2799       break;
2800
2801     case GFC_ISYM_LGT:
2802       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2803       break;
2804
2805     case GFC_ISYM_LLE:
2806       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2807       break;
2808
2809     case GFC_ISYM_LLT:
2810       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2811       break;
2812
2813     case GFC_ISYM_MAX:
2814       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2815       break;
2816
2817     case GFC_ISYM_MAXLOC:
2818       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2819       break;
2820
2821     case GFC_ISYM_MAXVAL:
2822       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2823       break;
2824
2825     case GFC_ISYM_MERGE:
2826       gfc_conv_intrinsic_merge (se, expr);
2827       break;
2828
2829     case GFC_ISYM_MIN:
2830       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2831       break;
2832
2833     case GFC_ISYM_MINLOC:
2834       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2835       break;
2836
2837     case GFC_ISYM_MINVAL:
2838       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2839       break;
2840
2841     case GFC_ISYM_NOT:
2842       gfc_conv_intrinsic_not (se, expr);
2843       break;
2844
2845     case GFC_ISYM_PRESENT:
2846       gfc_conv_intrinsic_present (se, expr);
2847       break;
2848
2849     case GFC_ISYM_PRODUCT:
2850       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2851       break;
2852
2853     case GFC_ISYM_SIGN:
2854       gfc_conv_intrinsic_sign (se, expr);
2855       break;
2856
2857     case GFC_ISYM_SIZE:
2858       gfc_conv_intrinsic_size (se, expr);
2859       break;
2860
2861     case GFC_ISYM_SUM:
2862       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2863       break;
2864
2865     case GFC_ISYM_TRANSFER:
2866       gfc_conv_intrinsic_transfer (se, expr);
2867       break;
2868
2869     case GFC_ISYM_UBOUND:
2870       gfc_conv_intrinsic_bound (se, expr, 1);
2871       break;
2872
2873     case GFC_ISYM_DOT_PRODUCT:
2874     case GFC_ISYM_MATMUL:
2875     case GFC_ISYM_IRAND:
2876     case GFC_ISYM_RAND:
2877     case GFC_ISYM_ETIME:
2878     case GFC_ISYM_SECOND:
2879       gfc_conv_intrinsic_funcall (se, expr);
2880       break;
2881
2882     default:
2883       gfc_conv_intrinsic_lib_function (se, expr);
2884       break;
2885     }
2886 }
2887
2888
2889 /* This generates code to execute before entering the scalarization loop.
2890    Currently does nothing.  */
2891
2892 void
2893 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
2894 {
2895   switch (ss->expr->value.function.isym->generic_id)
2896     {
2897     case GFC_ISYM_UBOUND:
2898     case GFC_ISYM_LBOUND:
2899       break;
2900
2901     default:
2902       abort ();
2903       break;
2904     }
2905 }
2906
2907
2908 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
2909    inside the scalarization loop.  */
2910
2911 static gfc_ss *
2912 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
2913 {
2914   gfc_ss *newss;
2915
2916   /* The two argument version returns a scalar.  */
2917   if (expr->value.function.actual->next->expr)
2918     return ss;
2919
2920   newss = gfc_get_ss ();
2921   newss->type = GFC_SS_INTRINSIC;
2922   newss->expr = expr;
2923   newss->next = ss;
2924
2925   return newss;
2926 }
2927
2928
2929 /* Walk an intrinsic array libcall.  */
2930
2931 static gfc_ss *
2932 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
2933 {
2934   gfc_ss *newss;
2935
2936   assert (expr->rank > 0);
2937
2938   newss = gfc_get_ss ();
2939   newss->type = GFC_SS_FUNCTION;
2940   newss->expr = expr;
2941   newss->next = ss;
2942   newss->data.info.dimen = expr->rank;
2943
2944   return newss;
2945 }
2946
2947
2948 /* Returns nonzero if the specified intrinsic function call maps directly to a
2949    an external library call.  Should only be used for functions that return
2950    arrays.  */
2951
2952 int
2953 gfc_is_intrinsic_libcall (gfc_expr * expr)
2954 {
2955   assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
2956   assert (expr->rank > 0);
2957
2958   switch (expr->value.function.isym->generic_id)
2959     {
2960     case GFC_ISYM_ALL:
2961     case GFC_ISYM_ANY:
2962     case GFC_ISYM_COUNT:
2963     case GFC_ISYM_MATMUL:
2964     case GFC_ISYM_MAXLOC:
2965     case GFC_ISYM_MAXVAL:
2966     case GFC_ISYM_MINLOC:
2967     case GFC_ISYM_MINVAL:
2968     case GFC_ISYM_PRODUCT:
2969     case GFC_ISYM_SUM:
2970     case GFC_ISYM_SHAPE:
2971     case GFC_ISYM_SPREAD:
2972     case GFC_ISYM_TRANSPOSE:
2973       /* Ignore absent optional parameters.  */
2974       return 1;
2975
2976     case GFC_ISYM_RESHAPE:
2977     case GFC_ISYM_CSHIFT:
2978     case GFC_ISYM_EOSHIFT:
2979     case GFC_ISYM_PACK:
2980     case GFC_ISYM_UNPACK:
2981       /* Pass absent optional parameters.  */
2982       return 2;
2983
2984     default:
2985       return 0;
2986     }
2987 }
2988
2989 /* Walk an intrinsic function.  */
2990 gfc_ss *
2991 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
2992                              gfc_intrinsic_sym * isym)
2993 {
2994   assert (isym);
2995
2996   if (isym->elemental)
2997     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
2998
2999   if (expr->rank == 0)
3000     return ss;
3001
3002   if (gfc_is_intrinsic_libcall (expr))
3003     return gfc_walk_intrinsic_libfunc (ss, expr);
3004
3005   /* Special cases.  */
3006   switch (isym->generic_id)
3007     {
3008     case GFC_ISYM_LBOUND:
3009     case GFC_ISYM_UBOUND:
3010       return gfc_walk_intrinsic_bound (ss, expr);
3011
3012     default:
3013       /* This probably meant someone forgot to add an intrinsic to the above
3014          list(s) when they implemented it, or something's gone horribly wrong.
3015        */
3016       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3017                       expr->value.function.name);
3018     }
3019 }
3020
3021 #include "gt-fortran-trans-intrinsic.h"