gcc/fortran/trans-intrinsic.c

   1 /* Intrinsic translation
   2    Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
   3    Free Software Foundation, Inc.
   4    Contributed by Paul Brook <paul@nowt.org>
   5    and Steven Bosscher <s.bosscher@student.tudelft.nl>
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  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 "tm.h"
  29 #include "tree.h"
  30 #include "ggc.h"
  31 #include "toplev.h"
  32 #include "real.h"
  33 #include "gimple.h"
  34 #include "flags.h"
  35 #include "gfortran.h"
  36 #include "arith.h"
  37 #include "intrinsic.h"
  38 #include "trans.h"
  39 #include "trans-const.h"
  40 #include "trans-types.h"
  41 #include "trans-array.h"
  42 #include "defaults.h"
  43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign.  */
  44 #include "trans-stmt.h"
  45
  46 /* This maps fortran intrinsic math functions to external library or GCC
  47    builtin functions.  */
  48 typedef struct gfc_intrinsic_map_t      GTY(())
  49 {
  50   /* The explicit enum is required to work around inadequacies in the
  51      garbage collection/gengtype parsing mechanism.  */
  52   enum gfc_isym_id id;
  53
  54   /* Enum value from the "language-independent", aka C-centric, part
  55      of gcc, or END_BUILTINS of no such value set.  */
  56   enum built_in_function code_r4;
  57   enum built_in_function code_r8;
  58   enum built_in_function code_r10;
  59   enum built_in_function code_r16;
  60   enum built_in_function code_c4;
  61   enum built_in_function code_c8;
  62   enum built_in_function code_c10;
  63   enum built_in_function code_c16;
  64
  65   /* True if the naming pattern is to prepend "c" for complex and
  66      append "f" for kind=4.  False if the naming pattern is to
  67      prepend "_gfortran_" and append "[rc](4|8|10|16)".  */
  68   bool libm_name;
  69
  70   /* True if a complex version of the function exists.  */
  71   bool complex_available;
  72
  73   /* True if the function should be marked const.  */
  74   bool is_constant;
  75
  76   /* The base library name of this function.  */
  77   const char *name;
  78
  79   /* Cache decls created for the various operand types.  */
  80   tree real4_decl;
  81   tree real8_decl;
  82   tree real10_decl;
  83   tree real16_decl;
  84   tree complex4_decl;
  85   tree complex8_decl;
  86   tree complex10_decl;
  87   tree complex16_decl;
  88 }
  89 gfc_intrinsic_map_t;
  90
  91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
  92    defines complex variants of all of the entries in mathbuiltins.def
  93    except for atan2.  */
  94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
  95   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
  96     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
  97     false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
  98     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
  99
 100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
 101   { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
 102     BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
 103     BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
 104     true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
 105     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
 106
 107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
 108   { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 109     END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
 110     false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
 111     NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
 112
 113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
 114 {
 115   /* Functions built into gcc itself.  */
 116 #include "mathbuiltins.def"
 117
 118   /* Functions in libgfortran.  */
 119   LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
 120
 121   /* End the list.  */
 122   LIB_FUNCTION (NONE, NULL, false)
 123
 124 };
 125 #undef LIB_FUNCTION
 126 #undef DEFINE_MATH_BUILTIN
 127 #undef DEFINE_MATH_BUILTIN_C
 128
 129 /* Structure for storing components of a floating number to be used by
 130    elemental functions to manipulate reals.  */
 131 typedef struct
 132 {
 133   tree arg;     /* Variable tree to view convert to integer.  */
 134   tree expn;    /* Variable tree to save exponent.  */
 135   tree frac;    /* Variable tree to save fraction.  */
 136   tree smask;   /* Constant tree of sign's mask.  */
 137   tree emask;   /* Constant tree of exponent's mask.  */
 138   tree fmask;   /* Constant tree of fraction's mask.  */
 139   tree edigits; /* Constant tree of the number of exponent bits.  */
 140   tree fdigits; /* Constant tree of the number of fraction bits.  */
 141   tree f1;      /* Constant tree of the f1 defined in the real model.  */
 142   tree bias;    /* Constant tree of the bias of exponent in the memory.  */
 143   tree type;    /* Type tree of arg1.  */
 144   tree mtype;   /* Type tree of integer type. Kind is that of arg1.  */
 145 }
 146 real_compnt_info;
 147
 148 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
 149
 150 /* Evaluate the arguments to an intrinsic function.  The value
 151    of NARGS may be less than the actual number of arguments in EXPR
 152    to allow optional "KIND" arguments that are not included in the
 153    generated code to be ignored.  */
 154
 155 static void
 156 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
 157                                   tree *argarray, int nargs)
 158 {
 159   gfc_actual_arglist *actual;
 160   gfc_expr *e;
 161   gfc_intrinsic_arg  *formal;
 162   gfc_se argse;
 163   int curr_arg;
 164
 165   formal = expr->value.function.isym->formal;
 166   actual = expr->value.function.actual;
 167
 168    for (curr_arg = 0; curr_arg < nargs; curr_arg++,
 169         actual = actual->next,
 170         formal = formal ? formal->next : NULL)
 171     {
 172       gcc_assert (actual);
 173       e = actual->expr;
 174       /* Skip omitted optional arguments.  */
 175       if (!e)
 176         {
 177           --curr_arg;
 178           continue;
 179         }
 180
 181       /* Evaluate the parameter.  This will substitute scalarized
 182          references automatically.  */
 183       gfc_init_se (&argse, se);
 184
 185       if (e->ts.type == BT_CHARACTER)
 186         {
 187           gfc_conv_expr (&argse, e);
 188           gfc_conv_string_parameter (&argse);
 189           argarray[curr_arg++] = argse.string_length;
 190           gcc_assert (curr_arg < nargs);
 191         }
 192       else
 193         gfc_conv_expr_val (&argse, e);
 194
 195       /* If an optional argument is itself an optional dummy argument,
 196          check its presence and substitute a null if absent.  */
 197       if (e->expr_type == EXPR_VARIABLE
 198             && e->symtree->n.sym->attr.optional
 199             && formal
 200             && formal->optional)
 201         gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
 202
 203       gfc_add_block_to_block (&se->pre, &argse.pre);
 204       gfc_add_block_to_block (&se->post, &argse.post);
 205       argarray[curr_arg] = argse.expr;
 206     }
 207 }
 208
 209 /* Count the number of actual arguments to the intrinsic function EXPR
 210    including any "hidden" string length arguments.  */
 211
 212 static unsigned int
 213 gfc_intrinsic_argument_list_length (gfc_expr *expr)
 214 {
 215   int n = 0;
 216   gfc_actual_arglist *actual;
 217
 218   for (actual = expr->value.function.actual; actual; actual = actual->next)
 219     {
 220       if (!actual->expr)
 221         continue;
 222
 223       if (actual->expr->ts.type == BT_CHARACTER)
 224         n += 2;
 225       else
 226         n++;
 227     }
 228
 229   return n;
 230 }
 231
 232
 233 /* Conversions between different types are output by the frontend as
 234    intrinsic functions.  We implement these directly with inline code.  */
 235
 236 static void
 237 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
 238 {
 239   tree type;
 240   tree *args;
 241   int nargs;
 242
 243   nargs = gfc_intrinsic_argument_list_length (expr);
 244   args = (tree *) alloca (sizeof (tree) * nargs);
 245
 246   /* Evaluate all the arguments passed. Whilst we're only interested in the
 247      first one here, there are other parts of the front-end that assume this
 248      and will trigger an ICE if it's not the case.  */
 249   type = gfc_typenode_for_spec (&expr->ts);
 250   gcc_assert (expr->value.function.actual->expr);
 251   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 252
 253   /* Conversion between character kinds involves a call to a library
 254      function.  */
 255   if (expr->ts.type == BT_CHARACTER)
 256     {
 257       tree fndecl, var, addr, tmp;
 258
 259       if (expr->ts.kind == 1
 260           && expr->value.function.actual->expr->ts.kind == 4)
 261         fndecl = gfor_fndecl_convert_char4_to_char1;
 262       else if (expr->ts.kind == 4
 263                && expr->value.function.actual->expr->ts.kind == 1)
 264         fndecl = gfor_fndecl_convert_char1_to_char4;
 265       else
 266         gcc_unreachable ();
 267
 268       /* Create the variable storing the converted value.  */
 269       type = gfc_get_pchar_type (expr->ts.kind);
 270       var = gfc_create_var (type, "str");
 271       addr = gfc_build_addr_expr (build_pointer_type (type), var);
 272
 273       /* Call the library function that will perform the conversion.  */
 274       gcc_assert (nargs >= 2);
 275       tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
 276       gfc_add_expr_to_block (&se->pre, tmp);
 277
 278       /* Free the temporary afterwards.  */
 279       tmp = gfc_call_free (var);
 280       gfc_add_expr_to_block (&se->post, tmp);
 281
 282       se->expr = var;
 283       se->string_length = args[0];
 284
 285       return;
 286     }
 287
 288   /* Conversion from complex to non-complex involves taking the real
 289      component of the value.  */
 290   if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 291       && expr->ts.type != BT_COMPLEX)
 292     {
 293       tree artype;
 294
 295       artype = TREE_TYPE (TREE_TYPE (args[0]));
 296       args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 297     }
 298
 299   se->expr = convert (type, args[0]);
 300 }
 301
 302 /* This is needed because the gcc backend only implements
 303    FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
 304    FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
 305    Similarly for CEILING.  */
 306
 307 static tree
 308 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
 309 {
 310   tree tmp;
 311   tree cond;
 312   tree argtype;
 313   tree intval;
 314
 315   argtype = TREE_TYPE (arg);
 316   arg = gfc_evaluate_now (arg, pblock);
 317
 318   intval = convert (type, arg);
 319   intval = gfc_evaluate_now (intval, pblock);
 320
 321   tmp = convert (argtype, intval);
 322   cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
 323
 324   tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
 325                      build_int_cst (type, 1));
 326   tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
 327   return tmp;
 328 }
 329
 330
 331 /* Round to nearest integer, away from zero.  */
 332
 333 static tree
 334 build_round_expr (tree arg, tree restype)
 335 {
 336   tree argtype;
 337   tree fn;
 338   bool longlong;
 339   int argprec, resprec;
 340
 341   argtype = TREE_TYPE (arg);
 342   argprec = TYPE_PRECISION (argtype);
 343   resprec = TYPE_PRECISION (restype);
 344
 345   /* Depending on the type of the result, choose the long int intrinsic
 346      (lround family) or long long intrinsic (llround).  We might also
 347      need to convert the result afterwards.  */
 348   if (resprec <= LONG_TYPE_SIZE)
 349     longlong = false;
 350   else if (resprec <= LONG_LONG_TYPE_SIZE)
 351     longlong = true;
 352   else
 353     gcc_unreachable ();
 354
 355   /* Now, depending on the argument type, we choose between intrinsics.  */
 356   if (argprec == TYPE_PRECISION (float_type_node))
 357     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
 358   else if (argprec == TYPE_PRECISION (double_type_node))
 359     fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
 360   else if (argprec == TYPE_PRECISION (long_double_type_node))
 361     fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
 362   else
 363     gcc_unreachable ();
 364
 365   return fold_convert (restype, build_call_expr (fn, 1, arg));
 366 }
 367
 368
 369 /* Convert a real to an integer using a specific rounding mode.
 370    Ideally we would just build the corresponding GENERIC node,
 371    however the RTL expander only actually supports FIX_TRUNC_EXPR.  */
 372
 373 static tree
 374 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
 375                enum rounding_mode op)
 376 {
 377   switch (op)
 378     {
 379     case RND_FLOOR:
 380       return build_fixbound_expr (pblock, arg, type, 0);
 381       break;
 382
 383     case RND_CEIL:
 384       return build_fixbound_expr (pblock, arg, type, 1);
 385       break;
 386
 387     case RND_ROUND:
 388       return build_round_expr (arg, type);
 389       break;
 390
 391     case RND_TRUNC:
 392       return fold_build1 (FIX_TRUNC_EXPR, type, arg);
 393       break;
 394
 395     default:
 396       gcc_unreachable ();
 397     }
 398 }
 399
 400
 401 /* Round a real value using the specified rounding mode.
 402    We use a temporary integer of that same kind size as the result.
 403    Values larger than those that can be represented by this kind are
 404    unchanged, as they will not be accurate enough to represent the
 405    rounding.
 406     huge = HUGE (KIND (a))
 407     aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
 408    */
 409
 410 static void
 411 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 412 {
 413   tree type;
 414   tree itype;
 415   tree arg[2];
 416   tree tmp;
 417   tree cond;
 418   mpfr_t huge;
 419   int n, nargs;
 420   int kind;
 421
 422   kind = expr->ts.kind;
 423   nargs =  gfc_intrinsic_argument_list_length (expr);
 424
 425   n = END_BUILTINS;
 426   /* We have builtin functions for some cases.  */
 427   switch (op)
 428     {
 429     case RND_ROUND:
 430       switch (kind)
 431         {
 432         case 4:
 433           n = BUILT_IN_ROUNDF;
 434           break;
 435
 436         case 8:
 437           n = BUILT_IN_ROUND;
 438           break;
 439
 440         case 10:
 441         case 16:
 442           n = BUILT_IN_ROUNDL;
 443           break;
 444         }
 445       break;
 446
 447     case RND_TRUNC:
 448       switch (kind)
 449         {
 450         case 4:
 451           n = BUILT_IN_TRUNCF;
 452           break;
 453
 454         case 8:
 455           n = BUILT_IN_TRUNC;
 456           break;
 457
 458         case 10:
 459         case 16:
 460           n = BUILT_IN_TRUNCL;
 461           break;
 462         }
 463       break;
 464
 465     default:
 466       gcc_unreachable ();
 467     }
 468
 469   /* Evaluate the argument.  */
 470   gcc_assert (expr->value.function.actual->expr);
 471   gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
 472
 473   /* Use a builtin function if one exists.  */
 474   if (n != END_BUILTINS)
 475     {
 476       tmp = built_in_decls[n];
 477       se->expr = build_call_expr (tmp, 1, arg[0]);
 478       return;
 479     }
 480
 481   /* This code is probably redundant, but we'll keep it lying around just
 482      in case.  */
 483   type = gfc_typenode_for_spec (&expr->ts);
 484   arg[0] = gfc_evaluate_now (arg[0], &se->pre);
 485
 486   /* Test if the value is too large to handle sensibly.  */
 487   gfc_set_model_kind (kind);
 488   mpfr_init (huge);
 489   n = gfc_validate_kind (BT_INTEGER, kind, false);
 490   mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
 491   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 492   cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
 493
 494   mpfr_neg (huge, huge, GFC_RND_MODE);
 495   tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
 496   tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
 497   cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
 498   itype = gfc_get_int_type (kind);
 499
 500   tmp = build_fix_expr (&se->pre, arg[0], itype, op);
 501   tmp = convert (type, tmp);
 502   se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
 503   mpfr_clear (huge);
 504 }
 505
 506
 507 /* Convert to an integer using the specified rounding mode.  */
 508
 509 static void
 510 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
 511 {
 512   tree type;
 513   tree *args;
 514   int nargs;
 515
 516   nargs = gfc_intrinsic_argument_list_length (expr);
 517   args = (tree *) alloca (sizeof (tree) * nargs);
 518
 519   /* Evaluate the argument, we process all arguments even though we only
 520      use the first one for code generation purposes.  */
 521   type = gfc_typenode_for_spec (&expr->ts);
 522   gcc_assert (expr->value.function.actual->expr);
 523   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
 524
 525   if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
 526     {
 527       /* Conversion to a different integer kind.  */
 528       se->expr = convert (type, args[0]);
 529     }
 530   else
 531     {
 532       /* Conversion from complex to non-complex involves taking the real
 533          component of the value.  */
 534       if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
 535           && expr->ts.type != BT_COMPLEX)
 536         {
 537           tree artype;
 538
 539           artype = TREE_TYPE (TREE_TYPE (args[0]));
 540           args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
 541         }
 542
 543       se->expr = build_fix_expr (&se->pre, args[0], type, op);
 544     }
 545 }
 546
 547
 548 /* Get the imaginary component of a value.  */
 549
 550 static void
 551 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
 552 {
 553   tree arg;
 554
 555   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 556   se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
 557 }
 558
 559
 560 /* Get the complex conjugate of a value.  */
 561
 562 static void
 563 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
 564 {
 565   tree arg;
 566
 567   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 568   se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
 569 }
 570
 571
 572 /* Initialize function decls for library functions.  The external functions
 573    are created as required.  Builtin functions are added here.  */
 574
 575 void
 576 gfc_build_intrinsic_lib_fndecls (void)
 577 {
 578   gfc_intrinsic_map_t *m;
 579
 580   /* Add GCC builtin functions.  */
 581   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 582     {
 583       if (m->code_r4 != END_BUILTINS)
 584         m->real4_decl = built_in_decls[m->code_r4];
 585       if (m->code_r8 != END_BUILTINS)
 586         m->real8_decl = built_in_decls[m->code_r8];
 587       if (m->code_r10 != END_BUILTINS)
 588         m->real10_decl = built_in_decls[m->code_r10];
 589       if (m->code_r16 != END_BUILTINS)
 590         m->real16_decl = built_in_decls[m->code_r16];
 591       if (m->code_c4 != END_BUILTINS)
 592         m->complex4_decl = built_in_decls[m->code_c4];
 593       if (m->code_c8 != END_BUILTINS)
 594         m->complex8_decl = built_in_decls[m->code_c8];
 595       if (m->code_c10 != END_BUILTINS)
 596         m->complex10_decl = built_in_decls[m->code_c10];
 597       if (m->code_c16 != END_BUILTINS)
 598         m->complex16_decl = built_in_decls[m->code_c16];
 599     }
 600 }
 601
 602
 603 /* Create a fndecl for a simple intrinsic library function.  */
 604
 605 static tree
 606 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
 607 {
 608   tree type;
 609   tree argtypes;
 610   tree fndecl;
 611   gfc_actual_arglist *actual;
 612   tree *pdecl;
 613   gfc_typespec *ts;
 614   char name[GFC_MAX_SYMBOL_LEN + 3];
 615
 616   ts = &expr->ts;
 617   if (ts->type == BT_REAL)
 618     {
 619       switch (ts->kind)
 620         {
 621         case 4:
 622           pdecl = &m->real4_decl;
 623           break;
 624         case 8:
 625           pdecl = &m->real8_decl;
 626           break;
 627         case 10:
 628           pdecl = &m->real10_decl;
 629           break;
 630         case 16:
 631           pdecl = &m->real16_decl;
 632           break;
 633         default:
 634           gcc_unreachable ();
 635         }
 636     }
 637   else if (ts->type == BT_COMPLEX)
 638     {
 639       gcc_assert (m->complex_available);
 640
 641       switch (ts->kind)
 642         {
 643         case 4:
 644           pdecl = &m->complex4_decl;
 645           break;
 646         case 8:
 647           pdecl = &m->complex8_decl;
 648           break;
 649         case 10:
 650           pdecl = &m->complex10_decl;
 651           break;
 652         case 16:
 653           pdecl = &m->complex16_decl;
 654           break;
 655         default:
 656           gcc_unreachable ();
 657         }
 658     }
 659   else
 660     gcc_unreachable ();
 661
 662   if (*pdecl)
 663     return *pdecl;
 664
 665   if (m->libm_name)
 666     {
 667       if (ts->kind == 4)
 668         snprintf (name, sizeof (name), "%s%s%s",
 669                 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
 670       else if (ts->kind == 8)
 671         snprintf (name, sizeof (name), "%s%s",
 672                 ts->type == BT_COMPLEX ? "c" : "", m->name);
 673       else
 674         {
 675           gcc_assert (ts->kind == 10 || ts->kind == 16);
 676           snprintf (name, sizeof (name), "%s%s%s",
 677                 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
 678         }
 679     }
 680   else
 681     {
 682       snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
 683                 ts->type == BT_COMPLEX ? 'c' : 'r',
 684                 ts->kind);
 685     }
 686
 687   argtypes = NULL_TREE;
 688   for (actual = expr->value.function.actual; actual; actual = actual->next)
 689     {
 690       type = gfc_typenode_for_spec (&actual->expr->ts);
 691       argtypes = gfc_chainon_list (argtypes, type);
 692     }
 693   argtypes = gfc_chainon_list (argtypes, void_type_node);
 694   type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
 695   fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
 696
 697   /* Mark the decl as external.  */
 698   DECL_EXTERNAL (fndecl) = 1;
 699   TREE_PUBLIC (fndecl) = 1;
 700
 701   /* Mark it __attribute__((const)), if possible.  */
 702   TREE_READONLY (fndecl) = m->is_constant;
 703
 704   rest_of_decl_compilation (fndecl, 1, 0);
 705
 706   (*pdecl) = fndecl;
 707   return fndecl;
 708 }
 709
 710
 711 /* Convert an intrinsic function into an external or builtin call.  */
 712
 713 static void
 714 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
 715 {
 716   gfc_intrinsic_map_t *m;
 717   tree fndecl;
 718   tree rettype;
 719   tree *args;
 720   unsigned int num_args;
 721   gfc_isym_id id;
 722
 723   id = expr->value.function.isym->id;
 724   /* Find the entry for this function.  */
 725   for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
 726     {
 727       if (id == m->id)
 728         break;
 729     }
 730
 731   if (m->id == GFC_ISYM_NONE)
 732     {
 733       internal_error ("Intrinsic function %s(%d) not recognized",
 734                       expr->value.function.name, id);
 735     }
 736
 737   /* Get the decl and generate the call.  */
 738   num_args = gfc_intrinsic_argument_list_length (expr);
 739   args = (tree *) alloca (sizeof (tree) * num_args);
 740
 741   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
 742   fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
 743   rettype = TREE_TYPE (TREE_TYPE (fndecl));
 744
 745   fndecl = build_addr (fndecl, current_function_decl);
 746   se->expr = build_call_array (rettype, fndecl, num_args, args);
 747 }
 748
 749
 750 /* If bounds-checking is enabled, create code to verify at runtime that the
 751    string lengths for both expressions are the same (needed for e.g. MERGE).
 752    If bounds-checking is not enabled, does nothing.  */
 753
 754 void
 755 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
 756                              tree a, tree b, stmtblock_t* target)
 757 {
 758   tree cond;
 759   tree name;
 760
 761   /* If bounds-checking is disabled, do nothing.  */
 762   if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
 763     return;
 764
 765   /* Compare the two string lengths.  */
 766   cond = fold_build2 (NE_EXPR, boolean_type_node, a, b);
 767
 768   /* Output the runtime-check.  */
 769   name = gfc_build_cstring_const (intr_name);
 770   name = gfc_build_addr_expr (pchar_type_node, name);
 771   gfc_trans_runtime_check (true, false, cond, target, where,
 772                            "Unequal character lengths (%ld/%ld) in %s",
 773                            fold_convert (long_integer_type_node, a),
 774                            fold_convert (long_integer_type_node, b), name);
 775 }
 776
 777
 778 /* The EXPONENT(s) intrinsic function is translated into
 779        int ret;
 780        frexp (s, &ret);
 781        return ret;
 782  */
 783
 784 static void
 785 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
 786 {
 787   tree arg, type, res, tmp;
 788   int frexp;
 789
 790   switch (expr->value.function.actual->expr->ts.kind)
 791     {
 792     case 4:
 793       frexp = BUILT_IN_FREXPF;
 794       break;
 795     case 8:
 796       frexp = BUILT_IN_FREXP;
 797       break;
 798     case 10:
 799     case 16:
 800       frexp = BUILT_IN_FREXPL;
 801       break;
 802     default:
 803       gcc_unreachable ();
 804     }
 805
 806   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
 807
 808   res = gfc_create_var (integer_type_node, NULL);
 809   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
 810                          gfc_build_addr_expr (NULL_TREE, res));
 811   gfc_add_expr_to_block (&se->pre, tmp);
 812
 813   type = gfc_typenode_for_spec (&expr->ts);
 814   se->expr = fold_convert (type, res);
 815 }
 816
 817 /* Evaluate a single upper or lower bound.  */
 818 /* TODO: bound intrinsic generates way too much unnecessary code.  */
 819
 820 static void
 821 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
 822 {
 823   gfc_actual_arglist *arg;
 824   gfc_actual_arglist *arg2;
 825   tree desc;
 826   tree type;
 827   tree bound;
 828   tree tmp;
 829   tree cond, cond1, cond2, cond3, cond4, size;
 830   tree ubound;
 831   tree lbound;
 832   gfc_se argse;
 833   gfc_ss *ss;
 834   gfc_array_spec * as;
 835   gfc_ref *ref;
 836
 837   arg = expr->value.function.actual;
 838   arg2 = arg->next;
 839
 840   if (se->ss)
 841     {
 842       /* Create an implicit second parameter from the loop variable.  */
 843       gcc_assert (!arg2->expr);
 844       gcc_assert (se->loop->dimen == 1);
 845       gcc_assert (se->ss->expr == expr);
 846       gfc_advance_se_ss_chain (se);
 847       bound = se->loop->loopvar[0];
 848       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 849                            se->loop->from[0]);
 850     }
 851   else
 852     {
 853       /* use the passed argument.  */
 854       gcc_assert (arg->next->expr);
 855       gfc_init_se (&argse, NULL);
 856       gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
 857       gfc_add_block_to_block (&se->pre, &argse.pre);
 858       bound = argse.expr;
 859       /* Convert from one based to zero based.  */
 860       bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
 861                            gfc_index_one_node);
 862     }
 863
 864   /* TODO: don't re-evaluate the descriptor on each iteration.  */
 865   /* Get a descriptor for the first parameter.  */
 866   ss = gfc_walk_expr (arg->expr);
 867   gcc_assert (ss != gfc_ss_terminator);
 868   gfc_init_se (&argse, NULL);
 869   gfc_conv_expr_descriptor (&argse, arg->expr, ss);
 870   gfc_add_block_to_block (&se->pre, &argse.pre);
 871   gfc_add_block_to_block (&se->post, &argse.post);
 872
 873   desc = argse.expr;
 874
 875   if (INTEGER_CST_P (bound))
 876     {
 877       int hi, low;
 878
 879       hi = TREE_INT_CST_HIGH (bound);
 880       low = TREE_INT_CST_LOW (bound);
 881       if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
 882         gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
 883                    "dimension index", upper ? "UBOUND" : "LBOUND",
 884                    &expr->where);
 885     }
 886   else
 887     {
 888       if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
 889         {
 890           bound = gfc_evaluate_now (bound, &se->pre);
 891           cond = fold_build2 (LT_EXPR, boolean_type_node,
 892                               bound, build_int_cst (TREE_TYPE (bound), 0));
 893           tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
 894           tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
 895           cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
 896           gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
 897                                    gfc_msg_fault);
 898         }
 899     }
 900
 901   ubound = gfc_conv_descriptor_ubound (desc, bound);
 902   lbound = gfc_conv_descriptor_lbound (desc, bound);
 903
 904   /* Follow any component references.  */
 905   if (arg->expr->expr_type == EXPR_VARIABLE
 906       || arg->expr->expr_type == EXPR_CONSTANT)
 907     {
 908       as = arg->expr->symtree->n.sym->as;
 909       for (ref = arg->expr->ref; ref; ref = ref->next)
 910         {
 911           switch (ref->type)
 912             {
 913             case REF_COMPONENT:
 914               as = ref->u.c.component->as;
 915               continue;
 916
 917             case REF_SUBSTRING:
 918               continue;
 919
 920             case REF_ARRAY:
 921               {
 922                 switch (ref->u.ar.type)
 923                   {
 924                   case AR_ELEMENT:
 925                   case AR_SECTION:
 926                   case AR_UNKNOWN:
 927                     as = NULL;
 928                     continue;
 929
 930                   case AR_FULL:
 931                     break;
 932                   }
 933                 break;
 934               }
 935             }
 936         }
 937     }
 938   else
 939     as = NULL;
 940
 941   /* 13.14.53: Result value for LBOUND
 942
 943      Case (i): For an array section or for an array expression other than a
 944                whole array or array structure component, LBOUND(ARRAY, DIM)
 945                has the value 1.  For a whole array or array structure
 946                component, LBOUND(ARRAY, DIM) has the value:
 947                  (a) equal to the lower bound for subscript DIM of ARRAY if
 948                      dimension DIM of ARRAY does not have extent zero
 949                      or if ARRAY is an assumed-size array of rank DIM,
 950               or (b) 1 otherwise.
 951
 952      13.14.113: Result value for UBOUND
 953
 954      Case (i): For an array section or for an array expression other than a
 955                whole array or array structure component, UBOUND(ARRAY, DIM)
 956                has the value equal to the number of elements in the given
 957                dimension; otherwise, it has a value equal to the upper bound
 958                for subscript DIM of ARRAY if dimension DIM of ARRAY does
 959                not have size zero and has value zero if dimension DIM has
 960                size zero.  */
 961
 962   if (as)
 963     {
 964       tree stride = gfc_conv_descriptor_stride (desc, bound);
 965
 966       cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
 967       cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
 968
 969       cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
 970                            gfc_index_zero_node);
 971       cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
 972
 973       cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
 974                            gfc_index_zero_node);
 975
 976       if (upper)
 977         {
 978           tree cond5;
 979           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 980
 981           cond5 = fold_build2 (EQ_EXPR, boolean_type_node, gfc_index_one_node, lbound);
 982           cond5 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond5);
 983
 984           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond5);
 985
 986           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
 987                                   ubound, gfc_index_zero_node);
 988         }
 989       else
 990         {
 991           if (as->type == AS_ASSUMED_SIZE)
 992             cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
 993                                 build_int_cst (TREE_TYPE (bound),
 994                                                arg->expr->rank - 1));
 995           else
 996             cond = boolean_false_node;
 997
 998           cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
 999           cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
