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 GNU G95.
   7
   8 GNU G95 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU G95 is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU G95; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330,
  21 Boston, MA 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-simple.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 && arg->ref == NULL)
1878           {
1879             sym = arg->symtree->n.sym;
1880             decl = gfc_get_symbol_decl (sym);
1881             if (decl == current_function_decl && sym->attr.function
1882                 && (sym->result == sym))
1883               decl = gfc_get_fake_result_decl (sym);
1884
1885             len = sym->ts.cl->backend_decl;
1886             assert (len);
1887           }
1888         else
1889           {
1890             /* Anybody stupid enough to do this deserves inefficient code.  */
1891             gfc_init_se (&argse, se);
1892             gfc_conv_expr (&argse, arg);
1893             gfc_add_block_to_block (&se->pre, &argse.pre);
1894             gfc_add_block_to_block (&se->post, &argse.post);
1895             len = argse.string_length;
1896         }
1897       break;
1898     }
1899   se->expr = convert (type, len);
1900 }
1901
1902 /* The length of a character string not including trailing blanks.  */
1903 static void
1904 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1905 {
1906   tree args;
1907   tree type;
1908
1909   args = gfc_conv_intrinsic_function_args (se, expr);
1910   type = gfc_typenode_for_spec (&expr->ts);
1911   se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1912   se->expr = convert (type, se->expr);
1913 }
1914
1915
1916 /* Returns the starting position of a substring within a string.  */
1917
1918 static void
1919 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1920 {
1921   tree args;
1922   tree back;
1923   tree type;
1924   tree tmp;
1925
1926   args = gfc_conv_intrinsic_function_args (se, expr);
1927   type = gfc_typenode_for_spec (&expr->ts);
1928   tmp = gfc_advance_chain (args, 3);
1929   if (TREE_CHAIN (tmp) == NULL_TREE)
1930     {
1931       back = convert (gfc_logical4_type_node, integer_one_node);
1932       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1933       TREE_CHAIN (tmp) = back;
1934     }
1935   else
1936     {
1937       back = TREE_CHAIN (tmp);
1938       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1939     }
1940
1941   se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1942   se->expr = convert (type, se->expr);
1943 }
1944
1945 /* The ascii value for a single character.  */
1946 static void
1947 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
1948 {
1949   tree arg;
1950   tree type;
1951
1952   arg = gfc_conv_intrinsic_function_args (se, expr);
1953   arg = TREE_VALUE (TREE_CHAIN (arg));
1954   assert (POINTER_TYPE_P (TREE_TYPE (arg)));
1955   arg = build1 (NOP_EXPR, pchar_type_node, arg);
1956   type = gfc_typenode_for_spec (&expr->ts);
1957
1958   se->expr = gfc_build_indirect_ref (arg);
1959   se->expr = convert (type, se->expr);
1960 }
1961
1962
1963 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
1964
1965 static void
1966 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
1967 {
1968   tree arg;
1969   tree tsource;
1970   tree fsource;
1971   tree mask;
1972   tree type;
1973
1974   arg = gfc_conv_intrinsic_function_args (se, expr);
1975   tsource = TREE_VALUE (arg);
1976   arg = TREE_CHAIN (arg);
1977   fsource = TREE_VALUE (arg);
1978   arg = TREE_CHAIN (arg);
1979   mask = TREE_VALUE (arg);
1980
1981   type = TREE_TYPE (tsource);
1982   se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource));
1983 }
1984
1985
1986 static void
1987 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
1988 {
1989   gfc_actual_arglist *actual;
1990   tree args;
1991   tree type;
1992   tree fndecl;
1993   gfc_se argse;
1994   gfc_ss *ss;
1995
1996   gfc_init_se (&argse, NULL);
1997   actual = expr->value.function.actual;
1998
1999   ss = gfc_walk_expr (actual->expr);
2000   assert (ss != gfc_ss_terminator);
2001   argse.want_pointer = 1;
2002   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2003   gfc_add_block_to_block (&se->pre, &argse.pre);
2004   gfc_add_block_to_block (&se->post, &argse.post);
2005   args = gfc_chainon_list (NULL_TREE, argse.expr);
2006
2007   actual = actual->next;
2008   if (actual->expr)
2009     {
2010       gfc_init_se (&argse, NULL);
2011       gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2012       gfc_add_block_to_block (&se->pre, &argse.pre);
2013       args = gfc_chainon_list (args, argse.expr);
2014       fndecl = gfor_fndecl_size1;
2015     }
2016   else
2017     fndecl = gfor_fndecl_size0;
2018
2019   se->expr = gfc_build_function_call (fndecl, args);
2020   type = gfc_typenode_for_spec (&expr->ts);
2021   se->expr = convert (type, se->expr);
2022 }
2023
2024
2025 /* Intrinsic string comparison functions.  */
2026
2027   static void
2028 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2029 {
2030   tree type;
2031   tree args;
2032
2033   args = gfc_conv_intrinsic_function_args (se, expr);
2034   /* Build a call for the comparison.  */
2035   se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2036
2037   type = gfc_typenode_for_spec (&expr->ts);
2038   se->expr = build (op, type, se->expr, integer_zero_node);
2039 }
2040
2041 /* Generate a call to the adjustl/adjustr library function.  */
2042 static void
2043 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2044 {
2045   tree args;
2046   tree len;
2047   tree type;
2048   tree var;
2049   tree tmp;
2050
2051   args = gfc_conv_intrinsic_function_args (se, expr);
2052   len = TREE_VALUE (args);
2053
2054   type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2055   var = gfc_conv_string_tmp (se, type, len);
2056   args = tree_cons (NULL_TREE, var, args);
2057
2058   tmp = gfc_build_function_call (fndecl, args);
2059   gfc_add_expr_to_block (&se->pre, tmp);
2060   se->expr = var;
2061   se->string_length = len;
2062 }
2063
2064
2065 /* Scalar transfer statement.
2066    TRANSFER (source, mold) = *(typeof<mould> *)&source  */
2067
2068 static void
2069 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2070 {
2071   gfc_actual_arglist *arg;
2072   gfc_se argse;
2073   tree type;
2074   tree ptr;
2075   gfc_ss *ss;
2076
2077   assert (!se->ss);
2078
2079   /* Get a pointer to the source.  */
2080   arg = expr->value.function.actual;
2081   ss = gfc_walk_expr (arg->expr);
2082   gfc_init_se (&argse, NULL);
2083   if (ss == gfc_ss_terminator)
2084     gfc_conv_expr_reference (&argse, arg->expr);
2085   else
2086     gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2087   gfc_add_block_to_block (&se->pre, &argse.pre);
2088   gfc_add_block_to_block (&se->post, &argse.post);
2089   ptr = argse.expr;
2090
2091   arg = arg->next;
2092   type = gfc_typenode_for_spec (&expr->ts);
2093   ptr = convert (build_pointer_type (type), ptr);
2094   if (expr->ts.type == BT_CHARACTER)
2095     {
2096       gfc_init_se (&argse, NULL);
2097       gfc_conv_expr (&argse, arg->expr);
2098       gfc_add_block_to_block (&se->pre, &argse.pre);
2099       gfc_add_block_to_block (&se->post, &argse.post);
2100       se->expr = ptr;
2101       se->string_length = argse.string_length;
2102     }
2103   else
2104     {
2105       se->expr = gfc_build_indirect_ref (ptr);
2106     }
2107 }
2108
2109
2110 /* Generate code for the ALLOCATED intrinsic.
2111    Generate inline code that directly check the address of the argument.  */
2112
2113 static void
2114 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2115 {
2116   gfc_actual_arglist *arg1;
2117   gfc_se arg1se;
2118   gfc_ss *ss1;
2119   tree tmp;
2120
2121   gfc_init_se (&arg1se, NULL);
2122   arg1 = expr->value.function.actual;
2123   ss1 = gfc_walk_expr (arg1->expr);
2124   arg1se.descriptor_only = 1;
2125   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2126
2127   tmp = gfc_conv_descriptor_data (arg1se.expr);
2128   tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
2129   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2130 }
2131
2132
2133 /* Generate code for the ASSOCIATED intrinsic.
2134    If both POINTER and TARGET are arrays, generate a call to library function
2135    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2136    In other cases, generate inline code that directly compare the address of
2137    POINTER with the address of TARGET.  */
2138
2139 static void
2140 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2141 {
2142   gfc_actual_arglist *arg1;
2143   gfc_actual_arglist *arg2;
2144   gfc_se arg1se;
2145   gfc_se arg2se;
2146   tree tmp2;
2147   tree tmp;
2148   tree args, fndecl;
2149   gfc_ss *ss1, *ss2;
2150
2151   gfc_init_se (&arg1se, NULL);
2152   gfc_init_se (&arg2se, NULL);
2153   arg1 = expr->value.function.actual;
2154   arg2 = arg1->next;
2155   ss1 = gfc_walk_expr (arg1->expr);
2156
2157   if (!arg2->expr)
2158     {
2159       /* No optional target.  */
2160       if (ss1 == gfc_ss_terminator)
2161         {
2162           /* A pointer to a scalar.  */
2163           arg1se.want_pointer = 1;
2164           gfc_conv_expr (&arg1se, arg1->expr);
2165           tmp2 = arg1se.expr;
2166         }
2167       else
2168         {
2169           /* A pointer to an array.  */
2170           arg1se.descriptor_only = 1;
2171           gfc_conv_expr_lhs (&arg1se, arg1->expr);
2172           tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2173         }
2174       tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
2175       se->expr = tmp;
2176     }
2177   else
2178     {
2179       /* An optional target.  */
2180       ss2 = gfc_walk_expr (arg2->expr);
2181       if (ss1 == gfc_ss_terminator)
2182         {
2183           /* A pointer to a scalar.  */
2184           assert (ss2 == gfc_ss_terminator);
2185           arg1se.want_pointer = 1;
2186           gfc_conv_expr (&arg1se, arg1->expr);
2187           arg2se.want_pointer = 1;
2188           gfc_conv_expr (&arg2se, arg2->expr);
2189           tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2190           se->expr = tmp;
2191         }
2192       else
2193         {
2194           /* A pointer to an array, call library function _gfor_associated.  */
2195           assert (ss2 != gfc_ss_terminator);
2196           args = NULL_TREE;
2197           arg1se.want_pointer = 1;
2198           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2199           args = gfc_chainon_list (args, arg1se.expr);
2200           arg2se.want_pointer = 1;
2201           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2202           gfc_add_block_to_block (&se->pre, &arg2se.pre);
2203           gfc_add_block_to_block (&se->post, &arg2se.post);
2204           args = gfc_chainon_list (args, arg2se.expr);
2205           fndecl = gfor_fndecl_associated;
2206           se->expr = gfc_build_function_call (fndecl, args);
2207         }
2208      }
2209   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2210 }
2211
2212
2213 /* Scan a string for any one of the characters in a set of characters.   */
2214
2215 static void
2216 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2217 {
2218   tree args;
2219   tree back;
2220   tree type;
2221   tree tmp;
2222
2223   args = gfc_conv_intrinsic_function_args (se, expr);
2224   type = gfc_typenode_for_spec (&expr->ts);
2225   tmp = gfc_advance_chain (args, 3);
2226   if (TREE_CHAIN (tmp) == NULL_TREE)
2227     {
2228       back = convert (gfc_logical4_type_node, integer_one_node);
2229       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2230       TREE_CHAIN (tmp) = back;
2231     }
2232   else
2233     {
2234       back = TREE_CHAIN (tmp);
2235       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2236     }
2237
2238   se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2239   se->expr = convert (type, se->expr);
2240 }
2241
2242
2243 /* Verify that a set of characters contains all the characters in a string
2244    by indentifying the position of the first character in a string of
2245    characters that does not appear in a given set of characters.  */
2246
2247 static void
2248 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2249 {
2250   tree args;
2251   tree back;
2252   tree type;
2253   tree tmp;
2254
2255   args = gfc_conv_intrinsic_function_args (se, expr);
2256   type = gfc_typenode_for_spec (&expr->ts);
2257   tmp = gfc_advance_chain (args, 3);
2258   if (TREE_CHAIN (tmp) == NULL_TREE)
2259     {
2260       back = convert (gfc_logical4_type_node, integer_one_node);
2261       back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2262       TREE_CHAIN (tmp) = back;
2263     }
2264   else
2265     {
2266       back = TREE_CHAIN (tmp);
2267       TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2268     }
2269
2270   se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2271   se->expr = convert (type, se->expr);
2272 }
2273
2274 /* Prepare components and related information of a real number which is
2275    the first argument of a elemental functions to manipulate reals.  */
2276
2277 static
2278 void prepare_arg_info (gfc_se * se, gfc_expr * expr,
2279                        real_compnt_info * rcs, int all)
2280 {
2281    tree arg;
2282    tree masktype;
2283    tree tmp;
2284    tree wbits;
2285    tree one;
2286    tree exponent, fraction;
2287    int n;
2288    gfc_expr *a1;
2289
2290    if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2291      gfc_todo_error ("Non-IEEE floating format");
2292
2293    assert (expr->expr_type == EXPR_FUNCTION);
2294
2295    arg = gfc_conv_intrinsic_function_args (se, expr);
2296    arg = TREE_VALUE (arg);
2297    rcs->type = TREE_TYPE (arg);
2298
2299    /* Force arg'type to integer by unaffected convert  */
2300    a1 = expr->value.function.actual->expr;
2301    masktype = gfc_get_int_type (a1->ts.kind);
2302    rcs->mtype = masktype;
2303    tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2304    arg = gfc_create_var (masktype, "arg");
2305    gfc_add_modify_expr(&se->pre, arg, tmp);
2306    rcs->arg = arg;
2307
2308    /* Caculate the numbers of bits of exponent, fraction and word  */
2309    n = gfc_validate_kind (a1->ts.type, a1->ts.kind);
2310    tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0);
2311    rcs->fdigits = convert (masktype, tmp);
2312    wbits = build_int_2 (TYPE_PRECISION (rcs->type) - 1, 0);
2313    wbits = convert (masktype, wbits);
2314    rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp));
2315
2316    /* Form masks for exponent/fraction/sign  */
2317    one = gfc_build_const (masktype, integer_one_node);
2318    rcs->smask = fold (build (LSHIFT_EXPR, masktype, one, wbits));
2319    rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2320    rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2321    rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one));
2322    /* Form bias.  */
2323    tmp = fold (build (MINUS_EXPR, masktype, rcs->edigits, one));
2324    tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp));
2325    rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one));
2326
2327    if (all)
2328    {
2329      /* exponent, and fraction  */
2330      tmp = build (BIT_AND_EXPR, masktype, arg, rcs->emask);
2331      tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2332      exponent = gfc_create_var (masktype, "exponent");
2333      gfc_add_modify_expr(&se->pre, exponent, tmp);
2334      rcs->expn = exponent;
2335
2336      tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2337      fraction = gfc_create_var (masktype, "fraction");
2338      gfc_add_modify_expr(&se->pre, fraction, tmp);
2339      rcs->frac = fraction;
2340   }
2341 }
2342
2343 /* Build a call to __builtin_clz.  */
2344
2345 static tree
2346 call_builtin_clz (tree result_type, tree op0)
2347 {
2348   tree fn, parms, call;
2349   enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2350
2351   if (op0_mode == TYPE_MODE (integer_type_node))
2352     fn = built_in_decls[BUILT_IN_CLZ];
2353   else if (op0_mode == TYPE_MODE (long_integer_type_node))
2354     fn = built_in_decls[BUILT_IN_CLZL];
2355   else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2356     fn = built_in_decls[BUILT_IN_CLZLL];
2357   else
2358     abort ();
2359
2360   parms = tree_cons (NULL, op0, NULL);
2361   call = gfc_build_function_call (fn, parms);
2362
2363   return convert (result_type, call);
2364 }
2365
2366 /* Generate code for SPACING (X) intrinsic function. We generate:
2367
2368     t = expn - (BITS_OF_FRACTION)
2369     res = t << (BITS_OF_FRACTION)
2370     if (t < 0)
2371       res = tiny(X)
2372 */
2373
2374 static void
2375 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2376 {
2377    tree arg;
2378    tree masktype;
2379    tree tmp, t1, cond;
2380    tree tiny, zero;
2381    tree fdigits;
2382    real_compnt_info rcs;
2383
2384    prepare_arg_info (se, expr, &rcs, 0);
2385    arg = rcs.arg;
2386    masktype = rcs.mtype;
2387    fdigits = rcs.fdigits;
2388    tiny = rcs.f1;
2389    zero = gfc_build_const (masktype, integer_zero_node);
2390    tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg);
2391    tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits);
2392    tmp = build (MINUS_EXPR, masktype, tmp, fdigits);
2393    cond = build (LE_EXPR, boolean_type_node, tmp, zero);
2394    t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2395    tmp = build (COND_EXPR, masktype, cond, tiny, t1);
2396    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2397
2398    se->expr = tmp;
2399 }
2400
2401 /* Generate code for RRSPACING (X) intrinsic function. We generate:
2402     sedigits = edigits + 1;
2403     if (expn == 0)
2404     {
2405       t1 = leadzero (frac);
2406       frac = frac << (t1 + sedigits);
2407       frac = frac >> (sedigits);
2408     }
2409     t = bias + BITS_OF_FRACTION_OF;
2410     res = (t << BITS_OF_FRACTION_OF) | frac;
2411 */
2412
2413 static void
2414 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2415 {
2416    tree masktype;
2417    tree tmp, t1, t2, cond;
2418    tree one, zero;
2419    tree fdigits, fraction;
2420    real_compnt_info rcs;
2421
2422    prepare_arg_info (se, expr, &rcs, 1);
2423    masktype = rcs.mtype;
2424    fdigits = rcs.fdigits;
2425    fraction = rcs.frac;
2426    one = gfc_build_const (masktype, integer_one_node);
2427    zero = gfc_build_const (masktype, integer_zero_node);
2428    t2 = build (PLUS_EXPR, masktype, rcs.edigits, one);
2429
2430    t1 = call_builtin_clz (masktype, fraction);
2431    tmp = build (PLUS_EXPR, masktype, t1, one);
2432    tmp = build (LSHIFT_EXPR, masktype, fraction, tmp);
2433    tmp = build (RSHIFT_EXPR, masktype, tmp, t2);
2434    cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2435    fraction = build (COND_EXPR, masktype, cond, tmp, fraction);
2436
2437    tmp = build (PLUS_EXPR, masktype, rcs.bias, fdigits);
2438    tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits);
2439    tmp = build (BIT_IOR_EXPR, masktype, tmp, fraction);
2440
2441    tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2442    se->expr = tmp;
2443 }
2444
2445 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
2446
2447 static void
2448 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2449 {
2450   tree args;
2451
2452   args = gfc_conv_intrinsic_function_args (se, expr);
2453   args = TREE_VALUE (args);
2454   args = gfc_build_addr_expr (NULL, args);
2455   args = tree_cons (NULL_TREE, args, NULL_TREE);
2456   se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2457 }
2458
2459 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
2460
2461 static void
2462 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2463 {
2464   gfc_actual_arglist *actual;
2465   tree args;
2466   gfc_se argse;
2467
2468   args = NULL_TREE;
2469   for (actual = expr->value.function.actual; actual; actual = actual->next)
2470     {
2471       gfc_init_se (&argse, se);
2472
2473       /* Pass a NULL pointer for an absent arg.  */
2474       if (actual->expr == NULL)
2475         argse.expr = null_pointer_node;
2476       else
2477         gfc_conv_expr_reference (&argse, actual->expr);
2478
2479       gfc_add_block_to_block (&se->pre, &argse.pre);
2480       gfc_add_block_to_block (&se->post, &argse.post);
2481       args = gfc_chainon_list (args, argse.expr);
2482     }
2483   se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2484 }
2485
2486
2487 /* Generate code for TRIM (A) intrinsic function.  */
2488
2489 static void
2490 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2491 {
2492   tree var;
2493   tree len;
2494   tree addr;
2495   tree tmp;
2496   tree arglist;
2497   tree type;
2498   tree cond;
2499
2500   arglist = NULL_TREE;
2501
2502   type = build_pointer_type (gfc_character1_type_node);
2503   var = gfc_create_var (type, "pstr");
2504   addr = gfc_build_addr_expr (ppvoid_type_node, var);
2505   len = gfc_create_var (gfc_int4_type_node, "len");
2506
2507   tmp = gfc_conv_intrinsic_function_args (se, expr);
2508   arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2509   arglist = gfc_chainon_list (arglist, addr);
2510   arglist = chainon (arglist, tmp);
2511
2512   tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2513   gfc_add_expr_to_block (&se->pre, tmp);
2514
2515   /* Free the temporary afterwards, if necessary.  */
2516   cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
2517   arglist = gfc_chainon_list (NULL_TREE, var);
2518   tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2519   tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2520   gfc_add_expr_to_block (&se->post, tmp);
2521
2522   se->expr = var;
2523   se->string_length = len;
2524 }
2525
2526
2527 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
2528
2529 static void
2530 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2531 {
2532   tree tmp;
2533   tree len;
2534   tree args;
2535   tree arglist;
2536   tree ncopies;
2537   tree var;
2538   tree type;
2539
2540   args = gfc_conv_intrinsic_function_args (se, expr);
2541   len = TREE_VALUE (args);
2542   tmp = gfc_advance_chain (args, 2);
2543   ncopies = TREE_VALUE (tmp);
2544   len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2545   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2546   var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2547
2548   arglist = NULL_TREE;
2549   arglist = gfc_chainon_list (arglist, var);
2550   arglist = chainon (arglist, args);
2551   tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2552   gfc_add_expr_to_block (&se->pre, tmp);
2553
2554   se->expr = var;
2555   se->string_length = len;
2556 }
2557
2558
2559 /* Generate code for an intrinsic function.  Some map directly to library
2560    calls, others get special handling.  In some cases the name of the function
2561    used depends on the type specifiers.  */
2562
2563 void
2564 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2565 {
2566   gfc_intrinsic_sym *isym;
2567   char *name;
2568   int lib;
2569
2570   isym = expr->value.function.isym;
2571
2572   name = &expr->value.function.name[2];
2573
2574   if (expr->rank > 0)
2575     {
2576       lib = gfc_is_intrinsic_libcall (expr);
2577       if (lib != 0)
2578         {
2579           if (lib == 1)
2580             se->ignore_optional = 1;
2581           gfc_conv_intrinsic_funcall (se, expr);
2582           return;
2583         }
2584     }
2585
2586   switch (expr->value.function.isym->generic_id)
2587     {
2588     case GFC_ISYM_NONE:
2589       abort ();
2590
2591     case GFC_ISYM_REPEAT:
2592       gfc_conv_intrinsic_repeat (se, expr);
2593       break;
2594
2595     case GFC_ISYM_TRIM:
2596       gfc_conv_intrinsic_trim (se, expr);
2597       break;
2598
2599     case GFC_ISYM_SI_KIND:
2600       gfc_conv_intrinsic_si_kind (se, expr);
2601       break;
2602
2603     case GFC_ISYM_SR_KIND:
2604       gfc_conv_intrinsic_sr_kind (se, expr);
2605       break;
2606
2607     case GFC_ISYM_EXPONENT:
2608       gfc_conv_intrinsic_exponent (se, expr);
2609       break;
2610
2611     case GFC_ISYM_SPACING:
2612       gfc_conv_intrinsic_spacing (se, expr);
2613       break;
2614
2615     case GFC_ISYM_RRSPACING:
2616       gfc_conv_intrinsic_rrspacing (se, expr);
2617       break;
2618
2619     case GFC_ISYM_SCAN:
2620       gfc_conv_intrinsic_scan (se, expr);
2621       break;
2622
2623     case GFC_ISYM_VERIFY:
2624       gfc_conv_intrinsic_verify (se, expr);
2625       break;
2626
2627     case GFC_ISYM_ALLOCATED:
2628       gfc_conv_allocated (se, expr);
2629       break;
2630
2631     case GFC_ISYM_ASSOCIATED:
2632       gfc_conv_associated(se, expr);
2633       break;
2634
2635     case GFC_ISYM_ABS:
2636       gfc_conv_intrinsic_abs (se, expr);
2637       break;
2638
2639     case GFC_ISYM_ADJUSTL:
2640       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2641       break;
2642
2643     case GFC_ISYM_ADJUSTR:
2644       gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2645       break;
2646
2647     case GFC_ISYM_AIMAG:
2648       gfc_conv_intrinsic_imagpart (se, expr);
2649       break;
2650
2651     case GFC_ISYM_AINT:
2652       gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2653       break;
2654
2655     case GFC_ISYM_ALL:
2656       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2657       break;
2658
2659     case GFC_ISYM_ANINT:
2660       gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2661       break;
2662
2663     case GFC_ISYM_ANY:
2664       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2665       break;
2666
2667     case GFC_ISYM_BTEST:
2668       gfc_conv_intrinsic_btest (se, expr);
2669       break;
2670
2671     case GFC_ISYM_ACHAR:
2672     case GFC_ISYM_CHAR:
2673       gfc_conv_intrinsic_char (se, expr);
2674       break;
2675
2676     case GFC_ISYM_CONVERSION:
2677     case GFC_ISYM_REAL:
2678     case GFC_ISYM_LOGICAL:
2679     case GFC_ISYM_DBLE:
2680       gfc_conv_intrinsic_conversion (se, expr);
2681       break;
2682
2683       /* Integer conversions are handled seperately to make sure we get the
2684          correct rounding mode.  */
2685     case GFC_ISYM_INT:
2686       gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2687       break;
2688
2689     case GFC_ISYM_NINT:
2690       gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2691       break;
2692
2693     case GFC_ISYM_CEILING:
2694       gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2695       break;
2696
2697     case GFC_ISYM_FLOOR:
2698       gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2699       break;
2700
2701     case GFC_ISYM_MOD:
2702       gfc_conv_intrinsic_mod (se, expr, 0);
2703       break;
2704
2705     case GFC_ISYM_MODULO:
2706       gfc_conv_intrinsic_mod (se, expr, 1);
2707       break;
2708
2709     case GFC_ISYM_CMPLX:
2710       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2711       break;
2712
2713     case GFC_ISYM_CONJG:
2714       gfc_conv_intrinsic_conjg (se, expr);
2715       break;
2716
2717     case GFC_ISYM_COUNT:
2718       gfc_conv_intrinsic_count (se, expr);
2719       break;
2720
2721     case GFC_ISYM_DIM:
2722       gfc_conv_intrinsic_dim (se, expr);
2723       break;
2724
2725     case GFC_ISYM_DPROD:
2726       gfc_conv_intrinsic_dprod (se, expr);
2727       break;
2728
2729     case GFC_ISYM_IAND:
2730       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2731       break;
2732
2733     case GFC_ISYM_IBCLR:
2734       gfc_conv_intrinsic_singlebitop (se, expr, 0);
2735       break;
2736
2737     case GFC_ISYM_IBITS:
2738       gfc_conv_intrinsic_ibits (se, expr);
2739       break;
2740
2741     case GFC_ISYM_IBSET:
2742       gfc_conv_intrinsic_singlebitop (se, expr, 1);
2743       break;
2744
2745     case GFC_ISYM_IACHAR:
2746     case GFC_ISYM_ICHAR:
2747       /* We assume ASCII character sequence.  */
2748       gfc_conv_intrinsic_ichar (se, expr);
2749       break;
2750
2751     case GFC_ISYM_IEOR:
2752       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2753       break;
2754
2755     case GFC_ISYM_INDEX:
2756       gfc_conv_intrinsic_index (se, expr);
2757       break;
2758
2759     case GFC_ISYM_IOR:
2760       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2761       break;
2762
2763     case GFC_ISYM_ISHFT:
2764       gfc_conv_intrinsic_ishft (se, expr);
2765       break;
2766
2767     case GFC_ISYM_ISHFTC:
2768       gfc_conv_intrinsic_ishftc (se, expr);
2769       break;
2770
2771     case GFC_ISYM_LBOUND:
2772       gfc_conv_intrinsic_bound (se, expr, 0);
2773       break;
2774
2775     case GFC_ISYM_LEN:
2776       gfc_conv_intrinsic_len (se, expr);
2777       break;
2778
2779     case GFC_ISYM_LEN_TRIM:
2780       gfc_conv_intrinsic_len_trim (se, expr);
2781       break;
2782
2783     case GFC_ISYM_LGE:
2784       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2785       break;
2786
2787     case GFC_ISYM_LGT:
2788       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2789       break;
2790
2791     case GFC_ISYM_LLE:
2792       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2793       break;
2794
2795     case GFC_ISYM_LLT:
2796       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2797       break;
2798
2799     case GFC_ISYM_MAX:
2800       gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2801       break;
2802
2803     case GFC_ISYM_MAXLOC:
2804       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2805       break;
2806
2807     case GFC_ISYM_MAXVAL:
2808       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2809       break;
2810
2811     case GFC_ISYM_MERGE:
2812       gfc_conv_intrinsic_merge (se, expr);
2813       break;
2814
2815     case GFC_ISYM_MIN:
2816       gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2817       break;
2818
2819     case GFC_ISYM_MINLOC:
2820       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2821       break;
2822
2823     case GFC_ISYM_MINVAL:
2824       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2825       break;
2826
2827     case GFC_ISYM_NOT:
2828       gfc_conv_intrinsic_not (se, expr);
2829       break;
2830
2831     case GFC_ISYM_PRESENT:
2832       gfc_conv_intrinsic_present (se, expr);
2833       break;
2834
2835     case GFC_ISYM_PRODUCT:
2836       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2837       break;
2838
2839     case GFC_ISYM_SIGN:
2840       gfc_conv_intrinsic_sign (se, expr);
2841       break;
2842
2843     case GFC_ISYM_SIZE:
2844       gfc_conv_intrinsic_size (se, expr);
2845       break;
2846
2847     case GFC_ISYM_SUM:
2848       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2849       break;
2850
2851     case GFC_ISYM_TRANSFER:
2852       gfc_conv_intrinsic_transfer (se, expr);
2853       break;
2854
2855     case GFC_ISYM_UBOUND:
2856       gfc_conv_intrinsic_bound (se, expr, 1);
2857       break;
2858
2859     case GFC_ISYM_DOT_PRODUCT:
2860     case GFC_ISYM_MATMUL:
2861       gfc_conv_intrinsic_funcall (se, expr);
2862       break;
2863
2864     default:
2865       gfc_conv_intrinsic_lib_function (se, expr);
2866       break;
2867     }
2868 }
2869
2870
2871 /* This generates code to execute before entering the scalarization loop.
2872    Currently does nothing.  */
2873
2874 void
2875 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
2876 {
2877   switch (ss->expr->value.function.isym->generic_id)
2878     {
2879     case GFC_ISYM_UBOUND:
2880     case GFC_ISYM_LBOUND:
2881       break;
2882
2883     default:
2884       abort ();
2885       break;
2886     }
2887 }
2888
2889
2890 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
2891    inside the scalarization loop.  */
2892
2893 static gfc_ss *
2894 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
2895 {
2896   gfc_ss *newss;
2897
2898   /* The two argument version returns a scalar.  */
2899   if (expr->value.function.actual->next->expr)
2900     return ss;
2901
2902   newss = gfc_get_ss ();
2903   newss->type = GFC_SS_INTRINSIC;
2904   newss->expr = expr;
2905   newss->next = ss;
2906
2907   return newss;
2908 }
2909
2910
2911 /* Walk an intrinsic array libcall.  */
2912
2913 static gfc_ss *
2914 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
2915 {
2916   gfc_ss *newss;
2917
2918   assert (expr->rank > 0);
2919
2920   newss = gfc_get_ss ();
2921   newss->type = GFC_SS_FUNCTION;
2922   newss->expr = expr;
2923   newss->next = ss;
2924   newss->data.info.dimen = expr->rank;
2925
2926   return newss;
2927 }
2928
2929
2930 /* Returns nonzero if the specified intrinsic function call maps directly to a
2931    an external library call.  Should only be used for functions that return
2932    arrays.  */
2933
2934 int
2935 gfc_is_intrinsic_libcall (gfc_expr * expr)
2936 {
2937   assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
2938   assert (expr->rank > 0);
2939
2940   switch (expr->value.function.isym->generic_id)
2941     {
2942     case GFC_ISYM_ALL:
2943     case GFC_ISYM_ANY:
2944     case GFC_ISYM_COUNT:
2945     case GFC_ISYM_MATMUL:
2946     case GFC_ISYM_MAXLOC:
2947     case GFC_ISYM_MAXVAL:
2948     case GFC_ISYM_MINLOC:
2949     case GFC_ISYM_MINVAL:
2950     case GFC_ISYM_PRODUCT:
2951     case GFC_ISYM_SUM:
2952     case GFC_ISYM_SHAPE:
2953     case GFC_ISYM_SPREAD:
2954     case GFC_ISYM_TRANSPOSE:
2955       /* Ignore absent optional parameters.  */
2956       return 1;
2957
2958     case GFC_ISYM_RESHAPE:
2959     case GFC_ISYM_CSHIFT:
2960     case GFC_ISYM_EOSHIFT:
2961     case GFC_ISYM_PACK:
2962     case GFC_ISYM_UNPACK:
2963       /* Pass absent optional parameters.  */
2964       return 2;
2965
2966     default:
2967       return 0;
2968     }
2969 }
2970
2971 /* Walk an intrinsic function.  */
2972 gfc_ss *
2973 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
2974                              gfc_intrinsic_sym * isym)
2975 {
2976   assert (isym);
2977
2978   if (isym->elemental)
2979     return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
2980
2981   if (expr->rank == 0)
2982     return ss;
2983
2984   if (gfc_is_intrinsic_libcall (expr))
2985     return gfc_walk_intrinsic_libfunc (ss, expr);
2986
2987   /* Special cases.  */
2988   switch (isym->generic_id)
2989     {
2990     case GFC_ISYM_LBOUND:
2991     case GFC_ISYM_UBOUND:
2992       return gfc_walk_intrinsic_bound (ss, expr);
2993
2994     default:
2995       /* This probably meant someone forgot to add an intrinsic to the above
2996          list(s) when they implemented it, or something's gone horribly wrong.
2997        */
2998       gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
2999                       expr->value.function.name);
3000     }
3001 }
3002
3003 #include "gt-fortran-trans-intrinsic.h"