1000
1001           se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
1002                                   lbound, gfc_index_one_node);
1003         }
1004     }
1005   else
1006     {
1007       if (upper)
1008         {
1009           size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
1010           se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
1011                                   gfc_index_one_node);
1012           se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
1013                                   gfc_index_zero_node);
1014         }
1015       else
1016         se->expr = gfc_index_one_node;
1017     }
1018
1019   type = gfc_typenode_for_spec (&expr->ts);
1020   se->expr = convert (type, se->expr);
1021 }
1022
1023
1024 static void
1025 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1026 {
1027   tree arg;
1028   int n;
1029
1030   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1031
1032   switch (expr->value.function.actual->expr->ts.type)
1033     {
1034     case BT_INTEGER:
1035     case BT_REAL:
1036       se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
1037       break;
1038
1039     case BT_COMPLEX:
1040       switch (expr->ts.kind)
1041         {
1042         case 4:
1043           n = BUILT_IN_CABSF;
1044           break;
1045         case 8:
1046           n = BUILT_IN_CABS;
1047           break;
1048         case 10:
1049         case 16:
1050           n = BUILT_IN_CABSL;
1051           break;
1052         default:
1053           gcc_unreachable ();
1054         }
1055       se->expr = build_call_expr (built_in_decls[n], 1, arg);
1056       break;
1057
1058     default:
1059       gcc_unreachable ();
1060     }
1061 }
1062
1063
1064 /* Create a complex value from one or two real components.  */
1065
1066 static void
1067 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1068 {
1069   tree real;
1070   tree imag;
1071   tree type;
1072   tree *args;
1073   unsigned int num_args;
1074
1075   num_args = gfc_intrinsic_argument_list_length (expr);
1076   args = (tree *) alloca (sizeof (tree) * num_args);
1077
1078   type = gfc_typenode_for_spec (&expr->ts);
1079   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1080   real = convert (TREE_TYPE (type), args[0]);
1081   if (both)
1082     imag = convert (TREE_TYPE (type), args[1]);
1083   else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1084     {
1085       imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1086                           args[0]);
1087       imag = convert (TREE_TYPE (type), imag);
1088     }
1089   else
1090     imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1091
1092   se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1093 }
1094
1095 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1096                       MODULO(A, P) = A - FLOOR (A / P) * P  */
1097 /* TODO: MOD(x, 0)  */
1098
1099 static void
1100 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1101 {
1102   tree type;
1103   tree itype;
1104   tree tmp;
1105   tree test;
1106   tree test2;
1107   mpfr_t huge;
1108   int n, ikind;
1109   tree args[2];
1110
1111   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1112
1113   switch (expr->ts.type)
1114     {
1115     case BT_INTEGER:
1116       /* Integer case is easy, we've got a builtin op.  */
1117       type = TREE_TYPE (args[0]);
1118
1119       if (modulo)
1120        se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1121       else
1122        se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1123       break;
1124
1125     case BT_REAL:
1126       n = END_BUILTINS;
1127       /* Check if we have a builtin fmod.  */
1128       switch (expr->ts.kind)
1129         {
1130         case 4:
1131           n = BUILT_IN_FMODF;
1132           break;
1133
1134         case 8:
1135           n = BUILT_IN_FMOD;
1136           break;
1137
1138         case 10:
1139         case 16:
1140           n = BUILT_IN_FMODL;
1141           break;
1142
1143         default:
1144           break;
1145         }
1146
1147       /* Use it if it exists.  */
1148       if (n != END_BUILTINS)
1149         {
1150           tmp = build_addr (built_in_decls[n], current_function_decl);
1151           se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1152                                        tmp, 2, args);
1153           if (modulo == 0)
1154             return;
1155         }
1156
1157       type = TREE_TYPE (args[0]);
1158
1159       args[0] = gfc_evaluate_now (args[0], &se->pre);
1160       args[1] = gfc_evaluate_now (args[1], &se->pre);
1161
1162       /* Definition:
1163          modulo = arg - floor (arg/arg2) * arg2, so
1164                 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1165          where
1166           test  = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1167          thereby avoiding another division and retaining the accuracy
1168          of the builtin function.  */
1169       if (n != END_BUILTINS && modulo)
1170         {
1171           tree zero = gfc_build_const (type, integer_zero_node);
1172           tmp = gfc_evaluate_now (se->expr, &se->pre);
1173           test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1174           test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1175           test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1176           test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1177           test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1178           test = gfc_evaluate_now (test, &se->pre);
1179           se->expr = fold_build3 (COND_EXPR, type, test,
1180                                   fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1181                                   tmp);
1182           return;
1183         }
1184
1185       /* If we do not have a built_in fmod, the calculation is going to
1186          have to be done longhand.  */
1187       tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1188
1189       /* Test if the value is too large to handle sensibly.  */
1190       gfc_set_model_kind (expr->ts.kind);
1191       mpfr_init (huge);
1192       n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1193       ikind = expr->ts.kind;
1194       if (n < 0)
1195         {
1196           n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1197           ikind = gfc_max_integer_kind;
1198         }
1199       mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1200       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1201       test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1202
1203       mpfr_neg (huge, huge, GFC_RND_MODE);
1204       test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1205       test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1206       test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1207
1208       itype = gfc_get_int_type (ikind);
1209       if (modulo)
1210        tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1211       else
1212        tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1213       tmp = convert (type, tmp);
1214       tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1215       tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1216       se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1217       mpfr_clear (huge);
1218       break;
1219
1220     default:
1221       gcc_unreachable ();
1222     }
1223 }
1224
1225 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y.  */
1226
1227 static void
1228 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1229 {
1230   tree val;
1231   tree tmp;
1232   tree type;
1233   tree zero;
1234   tree args[2];
1235
1236   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1237   type = TREE_TYPE (args[0]);
1238
1239   val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1240   val = gfc_evaluate_now (val, &se->pre);
1241
1242   zero = gfc_build_const (type, integer_zero_node);
1243   tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1244   se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1245 }
1246
1247
1248 /* SIGN(A, B) is absolute value of A times sign of B.
1249    The real value versions use library functions to ensure the correct
1250    handling of negative zero.  Integer case implemented as:
1251    SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1252   */
1253
1254 static void
1255 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1256 {
1257   tree tmp;
1258   tree type;
1259   tree args[2];
1260
1261   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1262   if (expr->ts.type == BT_REAL)
1263     {
1264       switch (expr->ts.kind)
1265         {
1266         case 4:
1267           tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1268           break;
1269         case 8:
1270           tmp = built_in_decls[BUILT_IN_COPYSIGN];
1271           break;
1272         case 10:
1273         case 16:
1274           tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1275           break;
1276         default:
1277           gcc_unreachable ();
1278         }
1279       se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1280       return;
1281     }
1282
1283   /* Having excluded floating point types, we know we are now dealing
1284      with signed integer types.  */
1285   type = TREE_TYPE (args[0]);
1286
1287   /* Args[0] is used multiple times below.  */
1288   args[0] = gfc_evaluate_now (args[0], &se->pre);
1289
1290   /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1291      the signs of A and B are the same, and of all ones if they differ.  */
1292   tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1293   tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1294                      build_int_cst (type, TYPE_PRECISION (type) - 1));
1295   tmp = gfc_evaluate_now (tmp, &se->pre);
1296
1297   /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1298      is all ones (i.e. -1).  */
1299   se->expr = fold_build2 (BIT_XOR_EXPR, type,
1300                           fold_build2 (PLUS_EXPR, type, args[0], tmp),
1301                           tmp);
1302 }
1303
1304
1305 /* Test for the presence of an optional argument.  */
1306
1307 static void
1308 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1309 {
1310   gfc_expr *arg;
1311
1312   arg = expr->value.function.actual->expr;
1313   gcc_assert (arg->expr_type == EXPR_VARIABLE);
1314   se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1315   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1316 }
1317
1318
1319 /* Calculate the double precision product of two single precision values.  */
1320
1321 static void
1322 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1323 {
1324   tree type;
1325   tree args[2];
1326
1327   gfc_conv_intrinsic_function_args (se, expr, args, 2);
1328
1329   /* Convert the args to double precision before multiplying.  */
1330   type = gfc_typenode_for_spec (&expr->ts);
1331   args[0] = convert (type, args[0]);
1332   args[1] = convert (type, args[1]);
1333   se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1334 }
1335
1336
1337 /* Return a length one character string containing an ascii character.  */
1338
1339 static void
1340 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1341 {
1342   tree arg[2];
1343   tree var;
1344   tree type;
1345   unsigned int num_args;
1346
1347   num_args = gfc_intrinsic_argument_list_length (expr);
1348   gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1349
1350   type = gfc_get_char_type (expr->ts.kind);
1351   var = gfc_create_var (type, "char");
1352
1353   arg[0] = fold_build1 (NOP_EXPR, type, arg[0]);
1354   gfc_add_modify (&se->pre, var, arg[0]);
1355   se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1356   se->string_length = integer_one_node;
1357 }
1358
1359
1360 static void
1361 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1362 {
1363   tree var;
1364   tree len;
1365   tree tmp;
1366   tree cond;
1367   tree fndecl;
1368   tree *args;
1369   unsigned int num_args;
1370
1371   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1372   args = (tree *) alloca (sizeof (tree) * num_args);
1373
1374   var = gfc_create_var (pchar_type_node, "pstr");
1375   len = gfc_create_var (gfc_get_int_type (8), "len");
1376
1377   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1378   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1379   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1380
1381   fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1382   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1383                           fndecl, num_args, args);
1384   gfc_add_expr_to_block (&se->pre, tmp);
1385
1386   /* Free the temporary afterwards, if necessary.  */
1387   cond = fold_build2 (GT_EXPR, boolean_type_node,
1388                       len, build_int_cst (TREE_TYPE (len), 0));
1389   tmp = gfc_call_free (var);
1390   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1391   gfc_add_expr_to_block (&se->post, tmp);
1392
1393   se->expr = var;
1394   se->string_length = len;
1395 }
1396
1397
1398 static void
1399 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1400 {
1401   tree var;
1402   tree len;
1403   tree tmp;
1404   tree cond;
1405   tree fndecl;
1406   tree *args;
1407   unsigned int num_args;
1408
1409   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1410   args = (tree *) alloca (sizeof (tree) * num_args);
1411
1412   var = gfc_create_var (pchar_type_node, "pstr");
1413   len = gfc_create_var (gfc_get_int_type (4), "len");
1414
1415   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1417   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1418
1419   fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1420   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1421                           fndecl, num_args, args);
1422   gfc_add_expr_to_block (&se->pre, tmp);
1423
1424   /* Free the temporary afterwards, if necessary.  */
1425   cond = fold_build2 (GT_EXPR, boolean_type_node,
1426                       len, build_int_cst (TREE_TYPE (len), 0));
1427   tmp = gfc_call_free (var);
1428   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429   gfc_add_expr_to_block (&se->post, tmp);
1430
1431   se->expr = var;
1432   se->string_length = len;
1433 }
1434
1435
1436 /* Return a character string containing the tty name.  */
1437
1438 static void
1439 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1440 {
1441   tree var;
1442   tree len;
1443   tree tmp;
1444   tree cond;
1445   tree fndecl;
1446   tree *args;
1447   unsigned int num_args;
1448
1449   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1450   args = (tree *) alloca (sizeof (tree) * num_args);
1451
1452   var = gfc_create_var (pchar_type_node, "pstr");
1453   len = gfc_create_var (gfc_get_int_type (4), "len");
1454
1455   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1456   args[0] = gfc_build_addr_expr (NULL_TREE, var);
1457   args[1] = gfc_build_addr_expr (NULL_TREE, len);
1458
1459   fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1460   tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1461                           fndecl, num_args, args);
1462   gfc_add_expr_to_block (&se->pre, tmp);
1463
1464   /* Free the temporary afterwards, if necessary.  */
1465   cond = fold_build2 (GT_EXPR, boolean_type_node,
1466                       len, build_int_cst (TREE_TYPE (len), 0));
1467   tmp = gfc_call_free (var);
1468   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1469   gfc_add_expr_to_block (&se->post, tmp);
1470
1471   se->expr = var;
1472   se->string_length = len;
1473 }
1474
1475
1476 /* Get the minimum/maximum value of all the parameters.
1477     minmax (a1, a2, a3, ...)
1478     {
1479       mvar = a1;
1480       if (a2 .op. mvar || isnan(mvar))
1481         mvar = a2;
1482       if (a3 .op. mvar || isnan(mvar))
1483         mvar = a3;
1484       ...
1485       return mvar
1486     }
1487  */
1488
1489 /* TODO: Mismatching types can occur when specific names are used.
1490    These should be handled during resolution.  */
1491 static void
1492 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1493 {
1494   tree tmp;
1495   tree mvar;
1496   tree val;
1497   tree thencase;
1498   tree *args;
1499   tree type;
1500   gfc_actual_arglist *argexpr;
1501   unsigned int i, nargs;
1502
1503   nargs = gfc_intrinsic_argument_list_length (expr);
1504   args = (tree *) alloca (sizeof (tree) * nargs);
1505
1506   gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1507   type = gfc_typenode_for_spec (&expr->ts);
1508
1509   argexpr = expr->value.function.actual;
1510   if (TREE_TYPE (args[0]) != type)
1511     args[0] = convert (type, args[0]);
1512   /* Only evaluate the argument once.  */
1513   if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1514     args[0] = gfc_evaluate_now (args[0], &se->pre);
1515
1516   mvar = gfc_create_var (type, "M");
1517   gfc_add_modify (&se->pre, mvar, args[0]);
1518   for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1519     {
1520       tree cond, isnan;
1521
1522       val = args[i];
1523
1524       /* Handle absent optional arguments by ignoring the comparison.  */
1525       if (argexpr->expr->expr_type == EXPR_VARIABLE
1526           && argexpr->expr->symtree->n.sym->attr.optional
1527           && TREE_CODE (val) == INDIRECT_REF)
1528         cond = fold_build2
1529                  (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1530                   build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1531       else
1532       {
1533         cond = NULL_TREE;
1534
1535         /* Only evaluate the argument once.  */
1536         if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1537           val = gfc_evaluate_now (val, &se->pre);
1538       }
1539
1540       thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1541
1542       tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1543
1544       /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1545          __builtin_isnan might be made dependent on that module being loaded,
1546          to help performance of programs that don't rely on IEEE semantics.  */
1547       if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1548         {
1549           isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1550           tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1551                              fold_convert (boolean_type_node, isnan));
1552         }
1553       tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
1554
1555       if (cond != NULL_TREE)
1556         tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1557
1558       gfc_add_expr_to_block (&se->pre, tmp);
1559       argexpr = argexpr->next;
1560     }
1561   se->expr = mvar;
1562 }
1563
1564
1565 /* Generate library calls for MIN and MAX intrinsics for character
1566    variables.  */
1567 static void
1568 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1569 {
1570   tree *args;
1571   tree var, len, fndecl, tmp, cond, function;
1572   unsigned int nargs;
1573
1574   nargs = gfc_intrinsic_argument_list_length (expr);
1575   args = (tree *) alloca (sizeof (tree) * (nargs + 4));
1576   gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1577
1578   /* Create the result variables.  */
1579   len = gfc_create_var (gfc_charlen_type_node, "len");
1580   args[0] = gfc_build_addr_expr (NULL_TREE, len);
1581   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
1582   args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1583   args[2] = build_int_cst (NULL_TREE, op);
1584   args[3] = build_int_cst (NULL_TREE, nargs / 2);
1585
1586   if (expr->ts.kind == 1)
1587     function = gfor_fndecl_string_minmax;
1588   else if (expr->ts.kind == 4)
1589     function = gfor_fndecl_string_minmax_char4;
1590   else
1591     gcc_unreachable ();
1592
1593   /* Make the function call.  */
1594   fndecl = build_addr (function, current_function_decl);
1595   tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
1596                           nargs + 4, args);
1597   gfc_add_expr_to_block (&se->pre, tmp);
1598
1599   /* Free the temporary afterwards, if necessary.  */
1600   cond = fold_build2 (GT_EXPR, boolean_type_node,
1601                       len, build_int_cst (TREE_TYPE (len), 0));
1602   tmp = gfc_call_free (var);
1603   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1604   gfc_add_expr_to_block (&se->post, tmp);
1605
1606   se->expr = var;
1607   se->string_length = len;
1608 }
1609
1610
1611 /* Create a symbol node for this intrinsic.  The symbol from the frontend
1612    has the generic name.  */
1613
1614 static gfc_symbol *
1615 gfc_get_symbol_for_expr (gfc_expr * expr)
1616 {
1617   gfc_symbol *sym;
1618
1619   /* TODO: Add symbols for intrinsic function to the global namespace.  */
1620   gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1621   sym = gfc_new_symbol (expr->value.function.name, NULL);
1622
1623   sym->ts = expr->ts;
1624   sym->attr.external = 1;
1625   sym->attr.function = 1;
1626   sym->attr.always_explicit = 1;
1627   sym->attr.proc = PROC_INTRINSIC;
1628   sym->attr.flavor = FL_PROCEDURE;
1629   sym->result = sym;
1630   if (expr->rank > 0)
1631     {
1632       sym->attr.dimension = 1;
1633       sym->as = gfc_get_array_spec ();
1634       sym->as->type = AS_ASSUMED_SHAPE;
1635       sym->as->rank = expr->rank;
1636     }
1637
1638   /* TODO: proper argument lists for external intrinsics.  */
1639   return sym;
1640 }
1641
1642 /* Generate a call to an external intrinsic function.  */
1643 static void
1644 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1645 {
1646   gfc_symbol *sym;
1647   tree append_args;
1648
1649   gcc_assert (!se->ss || se->ss->expr == expr);
1650
1651   if (se->ss)
1652     gcc_assert (expr->rank > 0);
1653   else
1654     gcc_assert (expr->rank == 0);
1655
1656   sym = gfc_get_symbol_for_expr (expr);
1657
1658   /* Calls to libgfortran_matmul need to be appended special arguments,
1659      to be able to call the BLAS ?gemm functions if required and possible.  */
1660   append_args = NULL_TREE;
1661   if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1662       && sym->ts.type != BT_LOGICAL)
1663     {
1664       tree cint = gfc_get_int_type (gfc_c_int_kind);
1665
1666       if (gfc_option.flag_external_blas
1667           && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1668           && (sym->ts.kind == gfc_default_real_kind
1669               || sym->ts.kind == gfc_default_double_kind))
1670         {
1671           tree gemm_fndecl;
1672
1673           if (sym->ts.type == BT_REAL)
1674             {
1675               if (sym->ts.kind == gfc_default_real_kind)
1676                 gemm_fndecl = gfor_fndecl_sgemm;
1677               else
1678                 gemm_fndecl = gfor_fndecl_dgemm;
1679             }
1680           else
1681             {
1682               if (sym->ts.kind == gfc_default_real_kind)
1683                 gemm_fndecl = gfor_fndecl_cgemm;
1684               else
1685                 gemm_fndecl = gfor_fndecl_zgemm;
1686             }
1687
1688           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1689           append_args = gfc_chainon_list
1690                           (append_args, build_int_cst
1691                                           (cint, gfc_option.blas_matmul_limit));
1692           append_args = gfc_chainon_list (append_args,
1693                                           gfc_build_addr_expr (NULL_TREE,
1694                                                                gemm_fndecl));
1695         }
1696       else
1697         {
1698           append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1699           append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1700           append_args = gfc_chainon_list (append_args, null_pointer_node);
1701         }
1702     }
1703
1704   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1705   gfc_free (sym);
1706 }
1707
1708 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1709    Implemented as
1710     any(a)
1711     {
1712       forall (i=...)
1713         if (a[i] != 0)
1714           return 1
1715       end forall
1716       return 0
1717     }
1718     all(a)
1719     {
1720       forall (i=...)
1721         if (a[i] == 0)
1722           return 0
1723       end forall
1724       return 1
1725     }
1726  */
1727 static void
1728 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1729 {
1730   tree resvar;
1731   stmtblock_t block;
1732   stmtblock_t body;
1733   tree type;
1734   tree tmp;
1735   tree found;
1736   gfc_loopinfo loop;
1737   gfc_actual_arglist *actual;
1738   gfc_ss *arrayss;
1739   gfc_se arrayse;
1740   tree exit_label;
1741
1742   if (se->ss)
1743     {
1744       gfc_conv_intrinsic_funcall (se, expr);
1745       return;
1746     }
1747
1748   actual = expr->value.function.actual;
1749   type = gfc_typenode_for_spec (&expr->ts);
1750   /* Initialize the result.  */
1751   resvar = gfc_create_var (type, "test");
1752   if (op == EQ_EXPR)
1753     tmp = convert (type, boolean_true_node);
1754   else
1755     tmp = convert (type, boolean_false_node);
1756   gfc_add_modify (&se->pre, resvar, tmp);
1757
1758   /* Walk the arguments.  */
1759   arrayss = gfc_walk_expr (actual->expr);
1760   gcc_assert (arrayss != gfc_ss_terminator);
1761
1762   /* Initialize the scalarizer.  */
1763   gfc_init_loopinfo (&loop);
1764   exit_label = gfc_build_label_decl (NULL_TREE);
1765   TREE_USED (exit_label) = 1;
1766   gfc_add_ss_to_loop (&loop, arrayss);
1767
1768   /* Initialize the loop.  */
1769   gfc_conv_ss_startstride (&loop);
1770   gfc_conv_loop_setup (&loop, &expr->where);
1771
1772   gfc_mark_ss_chain_used (arrayss, 1);
1773   /* Generate the loop body.  */
1774   gfc_start_scalarized_body (&loop, &body);
1775
1776   /* If the condition matches then set the return value.  */
1777   gfc_start_block (&block);
1778   if (op == EQ_EXPR)
1779     tmp = convert (type, boolean_false_node);
1780   else
1781     tmp = convert (type, boolean_true_node);
1782   gfc_add_modify (&block, resvar, tmp);
1783
1784   /* And break out of the loop.  */
1785   tmp = build1_v (GOTO_EXPR, exit_label);
1786   gfc_add_expr_to_block (&block, tmp);
1787
1788   found = gfc_finish_block (&block);
1789
1790   /* Check this element.  */
1791   gfc_init_se (&arrayse, NULL);
1792   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1793   arrayse.ss = arrayss;
1794   gfc_conv_expr_val (&arrayse, actual->expr);
1795
1796   gfc_add_block_to_block (&body, &arrayse.pre);
1797   tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1798                      build_int_cst (TREE_TYPE (arrayse.expr), 0));
1799   tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1800   gfc_add_expr_to_block (&body, tmp);
1801   gfc_add_block_to_block (&body, &arrayse.post);
1802
1803   gfc_trans_scalarizing_loops (&loop, &body);
1804
1805   /* Add the exit label.  */
1806   tmp = build1_v (LABEL_EXPR, exit_label);
1807   gfc_add_expr_to_block (&loop.pre, tmp);
1808
1809   gfc_add_block_to_block (&se->pre, &loop.pre);
1810   gfc_add_block_to_block (&se->pre, &loop.post);
1811   gfc_cleanup_loop (&loop);
1812
1813   se->expr = resvar;
1814 }
1815
1816 /* COUNT(A) = Number of true elements in A.  */
1817 static void
1818 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1819 {
1820   tree resvar;
1821   tree type;
1822   stmtblock_t body;
1823   tree tmp;
1824   gfc_loopinfo loop;
1825   gfc_actual_arglist *actual;
1826   gfc_ss *arrayss;
1827   gfc_se arrayse;
1828
1829   if (se->ss)
1830     {
1831       gfc_conv_intrinsic_funcall (se, expr);
1832       return;
1833     }
1834
1835   actual = expr->value.function.actual;
1836
1837   type = gfc_typenode_for_spec (&expr->ts);
1838   /* Initialize the result.  */
1839   resvar = gfc_create_var (type, "count");
1840   gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
1841
1842   /* Walk the arguments.  */
1843   arrayss = gfc_walk_expr (actual->expr);
1844   gcc_assert (arrayss != gfc_ss_terminator);
1845
1846   /* Initialize the scalarizer.  */
1847   gfc_init_loopinfo (&loop);
1848   gfc_add_ss_to_loop (&loop, arrayss);
1849
1850   /* Initialize the loop.  */
1851   gfc_conv_ss_startstride (&loop);
1852   gfc_conv_loop_setup (&loop, &expr->where);
1853
1854   gfc_mark_ss_chain_used (arrayss, 1);
1855   /* Generate the loop body.  */
1856   gfc_start_scalarized_body (&loop, &body);
1857
1858   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1859                      resvar, build_int_cst (TREE_TYPE (resvar), 1));
1860   tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1861
1862   gfc_init_se (&arrayse, NULL);
1863   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1864   arrayse.ss = arrayss;
1865   gfc_conv_expr_val (&arrayse, actual->expr);
1866   tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1867
1868   gfc_add_block_to_block (&body, &arrayse.pre);
1869   gfc_add_expr_to_block (&body, tmp);
1870   gfc_add_block_to_block (&body, &arrayse.post);
1871
1872   gfc_trans_scalarizing_loops (&loop, &body);
1873
1874   gfc_add_block_to_block (&se->pre, &loop.pre);
1875   gfc_add_block_to_block (&se->pre, &loop.post);
1876   gfc_cleanup_loop (&loop);
1877
1878   se->expr = resvar;
1879 }
1880
1881 /* Inline implementation of the sum and product intrinsics.  */
1882 static void
1883 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1884 {
1885   tree resvar;
1886   tree type;
1887   stmtblock_t body;
1888   stmtblock_t block;
1889   tree tmp;
1890   gfc_loopinfo loop;
1891   gfc_actual_arglist *actual;
1892   gfc_ss *arrayss;
1893   gfc_ss *maskss;
1894   gfc_se arrayse;
1895   gfc_se maskse;
1896   gfc_expr *arrayexpr;
1897   gfc_expr *maskexpr;
1898
1899   if (se->ss)
1900     {
1901       gfc_conv_intrinsic_funcall (se, expr);
1902       return;
1903     }
1904
1905   type = gfc_typenode_for_spec (&expr->ts);
1906   /* Initialize the result.  */
1907   resvar = gfc_create_var (type, "val");
1908   if (op == PLUS_EXPR)
1909     tmp = gfc_build_const (type, integer_zero_node);
1910   else
1911     tmp = gfc_build_const (type, integer_one_node);
1912
1913   gfc_add_modify (&se->pre, resvar, tmp);
1914
1915   /* Walk the arguments.  */
1916   actual = expr->value.function.actual;
1917   arrayexpr = actual->expr;
1918   arrayss = gfc_walk_expr (arrayexpr);
1919   gcc_assert (arrayss != gfc_ss_terminator);
1920
1921   actual = actual->next->next;
1922   gcc_assert (actual);
1923   maskexpr = actual->expr;
1924   if (maskexpr && maskexpr->rank != 0)
1925     {
1926       maskss = gfc_walk_expr (maskexpr);
1927       gcc_assert (maskss != gfc_ss_terminator);
1928     }
1929   else
1930     maskss = NULL;
1931
1932   /* Initialize the scalarizer.  */
1933   gfc_init_loopinfo (&loop);
1934   gfc_add_ss_to_loop (&loop, arrayss);
1935   if (maskss)
1936     gfc_add_ss_to_loop (&loop, maskss);
1937
1938   /* Initialize the loop.  */
1939   gfc_conv_ss_startstride (&loop);
1940   gfc_conv_loop_setup (&loop, &expr->where);
1941
1942   gfc_mark_ss_chain_used (arrayss, 1);
1943   if (maskss)
1944     gfc_mark_ss_chain_used (maskss, 1);
1945   /* Generate the loop body.  */
1946   gfc_start_scalarized_body (&loop, &body);
1947
1948   /* If we have a mask, only add this element if the mask is set.  */
1949   if (maskss)
1950     {
1951       gfc_init_se (&maskse, NULL);
1952       gfc_copy_loopinfo_to_se (&maskse, &loop);
1953       maskse.ss = maskss;
1954       gfc_conv_expr_val (&maskse, maskexpr);
1955       gfc_add_block_to_block (&body, &maskse.pre);
1956
1957       gfc_start_block (&block);
1958     }
1959   else
1960     gfc_init_block (&block);
1961
1962   /* Do the actual summation/product.  */
1963   gfc_init_se (&arrayse, NULL);
1964   gfc_copy_loopinfo_to_se (&arrayse, &loop);
1965   arrayse.ss = arrayss;
1966   gfc_conv_expr_val (&arrayse, arrayexpr);
1967   gfc_add_block_to_block (&block, &arrayse.pre);
1968
1969   tmp = fold_build2 (op, type, resvar, arrayse.expr);
1970   gfc_add_modify (&block, resvar, tmp);
1971   gfc_add_block_to_block (&block, &arrayse.post);
1972
1973   if (maskss)
1974     {
1975       /* We enclose the above in if (mask) {...} .  */
1976       tmp = gfc_finish_block (&block);
1977
1978       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1979     }
1980   else
1981     tmp = gfc_finish_block (&block);
1982   gfc_add_expr_to_block (&body, tmp);
1983
1984   gfc_trans_scalarizing_loops (&loop, &body);
1985
1986   /* For a scalar mask, enclose the loop in an if statement.  */
1987   if (maskexpr && maskss == NULL)
1988     {
1989       gfc_init_se (&maskse, NULL);
1990       gfc_conv_expr_val (&maskse, maskexpr);
1991       gfc_init_block (&block);
1992       gfc_add_block_to_block (&block, &loop.pre);
1993       gfc_add_block_to_block (&block, &loop.post);
1994       tmp = gfc_finish_block (&block);
1995
1996       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1997       gfc_add_expr_to_block (&block, tmp);
1998       gfc_add_block_to_block (&se->pre, &block);
1999     }
2000   else
2001     {
2002       gfc_add_block_to_block (&se->pre, &loop.pre);
2003       gfc_add_block_to_block (&se->pre, &loop.post);
2004     }
2005
2006   gfc_cleanup_loop (&loop);
2007
2008   se->expr = resvar;
2009 }
2010
2011
2012 /* Inline implementation of the dot_product intrinsic. This function
2013    is based on gfc_conv_intrinsic_arith (the previous function).  */
2014 static void
2015 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2016 {
2017   tree resvar;
2018   tree type;
2019   stmtblock_t body;
2020   stmtblock_t block;
2021   tree tmp;
2022   gfc_loopinfo loop;
2023   gfc_actual_arglist *actual;
2024   gfc_ss *arrayss1, *arrayss2;
2025   gfc_se arrayse1, arrayse2;
2026   gfc_expr *arrayexpr1, *arrayexpr2;
2027
2028   type = gfc_typenode_for_spec (&expr->ts);
2029
2030   /* Initialize the result.  */
2031   resvar = gfc_create_var (type, "val");
2032   if (expr->ts.type == BT_LOGICAL)
2033     tmp = build_int_cst (type, 0);
2034   else
2035     tmp = gfc_build_const (type, integer_zero_node);
2036
2037   gfc_add_modify (&se->pre, resvar, tmp);
2038
2039   /* Walk argument #1.  */
2040   actual = expr->value.function.actual;
2041   arrayexpr1 = actual->expr;
2042   arrayss1 = gfc_walk_expr (arrayexpr1);
2043   gcc_assert (arrayss1 != gfc_ss_terminator);
2044
2045   /* Walk argument #2.  */
2046   actual = actual->next;
2047   arrayexpr2 = actual->expr;
2048   arrayss2 = gfc_walk_expr (arrayexpr2);
2049   gcc_assert (arrayss2 != gfc_ss_terminator);
2050
2051   /* Initialize the scalarizer.  */
2052   gfc_init_loopinfo (&loop);
2053   gfc_add_ss_to_loop (&loop, arrayss1);
2054   gfc_add_ss_to_loop (&loop, arrayss2);
2055
2056   /* Initialize the loop.  */
2057   gfc_conv_ss_startstride (&loop);
2058   gfc_conv_loop_setup (&loop, &expr->where);
2059
2060   gfc_mark_ss_chain_used (arrayss1, 1);
2061   gfc_mark_ss_chain_used (arrayss2, 1);
2062
2063   /* Generate the loop body.  */
2064   gfc_start_scalarized_body (&loop, &body);
2065   gfc_init_block (&block);
2066
2067   /* Make the tree expression for [conjg(]array1[)].  */
2068   gfc_init_se (&arrayse1, NULL);
2069   gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2070   arrayse1.ss = arrayss1;
2071   gfc_conv_expr_val (&arrayse1, arrayexpr1);
2072   if (expr->ts.type == BT_COMPLEX)
2073     arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2074   gfc_add_block_to_block (&block, &arrayse1.pre);
2075
2076   /* Make the tree expression for array2.  */
2077   gfc_init_se (&arrayse2, NULL);
2078   gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2079   arrayse2.ss = arrayss2;
2080   gfc_conv_expr_val (&arrayse2, arrayexpr2);
2081   gfc_add_block_to_block (&block, &arrayse2.pre);
2082
2083   /* Do the actual product and sum.  */
2084   if (expr->ts.type == BT_LOGICAL)
2085     {
2086       tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2087       tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2088     }
2089   else
2090     {
2091       tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2092       tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2093     }
2094   gfc_add_modify (&block, resvar, tmp);
2095
2096   /* Finish up the loop block and the loop.  */
2097   tmp = gfc_finish_block (&block);
2098   gfc_add_expr_to_block (&body, tmp);
2099
2100   gfc_trans_scalarizing_loops (&loop, &body);
2101   gfc_add_block_to_block (&se->pre, &loop.pre);
2102   gfc_add_block_to_block (&se->pre, &loop.post);
2103   gfc_cleanup_loop (&loop);
2104
2105   se->expr = resvar;
2106 }
2107
2108
2109 static void
2110 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2111 {
2112   stmtblock_t body;
2113   stmtblock_t block;
2114   stmtblock_t ifblock;
2115   stmtblock_t elseblock;
2116   tree limit;
2117   tree type;
2118   tree tmp;
2119   tree elsetmp;
2120   tree ifbody;
2121   tree offset;
2122   gfc_loopinfo loop;
2123   gfc_actual_arglist *actual;
2124   gfc_ss *arrayss;
2125   gfc_ss *maskss;
2126   gfc_se arrayse;
2127   gfc_se maskse;
2128   gfc_expr *arrayexpr;
2129   gfc_expr *maskexpr;
2130   tree pos;
2131   int n;
2132
2133   if (se->ss)
2134     {
2135       gfc_conv_intrinsic_funcall (se, expr);
2136       return;
2137     }
2138
2139   /* Initialize the result.  */
2140   pos = gfc_create_var (gfc_array_index_type, "pos");
2141   offset = gfc_create_var (gfc_array_index_type, "offset");
2142   type = gfc_typenode_for_spec (&expr->ts);
2143
2144   /* Walk the arguments.  */
2145   actual = expr->value.function.actual;
2146   arrayexpr = actual->expr;
2147   arrayss = gfc_walk_expr (arrayexpr);
2148   gcc_assert (arrayss != gfc_ss_terminator);
2149
2150   actual = actual->next->next;
2151   gcc_assert (actual);
2152   maskexpr = actual->expr;
2153   if (maskexpr && maskexpr->rank != 0)
2154     {
2155       maskss = gfc_walk_expr (maskexpr);
2156       gcc_assert (maskss != gfc_ss_terminator);
2157     }
2158   else
2159     maskss = NULL;
2160
2161   limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2162   n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2163   switch (arrayexpr->ts.type)
2164     {
2165     case BT_REAL:
2166       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
2167                                    arrayexpr->ts.kind, 0);
2168       break;
2169
2170     case BT_INTEGER:
2171       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2172                                   arrayexpr->ts.kind);
2173       break;
2174
2175     default:
2176       gcc_unreachable ();
2177     }
2178
2179   /* We start with the most negative possible value for MAXLOC, and the most
2180      positive possible value for MINLOC. The most negative possible value is
2181      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2182      possible value is HUGE in both cases.  */
2183   if (op == GT_EXPR)
2184     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2185   gfc_add_modify (&se->pre, limit, tmp);
2186
2187   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2188     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2189                        build_int_cst (type, 1));
2190
2191   /* Initialize the scalarizer.  */
2192   gfc_init_loopinfo (&loop);
2193   gfc_add_ss_to_loop (&loop, arrayss);
2194   if (maskss)
2195     gfc_add_ss_to_loop (&loop, maskss);
2196
2197   /* Initialize the loop.  */
2198   gfc_conv_ss_startstride (&loop);
2199   gfc_conv_loop_setup (&loop, &expr->where);
2200
2201   gcc_assert (loop.dimen == 1);
2202
2203   /* Initialize the position to zero, following Fortran 2003.  We are free
2204      to do this because Fortran 95 allows the result of an entirely false
2205      mask to be processor dependent.  */
2206   gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
2207
2208   gfc_mark_ss_chain_used (arrayss, 1);
2209   if (maskss)
2210     gfc_mark_ss_chain_used (maskss, 1);
2211   /* Generate the loop body.  */
2212   gfc_start_scalarized_body (&loop, &body);
2213
2214   /* If we have a mask, only check this element if the mask is set.  */
2215   if (maskss)
2216     {
2217       gfc_init_se (&maskse, NULL);
2218       gfc_copy_loopinfo_to_se (&maskse, &loop);
2219       maskse.ss = maskss;
2220       gfc_conv_expr_val (&maskse, maskexpr);
2221       gfc_add_block_to_block (&body, &maskse.pre);
2222
2223       gfc_start_block (&block);
2224     }
2225   else
2226     gfc_init_block (&block);
2227
2228   /* Compare with the current limit.  */
2229   gfc_init_se (&arrayse, NULL);
2230   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2231   arrayse.ss = arrayss;
2232   gfc_conv_expr_val (&arrayse, arrayexpr);
2233   gfc_add_block_to_block (&block, &arrayse.pre);
2234
2235   /* We do the following if this is a more extreme value.  */
2236   gfc_start_block (&ifblock);
2237
2238   /* Assign the value to the limit...  */
2239   gfc_add_modify (&ifblock, limit, arrayse.expr);
2240
2241   /* Remember where we are.  An offset must be added to the loop
2242      counter to obtain the required position.  */
2243   if (loop.from[0])
2244     tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2245                        gfc_index_one_node, loop.from[0]);
2246   else
2247     tmp = gfc_index_one_node;
2248
2249   gfc_add_modify (&block, offset, tmp);
2250
2251   tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2252                      loop.loopvar[0], offset);
2253   gfc_add_modify (&ifblock, pos, tmp);
2254
2255   ifbody = gfc_finish_block (&ifblock);
2256
2257   /* If it is a more extreme value or pos is still zero and the value
2258      equal to the limit.  */
2259   tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2260                      fold_build2 (EQ_EXPR, boolean_type_node,
2261                                   pos, gfc_index_zero_node),
2262                      fold_build2 (EQ_EXPR, boolean_type_node,
2263                                   arrayse.expr, limit));
2264   tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2265                      fold_build2 (op, boolean_type_node,
2266                                   arrayse.expr, limit), tmp);
2267   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2268   gfc_add_expr_to_block (&block, tmp);
2269
2270   if (maskss)
2271     {
2272       /* We enclose the above in if (mask) {...}.  */
2273       tmp = gfc_finish_block (&block);
2274
2275       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2276     }
2277   else
2278     tmp = gfc_finish_block (&block);
2279   gfc_add_expr_to_block (&body, tmp);
2280
2281   gfc_trans_scalarizing_loops (&loop, &body);
2282
2283   /* For a scalar mask, enclose the loop in an if statement.  */
2284   if (maskexpr && maskss == NULL)
2285     {
2286       gfc_init_se (&maskse, NULL);
2287       gfc_conv_expr_val (&maskse, maskexpr);
2288       gfc_init_block (&block);
2289       gfc_add_block_to_block (&block, &loop.pre);
2290       gfc_add_block_to_block (&block, &loop.post);
2291       tmp = gfc_finish_block (&block);
2292
2293       /* For the else part of the scalar mask, just initialize
2294          the pos variable the same way as above.  */
2295
2296       gfc_init_block (&elseblock);
2297       gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
2298       elsetmp = gfc_finish_block (&elseblock);
2299
2300       tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2301       gfc_add_expr_to_block (&block, tmp);
2302       gfc_add_block_to_block (&se->pre, &block);
2303     }
2304   else
2305     {
2306       gfc_add_block_to_block (&se->pre, &loop.pre);
2307       gfc_add_block_to_block (&se->pre, &loop.post);
2308     }
2309   gfc_cleanup_loop (&loop);
2310
2311   se->expr = convert (type, pos);
2312 }
2313
2314 static void
2315 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2316 {
2317   tree limit;
2318   tree type;
2319   tree tmp;
2320   tree ifbody;
2321   stmtblock_t body;
2322   stmtblock_t block;
2323   gfc_loopinfo loop;
2324   gfc_actual_arglist *actual;
2325   gfc_ss *arrayss;
2326   gfc_ss *maskss;
2327   gfc_se arrayse;
2328   gfc_se maskse;
2329   gfc_expr *arrayexpr;
2330   gfc_expr *maskexpr;
2331   int n;
2332
2333   if (se->ss)
2334     {
2335       gfc_conv_intrinsic_funcall (se, expr);
2336       return;
2337     }
2338
2339   type = gfc_typenode_for_spec (&expr->ts);
2340   /* Initialize the result.  */
2341   limit = gfc_create_var (type, "limit");
2342   n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2343   switch (expr->ts.type)
2344     {
2345     case BT_REAL:
2346       tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind, 0);
2347       break;
2348
2349     case BT_INTEGER:
2350       tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2351       break;
2352
2353     default:
2354       gcc_unreachable ();
2355     }
2356
2357   /* We start with the most negative possible value for MAXVAL, and the most
2358      positive possible value for MINVAL. The most negative possible value is
2359      -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2360      possible value is HUGE in both cases.  */
2361   if (op == GT_EXPR)
2362     tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2363
2364   if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2365     tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2366                        tmp, build_int_cst (type, 1));
2367
2368   gfc_add_modify (&se->pre, limit, tmp);
2369
2370   /* Walk the arguments.  */
2371   actual = expr->value.function.actual;
2372   arrayexpr = actual->expr;
2373   arrayss = gfc_walk_expr (arrayexpr);
2374   gcc_assert (arrayss != gfc_ss_terminator);
2375
2376   actual = actual->next->next;
2377   gcc_assert (actual);
2378   maskexpr = actual->expr;
2379   if (maskexpr && maskexpr->rank != 0)
2380     {
2381       maskss = gfc_walk_expr (maskexpr);
2382       gcc_assert (maskss != gfc_ss_terminator);
2383     }
2384   else
2385     maskss = NULL;
2386
2387   /* Initialize the scalarizer.  */
2388   gfc_init_loopinfo (&loop);
2389   gfc_add_ss_to_loop (&loop, arrayss);
2390   if (maskss)
2391     gfc_add_ss_to_loop (&loop, maskss);
2392
2393   /* Initialize the loop.  */
2394   gfc_conv_ss_startstride (&loop);
2395   gfc_conv_loop_setup (&loop, &expr->where);
2396
2397   gfc_mark_ss_chain_used (arrayss, 1);
2398   if (maskss)
2399     gfc_mark_ss_chain_used (maskss, 1);
2400   /* Generate the loop body.  */
2401   gfc_start_scalarized_body (&loop, &body);
2402
2403   /* If we have a mask, only add this element if the mask is set.  */
2404   if (maskss)
2405     {
2406       gfc_init_se (&maskse, NULL);
2407       gfc_copy_loopinfo_to_se (&maskse, &loop);
2408       maskse.ss = maskss;
2409       gfc_conv_expr_val (&maskse, maskexpr);
2410       gfc_add_block_to_block (&body, &maskse.pre);
2411
2412       gfc_start_block (&block);
2413     }
2414   else
2415     gfc_init_block (&block);
2416
2417   /* Compare with the current limit.  */
2418   gfc_init_se (&arrayse, NULL);
2419   gfc_copy_loopinfo_to_se (&arrayse, &loop);
2420   arrayse.ss = arrayss;
2421   gfc_conv_expr_val (&arrayse, arrayexpr);
2422   gfc_add_block_to_block (&block, &arrayse.pre);
2423
2424   /* Assign the value to the limit...  */
2425   ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2426
2427   /* If it is a more extreme value.  */
2428   tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2429   tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2430   gfc_add_expr_to_block (&block, tmp);
2431   gfc_add_block_to_block (&block, &arrayse.post);
2432
2433   tmp = gfc_finish_block (&block);
2434   if (maskss)
2435     /* We enclose the above in if (mask) {...}.  */
2436     tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2437   gfc_add_expr_to_block (&body, tmp);
2438
2439   gfc_trans_scalarizing_loops (&loop, &body);
2440
2441   /* For a scalar mask, enclose the loop in an if statement.  */
2442   if (maskexpr && maskss == NULL)
2443     {
2444       gfc_init_se (&maskse, NULL);
2445       gfc_conv_expr_val (&maskse, maskexpr);
2446       gfc_init_block (&block);
2447       gfc_add_block_to_block (&block, &loop.pre);
2448       gfc_add_block_to_block (&block, &loop.post);
2449       tmp = gfc_finish_block (&block);
2450
2451       tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2452       gfc_add_expr_to_block (&block, tmp);
2453       gfc_add_block_to_block (&se->pre, &block);
2454     }
2455   else
2456     {
2457       gfc_add_block_to_block (&se->pre, &loop.pre);
2458       gfc_add_block_to_block (&se->pre, &loop.post);
2459     }
2460
2461   gfc_cleanup_loop (&loop);
2462
2463   se->expr = limit;
2464 }
2465
2466 /* BTEST (i, pos) = (i & (1 << pos)) != 0.  */
2467 static void
2468 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2469 {
2470   tree args[2];
2471   tree type;
2472   tree tmp;
2473
2474   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2475   type = TREE_TYPE (args[0]);
2476
2477   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2478   tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2479   tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2480                      build_int_cst (type, 0));
2481   type = gfc_typenode_for_spec (&expr->ts);
2482   se->expr = convert (type, tmp);
2483 }
2484
2485 /* Generate code to perform the specified operation.  */
2486 static void
2487 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2488 {
2489   tree args[2];
2490
2491   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2492   se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2493 }
2494
2495 /* Bitwise not.  */
2496 static void
2497 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2498 {
2499   tree arg;
2500
2501   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2502   se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2503 }
2504
2505 /* Set or clear a single bit.  */
2506 static void
2507 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2508 {
2509   tree args[2];
2510   tree type;
2511   tree tmp;
2512   int op;
2513
2514   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2515   type = TREE_TYPE (args[0]);
2516
2517   tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2518   if (set)
2519     op = BIT_IOR_EXPR;
2520   else
2521     {
2522       op = BIT_AND_EXPR;
2523       tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2524     }
2525   se->expr = fold_build2 (op, type, args[0], tmp);
2526 }
2527
2528 /* Extract a sequence of bits.
2529     IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN).  */
2530 static void
2531 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2532 {
2533   tree args[3];
2534   tree type;
2535   tree tmp;
2536   tree mask;
2537
2538   gfc_conv_intrinsic_function_args (se, expr, args, 3);
2539   type = TREE_TYPE (args[0]);
2540
2541   mask = build_int_cst (type, -1);
2542   mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2543   mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2544
2545   tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2546
2547   se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2548 }
2549
2550 /* RSHIFT (I, SHIFT) = I >> SHIFT
2551    LSHIFT (I, SHIFT) = I << SHIFT  */
2552 static void
2553 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2554 {
2555   tree args[2];
2556
2557   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2558
2559   se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2560                           TREE_TYPE (args[0]), args[0], args[1]);
2561 }
2562
2563 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2564                         ? 0
2565                         : ((shift >= 0) ? i << shift : i >> -shift)
2566    where all shifts are logical shifts.  */
2567 static void
2568 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2569 {
2570   tree args[2];
2571   tree type;
2572   tree utype;
2573   tree tmp;
2574   tree width;
2575   tree num_bits;
2576   tree cond;
2577   tree lshift;
2578   tree rshift;
2579
2580   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2581   type = TREE_TYPE (args[0]);
2582   utype = unsigned_type_for (type);
2583
2584   width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2585
2586   /* Left shift if positive.  */
2587   lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2588
2589   /* Right shift if negative.
2590      We convert to an unsigned type because we want a logical shift.
2591      The standard doesn't define the case of shifting negative
2592      numbers, and we try to be compatible with other compilers, most
2593      notably g77, here.  */
2594   rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
2595                                             convert (utype, args[0]), width));
2596
2597   tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2598                      build_int_cst (TREE_TYPE (args[1]), 0));
2599   tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2600
2601   /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2602      gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2603      special case.  */
2604   num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
2605   cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2606
2607   se->expr = fold_build3 (COND_EXPR, type, cond,
2608                           build_int_cst (type, 0), tmp);
2609 }
2610
2611
2612 /* Circular shift.  AKA rotate or barrel shift.  */
2613
2614 static void
2615 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2616 {
2617   tree *args;
2618   tree type;
2619   tree tmp;
2620   tree lrot;
2621   tree rrot;
2622   tree zero;
2623   unsigned int num_args;
2624
2625   num_args = gfc_intrinsic_argument_list_length (expr);
2626   args = (tree *) alloca (sizeof (tree) * num_args);
2627
2628   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2629
2630   if (num_args == 3)
2631     {
2632       /* Use a library function for the 3 parameter version.  */
2633       tree int4type = gfc_get_int_type (4);
2634
2635       type = TREE_TYPE (args[0]);
2636       /* We convert the first argument to at least 4 bytes, and
2637          convert back afterwards.  This removes the need for library
2638          functions for all argument sizes, and function will be
2639          aligned to at least 32 bits, so there's no loss.  */
2640       if (expr->ts.kind < 4)
2641         args[0] = convert (int4type, args[0]);
2642
2643       /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2644          need loads of library  functions.  They cannot have values >
2645          BIT_SIZE (I) so the conversion is safe.  */
2646       args[1] = convert (int4type, args[1]);
2647       args[2] = convert (int4type, args[2]);
2648
2649       switch (expr->ts.kind)
2650         {
2651         case 1:
2652         case 2:
2653         case 4:
2654           tmp = gfor_fndecl_math_ishftc4;
2655           break;
2656         case 8:
2657           tmp = gfor_fndecl_math_ishftc8;
2658           break;
2659         case 16:
2660           tmp = gfor_fndecl_math_ishftc16;
2661           break;
2662         default:
2663           gcc_unreachable ();
2664         }
2665       se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2666       /* Convert the result back to the original type, if we extended
2667          the first argument's width above.  */
2668       if (expr->ts.kind < 4)
2669         se->expr = convert (type, se->expr);
2670
2671       return;
2672     }
2673   type = TREE_TYPE (args[0]);
2674
2675   /* Rotate left if positive.  */
2676   lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2677
2678   /* Rotate right if negative.  */
2679   tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2680   rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2681
2682   zero = build_int_cst (TREE_TYPE (args[1]), 0);
2683   tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2684   rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2685
2686   /* Do nothing if shift == 0.  */
2687   tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2688   se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2689 }
2690
2691 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
2692                         : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
2693
2694    The conditional expression is necessary because the result of LEADZ(0)
2695    is defined, but the result of __builtin_clz(0) is undefined for most
2696    targets.
2697
2698    For INTEGER kinds smaller than the C 'int' type, we have to subtract the
2699    difference in bit size between the argument of LEADZ and the C int.  */
2700
2701 static void
2702 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
2703 {
2704   tree arg;
2705   tree arg_type;
2706   tree cond;
2707   tree result_type;
2708   tree leadz;
2709   tree bit_size;
2710   tree tmp;
2711   int arg_kind;
2712   int i, n, s;
2713
2714   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2715
2716   /* Which variant of __builtin_clz* should we call?  */
2717   arg_kind = expr->value.function.actual->expr->ts.kind;
2718   i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2719   switch (arg_kind)
2720     {
2721       case 1:
2722       case 2:
2723       case 4:
2724         arg_type = unsigned_type_node;
2725         n = BUILT_IN_CLZ;
2726         break;
2727
2728       case 8:
2729         arg_type = long_unsigned_type_node;
2730         n = BUILT_IN_CLZL;
2731         break;
2732
2733       case 16:
2734         arg_type = long_long_unsigned_type_node;
2735         n = BUILT_IN_CLZLL;
2736         break;
2737
2738       default:
2739         gcc_unreachable ();
2740     }
2741
2742   /* Convert the actual argument to the proper argument type for the built-in
2743      function.  But the return type is of the default INTEGER kind.  */
2744   arg = fold_convert (arg_type, arg);
2745   result_type = gfc_get_int_type (gfc_default_integer_kind);
2746
2747   /* Compute LEADZ for the case i .ne. 0.  */
2748   s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
2749   tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2750   leadz = fold_build2 (MINUS_EXPR, result_type,
2751                        tmp, build_int_cst (result_type, s));
2752
2753   /* Build BIT_SIZE.  */
2754   bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2755
2756   /* ??? For some combinations of targets and integer kinds, the condition
2757          can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
2758   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2759                       arg, build_int_cst (arg_type, 0));
2760   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
2761 }
2762
2763 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
2764
2765    The conditional expression is necessary because the result of TRAILZ(0)
2766    is defined, but the result of __builtin_ctz(0) is undefined for most
2767    targets.  */
2768
2769 static void
2770 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
2771 {
2772   tree arg;
2773   tree arg_type;
2774   tree cond;
2775   tree result_type;
2776   tree trailz;
2777   tree bit_size;
2778   int arg_kind;
2779   int i, n;
2780
2781   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2782
2783   /* Which variant of __builtin_clz* should we call?  */
2784   arg_kind = expr->value.function.actual->expr->ts.kind;
2785   i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
2786   switch (expr->ts.kind)
2787     {
2788       case 1:
2789       case 2:
2790       case 4:
2791         arg_type = unsigned_type_node;
2792         n = BUILT_IN_CTZ;
2793         break;
2794
2795       case 8:
2796         arg_type = long_unsigned_type_node;
2797         n = BUILT_IN_CTZL;
2798         break;
2799
2800       case 16:
2801         arg_type = long_long_unsigned_type_node;
2802         n = BUILT_IN_CTZLL;
2803         break;
2804
2805       default:
2806         gcc_unreachable ();
2807     }
2808
2809   /* Convert the actual argument to the proper argument type for the built-in
2810      function.  But the return type is of the default INTEGER kind.  */
2811   arg = fold_convert (arg_type, arg);
2812   result_type = gfc_get_int_type (gfc_default_integer_kind);
2813
2814   /* Compute TRAILZ for the case i .ne. 0.  */
2815   trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
2816
2817   /* Build BIT_SIZE.  */
2818   bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
2819
2820   /* ??? For some combinations of targets and integer kinds, the condition
2821          can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used.  Later.  */
2822   cond = fold_build2 (EQ_EXPR, boolean_type_node,
2823                       arg, build_int_cst (arg_type, 0));
2824   se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
2825 }
2826
2827 /* Process an intrinsic with unspecified argument-types that has an optional
2828    argument (which could be of type character), e.g. EOSHIFT.  For those, we
2829    need to append the string length of the optional argument if it is not
2830    present and the type is really character.
2831    primary specifies the position (starting at 1) of the non-optional argument
2832    specifying the type and optional gives the position of the optional
2833    argument in the arglist.  */
2834
2835 static void
2836 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
2837                                      unsigned primary, unsigned optional)
2838 {
2839   gfc_actual_arglist* prim_arg;
2840   gfc_actual_arglist* opt_arg;
2841   unsigned cur_pos;
2842   gfc_actual_arglist* arg;
2843   gfc_symbol* sym;
2844   tree append_args;
2845
2846   /* Find the two arguments given as position.  */
2847   cur_pos = 0;
2848   prim_arg = NULL;
2849   opt_arg = NULL;
2850   for (arg = expr->value.function.actual; arg; arg = arg->next)
2851     {
2852       ++cur_pos;
2853
2854       if (cur_pos == primary)
2855         prim_arg = arg;
2856       if (cur_pos == optional)
2857         opt_arg = arg;
2858
2859       if (cur_pos >= primary && cur_pos >= optional)
2860         break;
2861     }
2862   gcc_assert (prim_arg);
2863   gcc_assert (prim_arg->expr);
2864   gcc_assert (opt_arg);
2865
2866   /* If we do have type CHARACTER and the optional argument is really absent,
2867      append a dummy 0 as string length.  */
2868   append_args = NULL_TREE;
2869   if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
2870     {
2871       tree dummy;
2872
2873       dummy = build_int_cst (gfc_charlen_type_node, 0);
2874       append_args = gfc_chainon_list (append_args, dummy);
2875     }
2876
2877   /* Build the call itself.  */
2878   sym = gfc_get_symbol_for_expr (expr);
2879   gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
2880   gfc_free (sym);
2881 }
2882
2883
2884 /* The length of a character string.  */
2885 static void
2886 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2887 {
2888   tree len;
2889   tree type;
2890   tree decl;
2891   gfc_symbol *sym;
2892   gfc_se argse;
2893   gfc_expr *arg;
2894   gfc_ss *ss;
2895
2896   gcc_assert (!se->ss);
2897
2898   arg = expr->value.function.actual->expr;
2899
2900   type = gfc_typenode_for_spec (&expr->ts);
2901   switch (arg->expr_type)
2902     {
2903     case EXPR_CONSTANT:
2904       len = build_int_cst (NULL_TREE, arg->value.character.length);
2905       break;
2906
2907     case EXPR_ARRAY:
2908       /* Obtain the string length from the function used by
2909          trans-array.c(gfc_trans_array_constructor).  */
2910       len = NULL_TREE;
2911       get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2912       break;
2913
2914     case EXPR_VARIABLE:
2915       if (arg->ref == NULL
2916             || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2917         {
2918           /* This doesn't catch all cases.
2919              See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2920              and the surrounding thread.  */
2921           sym = arg->symtree->n.sym;
2922           decl = gfc_get_symbol_decl (sym);
2923           if (decl == current_function_decl && sym->attr.function
2924                 && (sym->result == sym))
2925             decl = gfc_get_fake_result_decl (sym, 0);
2926
2927           len = sym->ts.cl->backend_decl;
2928           gcc_assert (len);
2929           break;
2930         }
2931
2932       /* Otherwise fall through.  */
2933
2934     default:
2935       /* Anybody stupid enough to do this deserves inefficient code.  */
2936       ss = gfc_walk_expr (arg);
2937       gfc_init_se (&argse, se);
2938       if (ss == gfc_ss_terminator)
2939         gfc_conv_expr (&argse, arg);
2940       else
2941         gfc_conv_expr_descriptor (&argse, arg, ss);
2942       gfc_add_block_to_block (&se->pre, &argse.pre);
2943       gfc_add_block_to_block (&se->post, &argse.post);
2944       len = argse.string_length;
2945       break;
2946     }
2947   se->expr = convert (type, len);
2948 }
2949
2950 /* The length of a character string not including trailing blanks.  */
2951 static void
2952 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2953 {
2954   int kind = expr->value.function.actual->expr->ts.kind;
2955   tree args[2], type, fndecl;
2956
2957   gfc_conv_intrinsic_function_args (se, expr, args, 2);
2958   type = gfc_typenode_for_spec (&expr->ts);
2959
2960   if (kind == 1)
2961     fndecl = gfor_fndecl_string_len_trim;
2962   else if (kind == 4)
2963     fndecl = gfor_fndecl_string_len_trim_char4;
2964   else
2965     gcc_unreachable ();
2966
2967   se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
2968   se->expr = convert (type, se->expr);
2969 }
2970
2971
2972 /* Returns the starting position of a substring within a string.  */
2973
2974 static void
2975 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2976                                       tree function)
2977 {
2978   tree logical4_type_node = gfc_get_logical_type (4);
2979   tree type;
2980   tree fndecl;
2981   tree *args;
2982   unsigned int num_args;
2983
2984   args = (tree *) alloca (sizeof (tree) * 5);
2985
2986   /* Get number of arguments; characters count double due to the
2987      string length argument. Kind= is not passed to the library
2988      and thus ignored.  */
2989   if (expr->value.function.actual->next->next->expr == NULL)
2990     num_args = 4;
2991   else
2992     num_args = 5;
2993
2994   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2995   type = gfc_typenode_for_spec (&expr->ts);
2996
2997   if (num_args == 4)
2998     args[4] = build_int_cst (logical4_type_node, 0);
2999   else
3000     args[4] = convert (logical4_type_node, args[4]);
3001
3002   fndecl = build_addr (function, current_function_decl);
3003   se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
3004                                5, args);
3005   se->expr = convert (type, se->expr);
3006
3007 }
3008
3009 /* The ascii value for a single character.  */
3010 static void
3011 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
3012 {
3013   tree args[2], type, pchartype;
3014
3015   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3016   gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
3017   pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
3018   args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
3019   type = gfc_typenode_for_spec (&expr->ts);
3020
3021   se->expr = build_fold_indirect_ref (args[1]);
3022   se->expr = convert (type, se->expr);
3023 }
3024
3025
3026 /* Intrinsic ISNAN calls __builtin_isnan.  */
3027
3028 static void
3029 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
3030 {
3031   tree arg;
3032
3033   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3034   se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
3035   STRIP_TYPE_NOPS (se->expr);
3036   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3037 }
3038
3039
3040 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
3041    their argument against a constant integer value.  */
3042
3043 static void
3044 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
3045 {
3046   tree arg;
3047
3048   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3049   se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
3050                           arg, build_int_cst (TREE_TYPE (arg), value));
3051 }
3052
3053
3054
3055 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource.  */
3056
3057 static void
3058 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
3059 {
3060   tree tsource;
3061   tree fsource;
3062   tree mask;
3063   tree type;
3064   tree len, len2;
3065   tree *args;
3066   unsigned int num_args;
3067
3068   num_args = gfc_intrinsic_argument_list_length (expr);
3069   args = (tree *) alloca (sizeof (tree) * num_args);
3070
3071   gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3072   if (expr->ts.type != BT_CHARACTER)
3073     {
3074       tsource = args[0];
3075       fsource = args[1];
3076       mask = args[2];
3077     }
3078   else
3079     {
3080       /* We do the same as in the non-character case, but the argument
3081          list is different because of the string length arguments. We
3082          also have to set the string length for the result.  */
3083       len = args[0];
3084       tsource = args[1];
3085       len2 = args[2];
3086       fsource = args[3];
3087       mask = args[4];
3088
3089       gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
3090                                    &se->pre);
3091       se->string_length = len;
3092     }
3093   type = TREE_TYPE (tsource);
3094   se->expr = fold_build3 (COND_EXPR, type, mask, tsource,
3095                           fold_convert (type, fsource));
3096 }
3097
3098
3099 /* FRACTION (s) is translated into frexp (s, &dummy_int).  */
3100 static void
3101 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
3102 {
3103   tree arg, type, tmp;
3104   int frexp;
3105
3106   switch (expr->ts.kind)
3107     {
3108       case 4:
3109         frexp = BUILT_IN_FREXPF;
3110         break;
3111       case 8:
3112         frexp = BUILT_IN_FREXP;
3113         break;
3114       case 10:
3115       case 16:
3116         frexp = BUILT_IN_FREXPL;
3117         break;
3118       default:
3119         gcc_unreachable ();
3120     }
3121
3122   type = gfc_typenode_for_spec (&expr->ts);
3123   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3124   tmp = gfc_create_var (integer_type_node, NULL);
3125   se->expr = build_call_expr (built_in_decls[frexp], 2,
3126                               fold_convert (type, arg),
3127                               gfc_build_addr_expr (NULL_TREE, tmp));
3128   se->expr = fold_convert (type, se->expr);
3129 }
3130
3131
3132 /* NEAREST (s, dir) is translated into
3133      tmp = copysign (INF, dir);
3134      return nextafter (s, tmp);
3135  */
3136 static void
3137 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
3138 {
3139   tree args[2], type, tmp;
3140   int nextafter, copysign, inf;
3141
3142   switch (expr->ts.kind)
3143     {
3144       case 4:
3145         nextafter = BUILT_IN_NEXTAFTERF;
3146         copysign = BUILT_IN_COPYSIGNF;
3147         inf = BUILT_IN_INFF;
3148         break;
3149       case 8:
3150         nextafter = BUILT_IN_NEXTAFTER;
3151         copysign = BUILT_IN_COPYSIGN;
3152         inf = BUILT_IN_INF;
3153         break;
3154       case 10:
3155       case 16:
3156         nextafter = BUILT_IN_NEXTAFTERL;
3157         copysign = BUILT_IN_COPYSIGNL;
3158         inf = BUILT_IN_INFL;
3159         break;
3160       default:
3161         gcc_unreachable ();
3162     }
3163
3164   type = gfc_typenode_for_spec (&expr->ts);
3165   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3166   tmp = build_call_expr (built_in_decls[copysign], 2,
3167                          build_call_expr (built_in_decls[inf], 0),
3168                          fold_convert (type, args[1]));
3169   se->expr = build_call_expr (built_in_decls[nextafter], 2,
3170                               fold_convert (type, args[0]), tmp);
3171   se->expr = fold_convert (type, se->expr);
3172 }
3173
3174
3175 /* SPACING (s) is translated into
3176     int e;
3177     if (s == 0)
3178       res = tiny;
3179     else
3180     {
3181       frexp (s, &e);
3182       e = e - prec;
3183       e = MAX_EXPR (e, emin);
3184       res = scalbn (1., e);
3185     }
3186     return res;
3187
3188  where prec is the precision of s, gfc_real_kinds[k].digits,
3189        emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
3190    and tiny is tiny(s), gfc_real_kinds[k].tiny.  */
3191
3192 static void
3193 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
3194 {
3195   tree arg, type, prec, emin, tiny, res, e;
3196   tree cond, tmp;
3197   int frexp, scalbn, k;
3198   stmtblock_t block;
3199
3200   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3201   prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
3202   emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
3203   tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
3204
3205   switch (expr->ts.kind)
3206     {
3207       case 4:
3208         frexp = BUILT_IN_FREXPF;
3209         scalbn = BUILT_IN_SCALBNF;
3210         break;
3211       case 8:
3212         frexp = BUILT_IN_FREXP;
3213         scalbn = BUILT_IN_SCALBN;
3214         break;
3215       case 10:
3216       case 16:
3217         frexp = BUILT_IN_FREXPL;
3218         scalbn = BUILT_IN_SCALBNL;
3219         break;
3220       default:
3221         gcc_unreachable ();
3222     }
3223
3224   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3225   arg = gfc_evaluate_now (arg, &se->pre);
3226
3227   type = gfc_typenode_for_spec (&expr->ts);
3228   e = gfc_create_var (integer_type_node, NULL);
3229   res = gfc_create_var (type, NULL);
3230
3231
3232   /* Build the block for s /= 0.  */
3233   gfc_start_block (&block);
3234   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3235                          gfc_build_addr_expr (NULL_TREE, e));
3236   gfc_add_expr_to_block (&block, tmp);
3237
3238   tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
3239   gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
3240                                                tmp, emin));
3241
3242   tmp = build_call_expr (built_in_decls[scalbn], 2,
3243                          build_real_from_int_cst (type, integer_one_node), e);
3244   gfc_add_modify (&block, res, tmp);
3245
3246   /* Finish by building the IF statement.  */
3247   cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
3248                       build_real_from_int_cst (type, integer_zero_node));
3249   tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
3250                   gfc_finish_block (&block));
3251
3252   gfc_add_expr_to_block (&se->pre, tmp);
3253   se->expr = res;
3254 }
3255
3256
3257 /* RRSPACING (s) is translated into
3258       int e;
3259       real x;
3260       x = fabs (s);
3261       if (x != 0)
3262       {
3263         frexp (s, &e);
3264         x = scalbn (x, precision - e);
3265       }
3266       return x;
3267
3268  where precision is gfc_real_kinds[k].digits.  */
3269
3270 static void
3271 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
3272 {
3273   tree arg, type, e, x, cond, stmt, tmp;
3274   int frexp, scalbn, fabs, prec, k;
3275   stmtblock_t block;
3276
3277   k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
3278   prec = gfc_real_kinds[k].digits;
3279   switch (expr->ts.kind)
3280     {
3281       case 4:
3282         frexp = BUILT_IN_FREXPF;
3283         scalbn = BUILT_IN_SCALBNF;
3284         fabs = BUILT_IN_FABSF;
3285         break;
3286       case 8:
3287         frexp = BUILT_IN_FREXP;
3288         scalbn = BUILT_IN_SCALBN;
3289         fabs = BUILT_IN_FABS;
3290         break;
3291       case 10:
3292       case 16:
3293         frexp = BUILT_IN_FREXPL;
3294         scalbn = BUILT_IN_SCALBNL;
3295         fabs = BUILT_IN_FABSL;
3296         break;
3297       default:
3298         gcc_unreachable ();
3299     }
3300
3301   type = gfc_typenode_for_spec (&expr->ts);
3302   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3303   arg = gfc_evaluate_now (arg, &se->pre);
3304
3305   e = gfc_create_var (integer_type_node, NULL);
3306   x = gfc_create_var (type, NULL);
3307   gfc_add_modify (&se->pre, x,
3308                        build_call_expr (built_in_decls[fabs], 1, arg));
3309
3310
3311   gfc_start_block (&block);
3312   tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3313                          gfc_build_addr_expr (NULL_TREE, e));
3314   gfc_add_expr_to_block (&block, tmp);
3315
3316   tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3317                      build_int_cst (NULL_TREE, prec), e);
3318   tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
3319   gfc_add_modify (&block, x, tmp);
3320   stmt = gfc_finish_block (&block);
3321
3322   cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3323                       build_real_from_int_cst (type, integer_zero_node));
3324   tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ());
3325   gfc_add_expr_to_block (&se->pre, tmp);
3326
3327   se->expr = fold_convert (type, x);
3328 }
3329
3330
3331 /* SCALE (s, i) is translated into scalbn (s, i).  */
3332 static void
3333 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3334 {
3335   tree args[2], type;
3336   int scalbn;
3337
3338   switch (expr->ts.kind)
3339     {
3340       case 4:
3341         scalbn = BUILT_IN_SCALBNF;
3342         break;
3343       case 8:
3344         scalbn = BUILT_IN_SCALBN;
3345         break;
3346       case 10:
3347       case 16:
3348         scalbn = BUILT_IN_SCALBNL;
3349         break;
3350       default:
3351         gcc_unreachable ();
3352     }
3353
3354   type = gfc_typenode_for_spec (&expr->ts);
3355   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3356   se->expr = build_call_expr (built_in_decls[scalbn], 2,
3357                               fold_convert (type, args[0]),
3358                               fold_convert (integer_type_node, args[1]));
3359   se->expr = fold_convert (type, se->expr);
3360 }
3361
3362
3363 /* SET_EXPONENT (s, i) is translated into
3364    scalbn (frexp (s, &dummy_int), i).  */
3365 static void
3366 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3367 {
3368   tree args[2], type, tmp;
3369   int frexp, scalbn;
3370
3371   switch (expr->ts.kind)
3372     {
3373       case 4:
3374         frexp = BUILT_IN_FREXPF;
3375         scalbn = BUILT_IN_SCALBNF;
3376         break;
3377       case 8:
3378         frexp = BUILT_IN_FREXP;
3379         scalbn = BUILT_IN_SCALBN;
3380         break;
3381       case 10:
3382       case 16:
3383         frexp = BUILT_IN_FREXPL;
3384         scalbn = BUILT_IN_SCALBNL;
3385         break;
3386       default:
3387         gcc_unreachable ();
3388     }
3389
3390   type = gfc_typenode_for_spec (&expr->ts);
3391   gfc_conv_intrinsic_function_args (se, expr, args, 2);
3392
3393   tmp = gfc_create_var (integer_type_node, NULL);
3394   tmp = build_call_expr (built_in_decls[frexp], 2,
3395                          fold_convert (type, args[0]),
3396                          gfc_build_addr_expr (NULL_TREE, tmp));
3397   se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
3398                               fold_convert (integer_type_node, args[1]));
3399   se->expr = fold_convert (type, se->expr);
3400 }
3401
3402
3403 static void
3404 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3405 {
3406   gfc_actual_arglist *actual;
3407   tree arg1;
3408   tree type;
3409   tree fncall0;
3410   tree fncall1;
3411   gfc_se argse;
3412   gfc_ss *ss;
3413
3414   gfc_init_se (&argse, NULL);
3415   actual = expr->value.function.actual;
3416
3417   ss = gfc_walk_expr (actual->expr);
3418   gcc_assert (ss != gfc_ss_terminator);
3419   argse.want_pointer = 1;
3420   argse.data_not_needed = 1;
3421   gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3422   gfc_add_block_to_block (&se->pre, &argse.pre);
3423   gfc_add_block_to_block (&se->post, &argse.post);
3424   arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3425
3426   /* Build the call to size0.  */
3427   fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
3428
3429   actual = actual->next;
3430
3431   if (actual->expr)
3432     {
3433       gfc_init_se (&argse, NULL);
3434       gfc_conv_expr_type (&argse, actual->expr,
3435                           gfc_array_index_type);
3436       gfc_add_block_to_block (&se->pre, &argse.pre);
3437
3438       /* Unusually, for an intrinsic, size does not exclude
3439          an optional arg2, so we must test for it.  */
3440       if (actual->expr->expr_type == EXPR_VARIABLE
3441             && actual->expr->symtree->n.sym->attr.dummy
3442             && actual->expr->symtree->n.sym->attr.optional)
3443         {
3444           tree tmp;
3445           /* Build the call to size1.  */
3446           fncall1 = build_call_expr (gfor_fndecl_size1, 2,
3447                                      arg1, argse.expr);
3448
3449           gfc_init_se (&argse, NULL);
3450           argse.want_pointer = 1;
3451           argse.data_not_needed = 1;
3452           gfc_conv_expr (&argse, actual->expr);
3453           gfc_add_block_to_block (&se->pre, &argse.pre);
3454           tmp = fold_build2 (NE_EXPR, boolean_type_node,
3455                              argse.expr, null_pointer_node);
3456           tmp = gfc_evaluate_now (tmp, &se->pre);
3457           se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3458                                   tmp, fncall1, fncall0);
3459         }
3460       else
3461         {
3462           se->expr = NULL_TREE;
3463           argse.expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3464                                     argse.expr, gfc_index_one_node);
3465         }
3466     }
3467   else if (expr->value.function.actual->expr->rank == 1)
3468     {
3469       argse.expr = gfc_index_zero_node;
3470       se->expr = NULL_TREE;
3471     }
3472   else
3473     se->expr = fncall0;
3474
3475   if (se->expr == NULL_TREE)
3476     {
3477       tree ubound, lbound;
3478
3479       arg1 = build_fold_indirect_ref (arg1);
3480       ubound = gfc_conv_descriptor_ubound (arg1, argse.expr);
3481       lbound = gfc_conv_descriptor_lbound (arg1, argse.expr);
3482       se->expr = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3483                               ubound, lbound);
3484       se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
3485                               gfc_index_one_node);
3486       se->expr = fold_build2 (MAX_EXPR, gfc_array_index_type, se->expr,
3487                               gfc_index_zero_node);
3488     }
3489
3490   type = gfc_typenode_for_spec (&expr->ts);
3491   se->expr = convert (type, se->expr);
3492 }
3493
3494
3495 /* Helper function to compute the size of a character variable,
3496    excluding the terminating null characters.  The result has
3497    gfc_array_index_type type.  */
3498
3499 static tree
3500 size_of_string_in_bytes (int kind, tree string_length)
3501 {
3502   tree bytesize;
3503   int i = gfc_validate_kind (BT_CHARACTER, kind, false);
3504
3505   bytesize = build_int_cst (gfc_array_index_type,
3506                             gfc_character_kinds[i].bit_size / 8);
3507
3508   return fold_build2 (MULT_EXPR, gfc_array_index_type, bytesize,
3509                       fold_convert (gfc_array_index_type, string_length));
3510 }
3511
3512
3513 static void
3514 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3515 {
3516   gfc_expr *arg;
3517   gfc_ss *ss;
3518   gfc_se argse;
3519   tree source;
3520   tree source_bytes;
3521   tree type;
3522   tree tmp;
3523   tree lower;
3524   tree upper;
3525   int n;
3526
3527   arg = expr->value.function.actual->expr;
3528
3529   gfc_init_se (&argse, NULL);
3530   ss = gfc_walk_expr (arg);
3531
3532   if (ss == gfc_ss_terminator)
3533     {
3534       gfc_conv_expr_reference (&argse, arg);
3535       source = argse.expr;
3536
3537       type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3538
3539       /* Obtain the source word length.  */
3540       if (arg->ts.type == BT_CHARACTER)
3541         se->expr = size_of_string_in_bytes (arg->ts.kind,
3542                                             argse.string_length);
3543       else
3544         se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
3545     }
3546   else
3547     {
3548       source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3549       argse.want_pointer = 0;
3550       gfc_conv_expr_descriptor (&argse, arg, ss);
3551       source = gfc_conv_descriptor_data_get (argse.expr);
3552       type = gfc_get_element_type (TREE_TYPE (argse.expr));
3553
3554       /* Obtain the argument's word length.  */
3555       if (arg->ts.type == BT_CHARACTER)
3556         tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
3557       else
3558         tmp = fold_convert (gfc_array_index_type,
3559                             size_in_bytes (type));
3560       gfc_add_modify (&argse.pre, source_bytes, tmp);
3561
3562       /* Obtain the size of the array in bytes.  */
3563       for (n = 0; n < arg->rank; n++)
3564         {
3565           tree idx;
3566           idx = gfc_rank_cst[n];
3567           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3568           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3569           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3570                              upper, lower);
3571           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3572                              tmp, gfc_index_one_node);
3573           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3574                              tmp, source_bytes);
3575           gfc_add_modify (&argse.pre, source_bytes, tmp);
3576         }
3577       se->expr = source_bytes;
3578     }
3579
3580   gfc_add_block_to_block (&se->pre, &argse.pre);
3581 }
3582
3583
3584 /* Intrinsic string comparison functions.  */
3585
3586 static void
3587 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3588 {
3589   tree args[4];
3590
3591   gfc_conv_intrinsic_function_args (se, expr, args, 4);
3592
3593   se->expr
3594     = gfc_build_compare_string (args[0], args[1], args[2], args[3],
3595                                 expr->value.function.actual->expr->ts.kind);
3596   se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3597                           build_int_cst (TREE_TYPE (se->expr), 0));
3598 }
3599
3600 /* Generate a call to the adjustl/adjustr library function.  */
3601 static void
3602 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3603 {
3604   tree args[3];
3605   tree len;
3606   tree type;
3607   tree var;
3608   tree tmp;
3609
3610   gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3611   len = args[1];
3612
3613   type = TREE_TYPE (args[2]);
3614   var = gfc_conv_string_tmp (se, type, len);
3615   args[0] = var;
3616
3617   tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3618   gfc_add_expr_to_block (&se->pre, tmp);
3619   se->expr = var;
3620   se->string_length = len;
3621 }
3622
3623
3624 /* Generate code for the TRANSFER intrinsic:
3625         For scalar results:
3626           DEST = TRANSFER (SOURCE, MOLD)
3627         where:
3628           typeof<DEST> = typeof<MOLD>
3629         and:
3630           MOLD is scalar.
3631
3632         For array results:
3633           DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3634         where:
3635           typeof<DEST> = typeof<MOLD>
3636         and:
3637           N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3638               sizeof (DEST(0) * SIZE).  */
3639 static void
3640 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3641 {
3642   tree tmp;
3643   tree tmpdecl;
3644   tree ptr;
3645   tree extent;
3646   tree source;
3647   tree source_type;
3648   tree source_bytes;
3649   tree mold_type;
3650   tree dest_word_len;
3651   tree size_words;
3652   tree size_bytes;
3653   tree upper;
3654   tree lower;
3655   tree stride;
3656   tree stmt;
3657   gfc_actual_arglist *arg;
3658   gfc_se argse;
3659   gfc_ss *ss;
3660   gfc_ss_info *info;
3661   stmtblock_t block;
3662   int n;
3663   bool scalar_mold;
3664
3665   info = NULL;
3666   if (se->loop)
3667     info = &se->ss->data.info;
3668
3669   /* Convert SOURCE.  The output from this stage is:-
3670         source_bytes = length of the source in bytes
3671         source = pointer to the source data.  */
3672   arg = expr->value.function.actual;
3673
3674   /* Ensure double transfer through LOGICAL preserves all
3675      the needed bits.  */
3676   if (arg->expr->expr_type == EXPR_FUNCTION
3677         && arg->expr->value.function.esym == NULL
3678         && arg->expr->value.function.isym != NULL
3679         && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
3680         && arg->expr->ts.type == BT_LOGICAL
3681         && expr->ts.type != arg->expr->ts.type)
3682     arg->expr->value.function.name = "__transfer_in_transfer";
3683
3684   gfc_init_se (&argse, NULL);
3685   ss = gfc_walk_expr (arg->expr);
3686
3687   source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3688
3689   /* Obtain the pointer to source and the length of source in bytes.  */
3690   if (ss == gfc_ss_terminator)
3691     {
3692       gfc_conv_expr_reference (&argse, arg->expr);
3693       source = argse.expr;
3694
3695       source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3696
3697       /* Obtain the source word length.  */
3698       if (arg->expr->ts.type == BT_CHARACTER)
3699         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3700                                        argse.string_length);
3701       else
3702         tmp = fold_convert (gfc_array_index_type,
3703                             size_in_bytes (source_type));
3704     }
3705   else
3706     {
3707       argse.want_pointer = 0;
3708       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3709       source = gfc_conv_descriptor_data_get (argse.expr);
3710       source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3711
3712       /* Repack the source if not a full variable array.  */
3713       if (arg->expr->expr_type == EXPR_VARIABLE
3714               && arg->expr->ref->u.ar.type != AR_FULL)
3715         {
3716           tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
3717
3718           if (gfc_option.warn_array_temp)
3719             gfc_warning ("Creating array temporary at %L", &expr->where);
3720
3721           source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3722           source = gfc_evaluate_now (source, &argse.pre);
3723
3724           /* Free the temporary.  */
3725           gfc_start_block (&block);
3726           tmp = gfc_call_free (convert (pvoid_type_node, source));
3727           gfc_add_expr_to_block (&block, tmp);
3728           stmt = gfc_finish_block (&block);
3729
3730           /* Clean up if it was repacked.  */
3731           gfc_init_block (&block);
3732           tmp = gfc_conv_array_data (argse.expr);
3733           tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3734           tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3735           gfc_add_expr_to_block (&block, tmp);
3736           gfc_add_block_to_block (&block, &se->post);
3737           gfc_init_block (&se->post);
3738           gfc_add_block_to_block (&se->post, &block);
3739         }
3740
3741       /* Obtain the source word length.  */
3742       if (arg->expr->ts.type == BT_CHARACTER)
3743         tmp = size_of_string_in_bytes (arg->expr->ts.kind,
3744                                        argse.string_length);
3745       else
3746         tmp = fold_convert (gfc_array_index_type,
3747                             size_in_bytes (source_type));
3748
3749       /* Obtain the size of the array in bytes.  */
3750       extent = gfc_create_var (gfc_array_index_type, NULL);
3751       for (n = 0; n < arg->expr->rank; n++)
3752         {
3753           tree idx;
3754           idx = gfc_rank_cst[n];
3755           gfc_add_modify (&argse.pre, source_bytes, tmp);
3756           stride = gfc_conv_descriptor_stride (argse.expr, idx);
3757           lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3758           upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3759           tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3760                              upper, lower);
3761           gfc_add_modify (&argse.pre, extent, tmp);
3762           tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3763                              extent, gfc_index_one_node);
3764           tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3765                              tmp, source_bytes);
3766         }
3767     }
3768
3769   gfc_add_modify (&argse.pre, source_bytes, tmp);
3770   gfc_add_block_to_block (&se->pre, &argse.pre);
3771   gfc_add_block_to_block (&se->post, &argse.post);
3772
3773   /* Now convert MOLD.  The outputs are:
3774         mold_type = the TREE type of MOLD
3775         dest_word_len = destination word length in bytes.  */
3776   arg = arg->next;
3777
3778   gfc_init_se (&argse, NULL);
3779   ss = gfc_walk_expr (arg->expr);
3780
3781   scalar_mold = arg->expr->rank == 0;
3782
3783   if (ss == gfc_ss_terminator)
3784     {
3785       gfc_conv_expr_reference (&argse, arg->expr);
3786       mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3787     }
3788   else
3789     {
3790       gfc_init_se (&argse, NULL);
3791       argse.want_pointer = 0;
3792       gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3793       mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3794     }
3795
3796   gfc_add_block_to_block (&se->pre, &argse.pre);
3797   gfc_add_block_to_block (&se->post, &argse.post);
3798
3799   if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
3800     {
3801       /* If this TRANSFER is nested in another TRANSFER, use a type
3802          that preserves all bits.  */
3803       if (arg->expr->ts.type == BT_LOGICAL)
3804         mold_type = gfc_get_int_type (arg->expr->ts.kind);
3805     }
3806
3807   if (arg->expr->ts.type == BT_CHARACTER)
3808     {
3809       tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
3810       mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3811     }
3812   else
3813     tmp = fold_convert (gfc_array_index_type,
3814                         size_in_bytes (mold_type));
3815
3816   dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3817   gfc_add_modify (&se->pre, dest_word_len, tmp);
3818
3819   /* Finally convert SIZE, if it is present.  */
3820   arg = arg->next;
3821   size_words = gfc_create_var (gfc_array_index_type, NULL);
3822
3823   if (arg->expr)
3824     {
3825       gfc_init_se (&argse, NULL);
3826       gfc_conv_expr_reference (&argse, arg->expr);
3827       tmp = convert (gfc_array_index_type,
3828                          build_fold_indirect_ref (argse.expr));
3829       gfc_add_block_to_block (&se->pre, &argse.pre);
3830       gfc_add_block_to_block (&se->post, &argse.post);
3831     }
3832   else
3833     tmp = NULL_TREE;
3834
3835   /* Separate array and scalar results.  */
3836   if (scalar_mold && tmp == NULL_TREE)
3837     goto scalar_transfer;
3838
3839   size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3840   if (tmp != NULL_TREE)
3841     tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3842                        tmp, dest_word_len);
3843   else
3844     tmp = source_bytes;
3845
3846   gfc_add_modify (&se->pre, size_bytes, tmp);
3847   gfc_add_modify (&se->pre, size_words,
3848                        fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3849                                     size_bytes, dest_word_len));
3850
3851   /* Evaluate the bounds of the result.  If the loop range exists, we have
3852      to check if it is too large.  If so, we modify loop->to be consistent
3853      with min(size, size(source)).  Otherwise, size is made consistent with
3854      the loop range, so that the right number of bytes is transferred.*/
3855   n = se->loop->order[0];
3856   if (se->loop->to[n] != NULL_TREE)
3857     {
3858       tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3859                          se->loop->to[n], se->loop->from[n]);
3860       tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3861                          tmp, gfc_index_one_node);
3862       tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3863                          tmp, size_words);
3864       gfc_add_modify (&se->pre, size_words, tmp);
3865       gfc_add_modify (&se->pre, size_bytes,
3866                            fold_build2 (MULT_EXPR, gfc_array_index_type,
3867                                         size_words, dest_word_len));
3868       upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3869                            size_words, se->loop->from[n]);
3870       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3871                            upper, gfc_index_one_node);
3872     }
3873   else
3874     {
3875       upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3876                            size_words, gfc_index_one_node);
3877       se->loop->from[n] = gfc_index_zero_node;
3878     }
3879
3880   se->loop->to[n] = upper;
3881
3882   /* Build a destination descriptor, using the pointer, source, as the
3883      data field.  */
3884   gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3885                                info, mold_type, NULL_TREE, false, true, false,
3886                                &expr->where);
3887
3888   /* Cast the pointer to the result.  */
3889   tmp = gfc_conv_descriptor_data_get (info->descriptor);
3890   tmp = fold_convert (pvoid_type_node, tmp);
3891
3892   /* Use memcpy to do the transfer.  */
3893   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3894                          3,
3895                          tmp,
3896                          fold_convert (pvoid_type_node, source),
3897                          fold_build2 (MIN_EXPR, gfc_array_index_type,
3898                                       size_bytes, source_bytes));
3899   gfc_add_expr_to_block (&se->pre, tmp);
3900
3901   se->expr = info->descriptor;
3902   if (expr->ts.type == BT_CHARACTER)
3903     se->string_length = dest_word_len;
3904
3905   return;
3906
3907 /* Deal with scalar results.  */
3908 scalar_transfer:
3909   extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
3910                         dest_word_len, source_bytes);
3911
3912   if (expr->ts.type == BT_CHARACTER)
3913     {
3914       tree direct;
3915       tree indirect;
3916
3917       ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
3918       tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
3919                                 "transfer");
3920
3921       /* If source is longer than the destination, use a pointer to
3922          the source directly.  */
3923       gfc_init_block (&block);
3924       gfc_add_modify (&block, tmpdecl, ptr);
3925       direct = gfc_finish_block (&block);
3926
3927       /* Otherwise, allocate a string with the length of the destination
3928          and copy the source into it.  */
3929       gfc_init_block (&block);
3930       tmp = gfc_get_pchar_type (expr->ts.kind);
3931       tmp = gfc_call_malloc (&block, tmp, dest_word_len);
3932       gfc_add_modify (&block, tmpdecl,
3933                       fold_convert (TREE_TYPE (ptr), tmp));
3934       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3935                              fold_convert (pvoid_type_node, tmpdecl),
3936                              fold_convert (pvoid_type_node, ptr),
3937                              extent);
3938       gfc_add_expr_to_block (&block, tmp);
3939       indirect = gfc_finish_block (&block);
3940
3941       /* Wrap it up with the condition.  */
3942       tmp = fold_build2 (LE_EXPR, boolean_type_node,
3943                          dest_word_len, source_bytes);
3944       tmp = build3_v (COND_EXPR, tmp, direct, indirect);
3945       gfc_add_expr_to_block (&se->pre, tmp);
3946
3947       se->expr = tmpdecl;
3948       se->string_length = dest_word_len;
3949     }
3950   else
3951     {
3952       tmpdecl = gfc_create_var (mold_type, "transfer");
3953
3954       ptr = convert (build_pointer_type (mold_type), source);
3955
3956       /* Use memcpy to do the transfer.  */
3957       tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
3958       tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3959                              fold_convert (pvoid_type_node, tmp),
3960                              fold_convert (pvoid_type_node, ptr),
3961                              extent);
3962       gfc_add_expr_to_block (&se->pre, tmp);
3963
3964       se->expr = tmpdecl;
3965     }
3966 }
3967
3968
3969 /* Generate code for the ALLOCATED intrinsic.
3970    Generate inline code that directly check the address of the argument.  */
3971
3972 static void
3973 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3974 {
3975   gfc_actual_arglist *arg1;
3976   gfc_se arg1se;
3977   gfc_ss *ss1;
3978   tree tmp;
3979
3980   gfc_init_se (&arg1se, NULL);
3981   arg1 = expr->value.function.actual;
3982   ss1 = gfc_walk_expr (arg1->expr);
3983   arg1se.descriptor_only = 1;
3984   gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3985
3986   tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3987   tmp = fold_build2 (NE_EXPR, boolean_type_node,
3988                      tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
3989   se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3990 }
3991
3992
3993 /* Generate code for the ASSOCIATED intrinsic.
3994    If both POINTER and TARGET are arrays, generate a call to library function
3995    _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3996    In other cases, generate inline code that directly compare the address of
3997    POINTER with the address of TARGET.  */
3998
3999 static void
4000 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
4001 {
4002   gfc_actual_arglist *arg1;
4003   gfc_actual_arglist *arg2;
4004   gfc_se arg1se;
4005   gfc_se arg2se;
4006   tree tmp2;
4007   tree tmp;
4008   tree nonzero_charlen;
4009   tree nonzero_arraylen;
4010   gfc_ss *ss1, *ss2;
4011
4012   gfc_init_se (&arg1se, NULL);
4013   gfc_init_se (&arg2se, NULL);
4014   arg1 = expr->value.function.actual;
4015   arg2 = arg1->next;
4016   ss1 = gfc_walk_expr (arg1->expr);
4017
4018   if (!arg2->expr)
4019     {
4020       /* No optional target.  */
4021       if (ss1 == gfc_ss_terminator)
4022         {
4023           /* A pointer to a scalar.  */
4024           arg1se.want_pointer = 1;
4025           gfc_conv_expr (&arg1se, arg1->expr);
4026           tmp2 = arg1se.expr;
4027         }
4028       else
4029         {
4030           /* A pointer to an array.  */
4031           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4032           tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
4033         }
4034       gfc_add_block_to_block (&se->pre, &arg1se.pre);
4035       gfc_add_block_to_block (&se->post, &arg1se.post);
4036       tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
4037                          fold_convert (TREE_TYPE (tmp2), null_pointer_node));
4038       se->expr = tmp;
4039     }
4040   else
4041     {
4042       /* An optional target.  */
4043       ss2 = gfc_walk_expr (arg2->expr);
4044
4045       nonzero_charlen = NULL_TREE;
4046       if (arg1->expr->ts.type == BT_CHARACTER)
4047         nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
4048                                        arg1->expr->ts.cl->backend_decl,
4049                                        integer_zero_node);
4050
4051       if (ss1 == gfc_ss_terminator)
4052         {
4053           /* A pointer to a scalar.  */
4054           gcc_assert (ss2 == gfc_ss_terminator);
4055           arg1se.want_pointer = 1;
4056           gfc_conv_expr (&arg1se, arg1->expr);
4057           arg2se.want_pointer = 1;
4058           gfc_conv_expr (&arg2se, arg2->expr);
4059           gfc_add_block_to_block (&se->pre, &arg1se.pre);
4060           gfc_add_block_to_block (&se->post, &arg1se.post);
4061           tmp = fold_build2 (EQ_EXPR, boolean_type_node,
4062                              arg1se.expr, arg2se.expr);
4063           tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
4064                               arg1se.expr, null_pointer_node);
4065           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4066                                   tmp, tmp2);
4067         }
4068       else
4069         {
4070           /* An array pointer of zero length is not associated if target is
4071              present.  */
4072           arg1se.descriptor_only = 1;
4073           gfc_conv_expr_lhs (&arg1se, arg1->expr);
4074           tmp = gfc_conv_descriptor_stride (arg1se.expr,
4075                                             gfc_rank_cst[arg1->expr->rank - 1]);
4076           nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
4077                                           build_int_cst (TREE_TYPE (tmp), 0));
4078
4079           /* A pointer to an array, call library function _gfor_associated.  */
4080           gcc_assert (ss2 != gfc_ss_terminator);
4081           arg1se.want_pointer = 1;
4082           gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
4083
4084           arg2se.want_pointer = 1;
4085           gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
4086           gfc_add_block_to_block (&se->pre, &arg2se.pre);
4087           gfc_add_block_to_block (&se->post, &arg2se.post);
4088           se->expr = build_call_expr (gfor_fndecl_associated, 2,
4089                                       arg1se.expr, arg2se.expr);
4090           se->expr = convert (boolean_type_node, se->expr);
4091           se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4092                                   se->expr, nonzero_arraylen);
4093         }
4094
4095       /* If target is present zero character length pointers cannot
4096          be associated.  */
4097       if (nonzero_charlen != NULL_TREE)
4098         se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
4099                                 se->expr, nonzero_charlen);
4100     }
4101
4102   se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4103 }
4104
4105
4106 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function.  */
4107
4108 static void
4109 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
4110 {
4111   tree args[2];
4112
4113   gfc_conv_intrinsic_function_args (se, expr, args, 2);
4114   se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
4115   se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4116 }
4117
4118
4119 /* Generate code for SELECTED_INT_KIND (R) intrinsic function.  */
4120
4121 static void
4122 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
4123 {
4124   tree arg, type;
4125
4126   gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4127
4128   /* The argument to SELECTED_INT_KIND is INTEGER(4).  */
4129   type = gfc_get_int_type (4);
4130   arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
4131
4132   /* Convert it to the required type.  */
4133   type = gfc_typenode_for_spec (&expr->ts);
4134   se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
4135   se->expr = fold_convert (type, se->expr);
4136 }
4137
4138
4139 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function.  */
4140
4141 static void
4142 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
4143 {
4144   gfc_actual_arglist *actual;
4145   tree args, type;
4146   gfc_se argse;
4147
4148   args = NULL_TREE;
4149   for (actual = expr->value.function.actual; actual; actual = actual->next)
4150     {
4151       gfc_init_se (&argse, se);
4152
4153       /* Pass a NULL pointer for an absent arg.  */
4154       if (actual->expr == NULL)
4155         argse.expr = null_pointer_node;
4156       else
4157         {
4158           gfc_typespec ts;
4159           gfc_clear_ts (&ts);
4160
4161           if (actual->expr->ts.kind != gfc_c_int_kind)
4162             {
4163               /* The arguments to SELECTED_REAL_KIND are INTEGER(4).  */
4164               ts.type = BT_INTEGER;
4165               ts.kind = gfc_c_int_kind;
4166               gfc_convert_type (actual->expr, &ts, 2);
4167             }
4168           gfc_conv_expr_reference (&argse, actual->expr);
4169         }
4170
4171       gfc_add_block_to_block (&se->pre, &argse.pre);
4172       gfc_add_block_to_block (&se->post, &argse.post);
4173       args = gfc_chainon_list (args, argse.expr);
4174     }
4175
4176   /* Convert it to the required type.  */
4177   type = gfc_typenode_for_spec (&expr->ts);
4178   se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
4179   se->expr = fold_convert (type, se->expr);
4180 }
4181
4182
4183 /* Generate code for TRIM (A) intrinsic function.  */
4184
4185 static void
4186 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
4187 {
4188   tree var;
4189   tree len;
4190   tree addr;
4191   tree tmp;
4192   tree cond;
4193   tree fndecl;
4194   tree function;
4195   tree *args;
4196   unsigned int num_args;
4197
4198   num_args = gfc_intrinsic_argument_list_length (expr) + 2;
4199   args = (tree *) alloca (sizeof (tree) * num_args);
4200
4201   var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
4202   addr = gfc_build_addr_expr (ppvoid_type_node, var);
4203   len = gfc_create_var (gfc_get_int_type (4), "len");
4204
4205   gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
4206   args[0] = gfc_build_addr_expr (NULL_TREE, len);
4207   args[1] = addr;
4208
4209   if (expr->ts.kind == 1)
4210     function = gfor_fndecl_string_trim;
4211   else if (expr->ts.kind == 4)
4212     function = gfor_fndecl_string_trim_char4;
4213   else
4214     gcc_unreachable ();
4215
4216   fndecl = build_addr (function, current_function_decl);
4217   tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
4218                           num_args, args);
4219   gfc_add_expr_to_block (&se->pre, tmp);
4220
4221   /* Free the temporary afterwards, if necessary.  */
4222   cond = fold_build2 (GT_EXPR, boolean_type_node,
4223                       len, build_int_cst (TREE_TYPE (len), 0));
4224   tmp = gfc_call_free (var);
4225   tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
4226   gfc_add_expr_to_block (&se->post, tmp);
4227
4228   se->expr = var;
4229   se->string_length = len;
4230 }
4231
4232
4233 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function.  */
4234
4235 static void
4236 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
4237 {
4238   tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
4239   tree type, cond, tmp, count, exit_label, n, max, largest;
4240   tree size;
4241   stmtblock_t block, body;
4242   int i;
4243
4244   /* We store in charsize the size of a character.  */
4245   i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
4246   size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
4247
4248   /* Get the arguments.  */
4249   gfc_conv_intrinsic_function_args (se, expr, args, 3);
4250   slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
4251   src = args[1];
4252   ncopies = gfc_evaluate_now (args[2], &se->pre);
4253   ncopies_type = TREE_TYPE (ncopies);
4254
4255   /* Check that NCOPIES is not negative.  */
4256   cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
4257                       build_int_cst (ncopies_type, 0));
4258   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4259                            "Argument NCOPIES of REPEAT intrinsic is negative "
4260                            "(its value is %lld)",
4261                            fold_convert (long_integer_type_node, ncopies));
4262
4263   /* If the source length is zero, any non negative value of NCOPIES
4264      is valid, and nothing happens.  */
4265   n = gfc_create_var (ncopies_type, "ncopies");
4266   cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4267                       build_int_cst (size_type_node, 0));
4268   tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
4269                      build_int_cst (ncopies_type, 0), ncopies);
4270   gfc_add_modify (&se->pre, n, tmp);
4271   ncopies = n;
4272
4273   /* Check that ncopies is not too large: ncopies should be less than
4274      (or equal to) MAX / slen, where MAX is the maximal integer of
4275      the gfc_charlen_type_node type.  If slen == 0, we need a special
4276      case to avoid the division by zero.  */
4277   i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
4278   max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
4279   max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
4280                      fold_convert (size_type_node, max), slen);
4281   largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
4282               ? size_type_node : ncopies_type;
4283   cond = fold_build2 (GT_EXPR, boolean_type_node,
4284                       fold_convert (largest, ncopies),
4285                       fold_convert (largest, max));
4286   tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
4287                      build_int_cst (size_type_node, 0));
4288   cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
4289                       cond);
4290   gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
4291                            "Argument NCOPIES of REPEAT intrinsic is too large");
4292
4293   /* Compute the destination length.  */
4294   dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4295                       fold_convert (gfc_charlen_type_node, slen),
4296                       fold_convert (gfc_charlen_type_node, ncopies));
4297   type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
4298   dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
4299
4300   /* Generate the code to do the repeat operation:
4301        for (i = 0; i < ncopies; i++)
4302          memmove (dest + (i * slen * size), src, slen*size);  */
4303   gfc_start_block (&block);
4304   count = gfc_create_var (ncopies_type, "count");
4305   gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
4306   exit_label = gfc_build_label_decl (NULL_TREE);
4307
4308   /* Start the loop body.  */
4309   gfc_start_block (&body);
4310
4311   /* Exit the loop if count >= ncopies.  */
4312   cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
4313   tmp = build1_v (GOTO_EXPR, exit_label);
4314   TREE_USED (exit_label) = 1;
4315   tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
4316                      build_empty_stmt ());
4317   gfc_add_expr_to_block (&body, tmp);
4318
4319   /* Call memmove (dest + (i*slen*size), src, slen*size).  */
4320   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4321                      fold_convert (gfc_charlen_type_node, slen),
4322                      fold_convert (gfc_charlen_type_node, count));
4323   tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
4324                      tmp, fold_convert (gfc_charlen_type_node, size));
4325   tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
4326                      fold_convert (pvoid_type_node, dest),
4327                      fold_convert (sizetype, tmp));
4328   tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
4329                          fold_build2 (MULT_EXPR, size_type_node, slen,
4330                                       fold_convert (size_type_node, size)));
4331   gfc_add_expr_to_block (&body, tmp);
4332
4333   /* Increment count.  */
4334   tmp = fold_build2 (PLUS_EXPR, ncopies_type,
4335                      count, build_int_cst (TREE_TYPE (count), 1));
4336   gfc_add_modify (&body, count, tmp);
4337
4338   /* Build the loop.  */
4339   tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
4340   gfc_add_expr_to_block (&block, tmp);
4341
4342   /* Add the exit label.  */
4343   tmp = build1_v (LABEL_EXPR, exit_label);
4344   gfc_add_expr_to_block (&block, tmp);
4345
4346   /* Finish the block.  */
4347   tmp = gfc_finish_block (&block);
4348   gfc_add_expr_to_block (&se->pre, tmp);
4349
4350   /* Set the result value.  */
4351   se->expr = dest;
4352   se->string_length = dlen;
4353 }
4354
4355
4356 /* Generate code for the IARGC intrinsic.  */
4357
4358 static void
4359 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
4360 {
4361   tree tmp;
4362   tree fndecl;
4363   tree type;
4364
4365   /* Call the library function.  This always returns an INTEGER(4).  */
4366   fndecl = gfor_fndecl_iargc;
4367   tmp = build_call_expr (fndecl, 0);
4368
4369   /* Convert it to the required type.  */
4370   type = gfc_typenode_for_spec (&expr->ts);
4371   tmp = fold_convert (type, tmp);
4372
4373   se->expr = tmp;
4374 }
4375
4376
4377 /* The loc intrinsic returns the address of its argument as
4378    gfc_index_integer_kind integer.  */
4379
4380 static void
4381 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4382 {
4383   tree temp_var;
4384   gfc_expr *arg_expr;
4385   gfc_ss *ss;
4386
4387   gcc_assert (!se->ss);
4388
4389   arg_expr = expr->value.function.actual->expr;
4390   ss = gfc_walk_expr (arg_expr);
4391   if (ss == gfc_ss_terminator)
4392     gfc_conv_expr_reference (se, arg_expr);
4393   else
4394     gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
4395   se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4396
4397   /* Create a temporary variable for loc return value.  Without this,
4398      we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1).  */
4399   temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4400   gfc_add_modify (&se->pre, temp_var, se->expr);
4401   se->expr = temp_var;
4402 }
4403
4404 /* Generate code for an intrinsic function.  Some map directly to library
4405    calls, others get special handling.  In some cases the name of the function
4406    used depends on the type specifiers.  */
4407
4408 void
4409 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4410 {
4411   gfc_intrinsic_sym *isym;
4412   const char *name;
4413   int lib, kind;
4414   tree fndecl;
4415
4416   isym = expr->value.function.isym;
4417
4418   name = &expr->value.function.name[2];
4419
4420   if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4421     {
4422       lib = gfc_is_intrinsic_libcall (expr);
4423       if (lib != 0)
4424         {
4425           if (lib == 1)
4426             se->ignore_optional = 1;
4427
4428           switch (expr->value.function.isym->id)
4429             {
4430             case GFC_ISYM_EOSHIFT:
4431             case GFC_ISYM_PACK:
4432             case GFC_ISYM_RESHAPE:
4433               /* For all of those the first argument specifies the type and the
4434                  third is optional.  */
4435               conv_generic_with_optional_char_arg (se, expr, 1, 3);
4436               break;
4437
4438             default:
4439               gfc_conv_intrinsic_funcall (se, expr);
4440               break;
4441             }
4442
4443           return;
4444         }
4445     }
4446
4447   switch (expr->value.function.isym->id)
4448     {
4449     case GFC_ISYM_NONE:
4450       gcc_unreachable ();
4451
4452     case GFC_ISYM_REPEAT:
4453       gfc_conv_intrinsic_repeat (se, expr);
4454       break;
4455
4456     case GFC_ISYM_TRIM:
4457       gfc_conv_intrinsic_trim (se, expr);
4458       break;
4459
4460     case GFC_ISYM_SC_KIND:
4461       gfc_conv_intrinsic_sc_kind (se, expr);
4462       break;
4463
4464     case GFC_ISYM_SI_KIND:
4465       gfc_conv_intrinsic_si_kind (se, expr);
4466       break;
4467
4468     case GFC_ISYM_SR_KIND:
4469       gfc_conv_intrinsic_sr_kind (se, expr);
4470       break;
4471
4472     case GFC_ISYM_EXPONENT:
4473       gfc_conv_intrinsic_exponent (se, expr);
4474       break;
4475
4476     case GFC_ISYM_SCAN:
4477       kind = expr->value.function.actual->expr->ts.kind;
4478       if (kind == 1)
4479        fndecl = gfor_fndecl_string_scan;
4480       else if (kind == 4)
4481        fndecl = gfor_fndecl_string_scan_char4;
4482       else
4483        gcc_unreachable ();
4484
4485       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4486       break;
4487
4488     case GFC_ISYM_VERIFY:
4489       kind = expr->value.function.actual->expr->ts.kind;
4490       if (kind == 1)
4491        fndecl = gfor_fndecl_string_verify;
4492       else if (kind == 4)
4493        fndecl = gfor_fndecl_string_verify_char4;
4494       else
4495        gcc_unreachable ();
4496
4497       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4498       break;
4499
4500     case GFC_ISYM_ALLOCATED:
4501       gfc_conv_allocated (se, expr);
4502       break;
4503
4504     case GFC_ISYM_ASSOCIATED:
4505       gfc_conv_associated(se, expr);
4506       break;
4507
4508     case GFC_ISYM_ABS:
4509       gfc_conv_intrinsic_abs (se, expr);
4510       break;
4511
4512     case GFC_ISYM_ADJUSTL:
4513       if (expr->ts.kind == 1)
4514        fndecl = gfor_fndecl_adjustl;
4515       else if (expr->ts.kind == 4)
4516        fndecl = gfor_fndecl_adjustl_char4;
4517       else
4518        gcc_unreachable ();
4519
4520       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4521       break;
4522
4523     case GFC_ISYM_ADJUSTR:
4524       if (expr->ts.kind == 1)
4525        fndecl = gfor_fndecl_adjustr;
4526       else if (expr->ts.kind == 4)
4527        fndecl = gfor_fndecl_adjustr_char4;
4528       else
4529        gcc_unreachable ();
4530
4531       gfc_conv_intrinsic_adjust (se, expr, fndecl);
4532       break;
4533
4534     case GFC_ISYM_AIMAG:
4535       gfc_conv_intrinsic_imagpart (se, expr);
4536       break;
4537
4538     case GFC_ISYM_AINT:
4539       gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4540       break;
4541
4542     case GFC_ISYM_ALL:
4543       gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4544       break;
4545
4546     case GFC_ISYM_ANINT:
4547       gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4548       break;
4549
4550     case GFC_ISYM_AND:
4551       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4552       break;
4553
4554     case GFC_ISYM_ANY:
4555       gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4556       break;
4557
4558     case GFC_ISYM_BTEST:
4559       gfc_conv_intrinsic_btest (se, expr);
4560       break;
4561
4562     case GFC_ISYM_ACHAR:
4563     case GFC_ISYM_CHAR:
4564       gfc_conv_intrinsic_char (se, expr);
4565       break;
4566
4567     case GFC_ISYM_CONVERSION:
4568     case GFC_ISYM_REAL:
4569     case GFC_ISYM_LOGICAL:
4570     case GFC_ISYM_DBLE:
4571       gfc_conv_intrinsic_conversion (se, expr);
4572       break;
4573
4574       /* Integer conversions are handled separately to make sure we get the
4575          correct rounding mode.  */
4576     case GFC_ISYM_INT:
4577     case GFC_ISYM_INT2:
4578     case GFC_ISYM_INT8:
4579     case GFC_ISYM_LONG:
4580       gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4581       break;
4582
4583     case GFC_ISYM_NINT:
4584       gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4585       break;
4586
4587     case GFC_ISYM_CEILING:
4588       gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4589       break;
4590
4591     case GFC_ISYM_FLOOR:
4592       gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4593       break;
4594
4595     case GFC_ISYM_MOD:
4596       gfc_conv_intrinsic_mod (se, expr, 0);
4597       break;
4598
4599     case GFC_ISYM_MODULO:
4600       gfc_conv_intrinsic_mod (se, expr, 1);
4601       break;
4602
4603     case GFC_ISYM_CMPLX:
4604       gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4605       break;
4606
4607     case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4608       gfc_conv_intrinsic_iargc (se, expr);
4609       break;
4610
4611     case GFC_ISYM_COMPLEX:
4612       gfc_conv_intrinsic_cmplx (se, expr, 1);
4613       break;
4614
4615     case GFC_ISYM_CONJG:
4616       gfc_conv_intrinsic_conjg (se, expr);
4617       break;
4618
4619     case GFC_ISYM_COUNT:
4620       gfc_conv_intrinsic_count (se, expr);
4621       break;
4622
4623     case GFC_ISYM_CTIME:
4624       gfc_conv_intrinsic_ctime (se, expr);
4625       break;
4626
4627     case GFC_ISYM_DIM:
4628       gfc_conv_intrinsic_dim (se, expr);
4629       break;
4630
4631     case GFC_ISYM_DOT_PRODUCT:
4632       gfc_conv_intrinsic_dot_product (se, expr);
4633       break;
4634
4635     case GFC_ISYM_DPROD:
4636       gfc_conv_intrinsic_dprod (se, expr);
4637       break;
4638
4639     case GFC_ISYM_FDATE:
4640       gfc_conv_intrinsic_fdate (se, expr);
4641       break;
4642
4643     case GFC_ISYM_FRACTION:
4644       gfc_conv_intrinsic_fraction (se, expr);
4645       break;
4646
4647     case GFC_ISYM_IAND:
4648       gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4649       break;
4650
4651     case GFC_ISYM_IBCLR:
4652       gfc_conv_intrinsic_singlebitop (se, expr, 0);
4653       break;
4654
4655     case GFC_ISYM_IBITS:
4656       gfc_conv_intrinsic_ibits (se, expr);
4657       break;
4658
4659     case GFC_ISYM_IBSET:
4660       gfc_conv_intrinsic_singlebitop (se, expr, 1);
4661       break;
4662
4663     case GFC_ISYM_IACHAR:
4664     case GFC_ISYM_ICHAR:
4665       /* We assume ASCII character sequence.  */
4666       gfc_conv_intrinsic_ichar (se, expr);
4667       break;
4668
4669     case GFC_ISYM_IARGC:
4670       gfc_conv_intrinsic_iargc (se, expr);
4671       break;
4672
4673     case GFC_ISYM_IEOR:
4674       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4675       break;
4676
4677     case GFC_ISYM_INDEX:
4678       kind = expr->value.function.actual->expr->ts.kind;
4679       if (kind == 1)
4680        fndecl = gfor_fndecl_string_index;
4681       else if (kind == 4)
4682        fndecl = gfor_fndecl_string_index_char4;
4683       else
4684        gcc_unreachable ();
4685
4686       gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
4687       break;
4688
4689     case GFC_ISYM_IOR:
4690       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4691       break;
4692
4693     case GFC_ISYM_IS_IOSTAT_END:
4694       gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4695       break;
4696
4697     case GFC_ISYM_IS_IOSTAT_EOR:
4698       gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4699       break;
4700
4701     case GFC_ISYM_ISNAN:
4702       gfc_conv_intrinsic_isnan (se, expr);
4703       break;
4704
4705     case GFC_ISYM_LSHIFT:
4706       gfc_conv_intrinsic_rlshift (se, expr, 0);
4707       break;
4708
4709     case GFC_ISYM_RSHIFT:
4710       gfc_conv_intrinsic_rlshift (se, expr, 1);
4711       break;
4712
4713     case GFC_ISYM_ISHFT:
4714       gfc_conv_intrinsic_ishft (se, expr);
4715       break;
4716
4717     case GFC_ISYM_ISHFTC:
4718       gfc_conv_intrinsic_ishftc (se, expr);
4719       break;
4720
4721     case GFC_ISYM_LEADZ:
4722       gfc_conv_intrinsic_leadz (se, expr);
4723       break;
4724
4725     case GFC_ISYM_TRAILZ:
4726       gfc_conv_intrinsic_trailz (se, expr);
4727       break;
4728
4729     case GFC_ISYM_LBOUND:
4730       gfc_conv_intrinsic_bound (se, expr, 0);
4731       break;
4732
4733     case GFC_ISYM_TRANSPOSE:
4734       if (se->ss && se->ss->useflags)
4735         {
4736           gfc_conv_tmp_array_ref (se);
4737           gfc_advance_se_ss_chain (se);
4738         }
4739       else
4740         gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4741       break;
4742
4743     case GFC_ISYM_LEN:
4744       gfc_conv_intrinsic_len (se, expr);
4745       break;
4746
4747     case GFC_ISYM_LEN_TRIM:
4748       gfc_conv_intrinsic_len_trim (se, expr);
4749       break;
4750
4751     case GFC_ISYM_LGE:
4752       gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4753       break;
4754
4755     case GFC_ISYM_LGT:
4756       gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4757       break;
4758
4759     case GFC_ISYM_LLE:
4760       gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4761       break;
4762
4763     case GFC_ISYM_LLT:
4764       gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4765       break;
4766
4767     case GFC_ISYM_MAX:
4768       if (expr->ts.type == BT_CHARACTER)
4769         gfc_conv_intrinsic_minmax_char (se, expr, 1);
4770       else
4771         gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4772       break;
4773
4774     case GFC_ISYM_MAXLOC:
4775       gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4776       break;
4777
4778     case GFC_ISYM_MAXVAL:
4779       gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4780       break;
4781
4782     case GFC_ISYM_MERGE:
4783       gfc_conv_intrinsic_merge (se, expr);
4784       break;
4785
4786     case GFC_ISYM_MIN:
4787       if (expr->ts.type == BT_CHARACTER)
4788         gfc_conv_intrinsic_minmax_char (se, expr, -1);
4789       else
4790         gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4791       break;
4792
4793     case GFC_ISYM_MINLOC:
4794       gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4795       break;
4796
4797     case GFC_ISYM_MINVAL:
4798       gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4799       break;
4800
4801     case GFC_ISYM_NEAREST:
4802       gfc_conv_intrinsic_nearest (se, expr);
4803       break;
4804
4805     case GFC_ISYM_NOT:
4806       gfc_conv_intrinsic_not (se, expr);
4807       break;
4808
4809     case GFC_ISYM_OR:
4810       gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4811       break;
4812
4813     case GFC_ISYM_PRESENT:
4814       gfc_conv_intrinsic_present (se, expr);
4815       break;
4816
4817     case GFC_ISYM_PRODUCT:
4818       gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4819       break;
4820
4821     case GFC_ISYM_RRSPACING:
4822       gfc_conv_intrinsic_rrspacing (se, expr);
4823       break;
4824
4825     case GFC_ISYM_SET_EXPONENT:
4826       gfc_conv_intrinsic_set_exponent (se, expr);
4827       break;
4828
4829     case GFC_ISYM_SCALE:
4830       gfc_conv_intrinsic_scale (se, expr);
4831       break;
4832
4833     case GFC_ISYM_SIGN:
4834       gfc_conv_intrinsic_sign (se, expr);
4835       break;
4836
4837     case GFC_ISYM_SIZE:
4838       gfc_conv_intrinsic_size (se, expr);
4839       break;
4840
4841     case GFC_ISYM_SIZEOF:
4842       gfc_conv_intrinsic_sizeof (se, expr);
4843       break;
4844
4845     case GFC_ISYM_SPACING:
4846       gfc_conv_intrinsic_spacing (se, expr);
4847       break;
4848
4849     case GFC_ISYM_SUM:
4850       gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4851       break;
4852
4853     case GFC_ISYM_TRANSFER:
4854       if (se->ss && se->ss->useflags)
4855         {
4856           /* Access the previously obtained result.  */
4857           gfc_conv_tmp_array_ref (se);
4858           gfc_advance_se_ss_chain (se);
4859         }
4860       else
4861         gfc_conv_intrinsic_transfer (se, expr);
4862       break;
4863
4864     case GFC_ISYM_TTYNAM:
4865       gfc_conv_intrinsic_ttynam (se, expr);
4866       break;
4867
4868     case GFC_ISYM_UBOUND:
4869       gfc_conv_intrinsic_bound (se, expr, 1);
4870       break;
4871
4872     case GFC_ISYM_XOR:
4873       gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4874       break;
4875
4876     case GFC_ISYM_LOC:
4877       gfc_conv_intrinsic_loc (se, expr);
4878       break;
4879
4880     case GFC_ISYM_ACCESS:
4881     case GFC_ISYM_CHDIR:
4882     case GFC_ISYM_CHMOD:
4883     case GFC_ISYM_DTIME:
4884     case GFC_ISYM_ETIME:
4885     case GFC_ISYM_FGET:
4886     case GFC_ISYM_FGETC:
4887     case GFC_ISYM_FNUM:
4888     case GFC_ISYM_FPUT:
4889     case GFC_ISYM_FPUTC:
4890     case GFC_ISYM_FSTAT:
4891     case GFC_ISYM_FTELL:
4892     case GFC_ISYM_GETCWD:
4893     case GFC_ISYM_GETGID:
4894     case GFC_ISYM_GETPID:
4895     case GFC_ISYM_GETUID:
4896     case GFC_ISYM_HOSTNM:
4897     case GFC_ISYM_KILL:
4898     case GFC_ISYM_IERRNO:
4899     case GFC_ISYM_IRAND:
4900     case GFC_ISYM_ISATTY:
4901     case GFC_ISYM_LINK:
4902     case GFC_ISYM_LSTAT:
4903     case GFC_ISYM_MALLOC:
4904     case GFC_ISYM_MATMUL:
4905     case GFC_ISYM_MCLOCK:
4906     case GFC_ISYM_MCLOCK8:
4907     case GFC_ISYM_RAND:
4908     case GFC_ISYM_RENAME:
4909     case GFC_ISYM_SECOND:
4910     case GFC_ISYM_SECNDS:
4911     case GFC_ISYM_SIGNAL:
4912     case GFC_ISYM_STAT:
4913     case GFC_ISYM_SYMLNK:
4914     case GFC_ISYM_SYSTEM:
4915     case GFC_ISYM_TIME:
4916     case GFC_ISYM_TIME8:
4917     case GFC_ISYM_UMASK:
4918     case GFC_ISYM_UNLINK:
4919       gfc_conv_intrinsic_funcall (se, expr);
4920       break;
4921
4922     case GFC_ISYM_EOSHIFT:
4923     case GFC_ISYM_PACK:
4924     case GFC_ISYM_RESHAPE:
4925       /* For those, expr->rank should always be >0 and thus the if above the
4926          switch should have matched.  */
4927       gcc_unreachable ();
4928       break;
4929
4930     default:
4931       gfc_conv_intrinsic_lib_function (se, expr);
4932       break;
4933     }
4934 }
4935
4936
4937 /* This generates code to execute before entering the scalarization loop.
4938    Currently does nothing.  */
4939
4940 void
4941 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4942 {
4943   switch (ss->expr->value.function.isym->id)
4944     {
4945     case GFC_ISYM_UBOUND:
4946     case GFC_ISYM_LBOUND:
4947       break;
4948
4949     default:
4950       gcc_unreachable ();
4951     }
4952 }
4953
4954
4955 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4956    inside the scalarization loop.  */
4957
4958 static gfc_ss *
4959 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4960 {
4961   gfc_ss *newss;
4962
4963   /* The two argument version returns a scalar.  */
4964   if (expr->value.function.actual->next->expr)
4965     return ss;
4966
4967   newss = gfc_get_ss ();
4968   newss->type = GFC_SS_INTRINSIC;
4969   newss->expr = expr;
4970   newss->next = ss;
4971   newss->data.info.dimen = 1;
4972
4973   return newss;
4974 }
4975
4976
4977 /* Walk an intrinsic array libcall.  */
4978
4979 static gfc_ss *
4980 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4981 {
4982   gfc_ss *newss;
4983
4984   gcc_assert (expr->rank > 0);
4985
4986   newss = gfc_get_ss ();
4987   newss->type = GFC_SS_FUNCTION;
4988   newss->expr = expr;
4989   newss->next = ss;
4990   newss->data.info.dimen = expr->rank;
4991
4992   return newss;
4993 }
4994
4995
4996 /* Returns nonzero if the specified intrinsic function call maps directly to
4997    an external library call.  Should only be used for functions that return
4998    arrays.  */
4999
5000 int
5001 gfc_is_intrinsic_libcall (gfc_expr * expr)
5002 {
5003   gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
5004   gcc_assert (expr->rank > 0);
5005
5006   switch (expr->value.function.isym->id)
5007     {
5008     case GFC_ISYM_ALL:
5009     case GFC_ISYM_ANY:
5010     case GFC_ISYM_COUNT:
5011     case GFC_ISYM_MATMUL:
5012     case GFC_ISYM_MAXLOC:
5013     case GFC_ISYM_MAXVAL:
5014     case GFC_ISYM_MINLOC:
5015     case GFC_ISYM_MINVAL:
5016     case GFC_ISYM_PRODUCT:
5017     case GFC_ISYM_SUM:
5018     case GFC_ISYM_SHAPE:
5019     case GFC_ISYM_SPREAD:
5020     case GFC_ISYM_TRANSPOSE:
5021       /* Ignore absent optional parameters.  */
5022       return 1;
5023
5024     case GFC_ISYM_RESHAPE:
5025     case GFC_ISYM_CSHIFT:
5026     case GFC_ISYM_EOSHIFT:
5027     case GFC_ISYM_PACK:
5028     case GFC_ISYM_UNPACK:
5029       /* Pass absent optional parameters.  */
5030       return 2;
5031
5032     default:
5033       return 0;
5034     }
5035 }
5036
5037 /* Walk an intrinsic function.  */
5038 gfc_ss *
5039 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
5040                              gfc_intrinsic_sym * isym)
5041 {
5042   gcc_assert (isym);
5043
5044   if (isym->elemental)
5045     return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
5046
5047   if (expr->rank == 0)
5048     return ss;
5049
5050   if (gfc_is_intrinsic_libcall (expr))
5051     return gfc_walk_intrinsic_libfunc (ss, expr);
5052
5053   /* Special cases.  */
5054   switch (isym->id)
5055     {
5056     case GFC_ISYM_LBOUND:
5057     case GFC_ISYM_UBOUND:
5058       return gfc_walk_intrinsic_bound (ss, expr);
5059
5060     case GFC_ISYM_TRANSFER:
5061       return gfc_walk_intrinsic_libfunc (ss, expr);
5062
5063     default:
5064       /* This probably meant someone forgot to add an intrinsic to the above
5065          list(s) when they implemented it, or something's gone horribly
5066          wrong.  */
5067       gcc_unreachable ();
5068     }
5069 }
5070
5071 #include "gt-fortran-trans-intrinsic.h"