/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "tm.h" /* For UNITS_PER_WORD. */
#include "tree.h"
-#include <stdio.h>
-#include <string.h>
#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
-#include "tree-gimple.h"
+#include "diagnostic-core.h" /* For internal_error. */
+#include "toplev.h" /* For rest_of_decl_compilation. */
#include "flags.h"
#include "gfortran.h"
#include "arith.h"
/* This maps fortran intrinsic math functions to external library or GCC
builtin functions. */
-typedef struct gfc_intrinsic_map_t GTY(())
-{
+typedef struct GTY(()) gfc_intrinsic_map_t {
/* The explicit enum is required to work around inadequacies in the
garbage collection/gengtype parsing mechanism. */
- enum gfc_generic_isym_id id;
+ enum gfc_isym_id id;
/* Enum value from the "language-independent", aka C-centric, part
of gcc, or END_BUILTINS of no such value set. */
- /* ??? There are now complex variants in builtins.def, though we
- don't currently do anything with them. */
- enum built_in_function code4;
- enum built_in_function code8;
+ enum built_in_function float_built_in;
+ enum built_in_function double_built_in;
+ enum built_in_function long_double_built_in;
+ enum built_in_function complex_float_built_in;
+ enum built_in_function complex_double_built_in;
+ enum built_in_function complex_long_double_built_in;
/* True if the naming pattern is to prepend "c" for complex and
append "f" for kind=4. False if the naming pattern is to
- prepend "_gfortran_" and append "[rc][48]". */
+ prepend "_gfortran_" and append "[rc](4|8|10|16)". */
bool libm_name;
/* True if a complex version of the function exists. */
/* Cache decls created for the various operand types. */
tree real4_decl;
tree real8_decl;
+ tree real10_decl;
+ tree real16_decl;
tree complex4_decl;
tree complex8_decl;
+ tree complex10_decl;
+ tree complex16_decl;
}
gfc_intrinsic_map_t;
/* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
defines complex variants of all of the entries in mathbuiltins.def
except for atan2. */
-#define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
- HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
-
-#define DEFINE_MATH_BUILTIN(id, name, argtype) \
- BUILT_IN_FUNCTION (id, name, false)
-
-/* TODO: Use builtin function for complex intrinsics. */
-#define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
- BUILT_IN_FUNCTION (id, name, true)
-
-#define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
- NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
-
-#define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
- { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
- NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
+ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+ BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+
+#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
+ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+ BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
+ BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
+
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
+ { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+ BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
+ NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
- /* Functions built into gcc itself. */
+ /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
+ DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
+ to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
#include "mathbuiltins.def"
- /* Functions in libm. */
- /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
- pattern for other mathbuiltins.def entries. At present we have no
- optimizations for this in the common sources. */
- LIBM_FUNCTION (SCALE, "scalbn", false),
-
/* Functions in libgfortran. */
- LIBF_FUNCTION (FRACTION, "fraction", false),
- LIBF_FUNCTION (NEAREST, "nearest", false),
- LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
+ LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
/* End the list. */
- LIBF_FUNCTION (NONE, NULL, false)
+ LIB_FUNCTION (NONE, NULL, false)
+
};
+#undef OTHER_BUILTIN
+#undef LIB_FUNCTION
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
-#undef BUILT_IN_FUNCTION
-#undef LIBM_FUNCTION
-#undef LIBF_FUNCTION
-/* Structure for storing components of a floating number to be used by
- elemental functions to manipulate reals. */
-typedef struct
+
+enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
+
+
+/* Find the correct variant of a given builtin from its argument. */
+static tree
+builtin_decl_for_precision (enum built_in_function base_built_in,
+ int precision)
+{
+ enum built_in_function i = END_BUILTINS;
+
+ gfc_intrinsic_map_t *m;
+ for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
+ ;
+
+ if (precision == TYPE_PRECISION (float_type_node))
+ i = m->float_built_in;
+ else if (precision == TYPE_PRECISION (double_type_node))
+ i = m->double_built_in;
+ else if (precision == TYPE_PRECISION (long_double_type_node))
+ i = m->long_double_built_in;
+ else if (precision == TYPE_PRECISION (float128_type_node))
+ {
+ /* Special treatment, because it is not exactly a built-in, but
+ a library function. */
+ return m->real16_decl;
+ }
+
+ return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
+}
+
+
+tree
+gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
+ int kind)
{
- tree arg; /* Variable tree to view convert to integer. */
- tree expn; /* Variable tree to save exponent. */
- tree frac; /* Variable tree to save fraction. */
- tree smask; /* Constant tree of sign's mask. */
- tree emask; /* Constant tree of exponent's mask. */
- tree fmask; /* Constant tree of fraction's mask. */
- tree edigits; /* Constant tree of the number of exponent bits. */
- tree fdigits; /* Constant tree of the number of fraction bits. */
- tree f1; /* Constant tree of the f1 defined in the real model. */
- tree bias; /* Constant tree of the bias of exponent in the memory. */
- tree type; /* Type tree of arg1. */
- tree mtype; /* Type tree of integer type. Kind is that of arg1. */
+ int i = gfc_validate_kind (BT_REAL, kind, false);
+
+ if (gfc_real_kinds[i].c_float128)
+ {
+ /* For __float128, the story is a bit different, because we return
+ a decl to a library function rather than a built-in. */
+ gfc_intrinsic_map_t *m;
+ for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
+ ;
+
+ return m->real16_decl;
+ }
+
+ return builtin_decl_for_precision (double_built_in,
+ gfc_real_kinds[i].mode_precision);
}
-real_compnt_info;
-/* Evaluate the arguments to an intrinsic function. */
+/* Evaluate the arguments to an intrinsic function. The value
+ of NARGS may be less than the actual number of arguments in EXPR
+ to allow optional "KIND" arguments that are not included in the
+ generated code to be ignored. */
-static tree
-gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
+static void
+gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
+ tree *argarray, int nargs)
{
gfc_actual_arglist *actual;
- tree args;
+ gfc_expr *e;
+ gfc_intrinsic_arg *formal;
gfc_se argse;
+ int curr_arg;
- args = NULL_TREE;
- for (actual = expr->value.function.actual; actual; actual = actual->next)
+ formal = expr->value.function.isym->formal;
+ actual = expr->value.function.actual;
+
+ for (curr_arg = 0; curr_arg < nargs; curr_arg++,
+ actual = actual->next,
+ formal = formal ? formal->next : NULL)
{
- /* Skip ommitted optional arguments. */
- if (!actual->expr)
- continue;
+ gcc_assert (actual);
+ e = actual->expr;
+ /* Skip omitted optional arguments. */
+ if (!e)
+ {
+ --curr_arg;
+ continue;
+ }
/* Evaluate the parameter. This will substitute scalarized
references automatically. */
gfc_init_se (&argse, se);
- if (actual->expr->ts.type == BT_CHARACTER)
+ if (e->ts.type == BT_CHARACTER)
{
- gfc_conv_expr (&argse, actual->expr);
+ gfc_conv_expr (&argse, e);
gfc_conv_string_parameter (&argse);
- args = gfc_chainon_list (args, argse.string_length);
+ argarray[curr_arg++] = argse.string_length;
+ gcc_assert (curr_arg < nargs);
}
else
- gfc_conv_expr_val (&argse, actual->expr);
+ gfc_conv_expr_val (&argse, e);
+
+ /* If an optional argument is itself an optional dummy argument,
+ check its presence and substitute a null if absent. */
+ if (e->expr_type == EXPR_VARIABLE
+ && e->symtree->n.sym->attr.optional
+ && formal
+ && formal->optional)
+ gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- args = gfc_chainon_list (args, argse.expr);
+ argarray[curr_arg] = argse.expr;
+ }
+}
+
+/* Count the number of actual arguments to the intrinsic function EXPR
+ including any "hidden" string length arguments. */
+
+static unsigned int
+gfc_intrinsic_argument_list_length (gfc_expr *expr)
+{
+ int n = 0;
+ gfc_actual_arglist *actual;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next)
+ {
+ if (!actual->expr)
+ continue;
+
+ if (actual->expr->ts.type == BT_CHARACTER)
+ n += 2;
+ else
+ n++;
}
- return args;
+
+ return n;
}
gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
{
tree type;
- tree arg;
+ tree *args;
+ int nargs;
- /* Evaluate the argument. */
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, nargs);
+
+ /* Evaluate all the arguments passed. Whilst we're only interested in the
+ first one here, there are other parts of the front-end that assume this
+ and will trigger an ICE if it's not the case. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
+
+ /* Conversion between character kinds involves a call to a library
+ function. */
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree fndecl, var, addr, tmp;
+
+ if (expr->ts.kind == 1
+ && expr->value.function.actual->expr->ts.kind == 4)
+ fndecl = gfor_fndecl_convert_char4_to_char1;
+ else if (expr->ts.kind == 4
+ && expr->value.function.actual->expr->ts.kind == 1)
+ fndecl = gfor_fndecl_convert_char1_to_char4;
+ else
+ gcc_unreachable ();
+
+ /* Create the variable storing the converted value. */
+ type = gfc_get_pchar_type (expr->ts.kind);
+ var = gfc_create_var (type, "str");
+ addr = gfc_build_addr_expr (build_pointer_type (type), var);
+
+ /* Call the library function that will perform the conversion. */
+ gcc_assert (nargs >= 2);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 3, addr, args[0], args[1]);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards. */
+ tmp = gfc_call_free (var);
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = args[0];
+
+ return;
+ }
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+ args[0]);
}
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
-
-/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
- TRUNC(x) = INT(x) <= x ? INT(x) : INT(x) - 1
+/* This is needed because the gcc backend only implements
+ FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
+ FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
Similarly for CEILING. */
static tree
intval = gfc_evaluate_now (intval, pblock);
tmp = convert (argtype, intval);
- cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
+ cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
+ boolean_type_node, tmp, arg);
- tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
- convert (type, integer_one_node));
- tmp = build3 (COND_EXPR, type, cond, intval, tmp);
+ tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
+ intval, build_int_cst (type, 1));
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
return tmp;
}
-/* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
- NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
+/* Round to nearest integer, away from zero. */
static tree
-build_round_expr (stmtblock_t * pblock, tree arg, tree type)
+build_round_expr (tree arg, tree restype)
{
- tree tmp;
- tree cond;
- tree neg;
- tree pos;
tree argtype;
- REAL_VALUE_TYPE r;
+ tree fn;
+ bool longlong;
+ int argprec, resprec;
argtype = TREE_TYPE (arg);
- arg = gfc_evaluate_now (arg, pblock);
-
- real_from_string (&r, "0.5");
- pos = build_real (argtype, r);
-
- real_from_string (&r, "-0.5");
- neg = build_real (argtype, r);
+ argprec = TYPE_PRECISION (argtype);
+ resprec = TYPE_PRECISION (restype);
+
+ /* Depending on the type of the result, choose the long int intrinsic
+ (lround family) or long long intrinsic (llround). We might also
+ need to convert the result afterwards. */
+ if (resprec <= LONG_TYPE_SIZE)
+ longlong = false;
+ else if (resprec <= LONG_LONG_TYPE_SIZE)
+ longlong = true;
+ else
+ gcc_unreachable ();
- tmp = gfc_build_const (argtype, integer_zero_node);
- cond = fold (build2 (GT_EXPR, boolean_type_node, arg, tmp));
+ /* Now, depending on the argument type, we choose between intrinsics. */
+ if (longlong)
+ fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
+ else
+ fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
- tmp = fold (build3 (COND_EXPR, argtype, cond, pos, neg));
- tmp = fold (build2 (PLUS_EXPR, argtype, arg, tmp));
- return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
+ return fold_convert (restype, build_call_expr_loc (input_location,
+ fn, 1, arg));
}
however the RTL expander only actually supports FIX_TRUNC_EXPR. */
static tree
-build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
+build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
+ enum rounding_mode op)
{
switch (op)
{
- case FIX_FLOOR_EXPR:
+ case RND_FLOOR:
return build_fixbound_expr (pblock, arg, type, 0);
break;
- case FIX_CEIL_EXPR:
+ case RND_CEIL:
return build_fixbound_expr (pblock, arg, type, 1);
break;
- case FIX_ROUND_EXPR:
- return build_round_expr (pblock, arg, type);
+ case RND_ROUND:
+ return build_round_expr (arg, type);
+ break;
+
+ case RND_TRUNC:
+ return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
+ break;
default:
- return build1 (op, type, arg);
+ gcc_unreachable ();
}
}
/* Round a real value using the specified rounding mode.
We use a temporary integer of that same kind size as the result.
- Values larger than can be represented by this kind are unchanged, as
- will not be accurate enough to represent the rounding.
+ Values larger than those that can be represented by this kind are
+ unchanged, as they will not be accurate enough to represent the
+ rounding.
huge = HUGE (KIND (a))
aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
*/
static void
-gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
{
tree type;
tree itype;
- tree arg;
+ tree arg[2];
tree tmp;
tree cond;
+ tree decl;
mpfr_t huge;
- int n;
+ int n, nargs;
int kind;
kind = expr->ts.kind;
+ nargs = gfc_intrinsic_argument_list_length (expr);
- n = END_BUILTINS;
+ decl = NULL_TREE;
/* We have builtin functions for some cases. */
switch (op)
{
- case FIX_ROUND_EXPR:
- switch (kind)
- {
- case 4:
- n = BUILT_IN_ROUNDF;
- break;
-
- case 8:
- n = BUILT_IN_ROUND;
- break;
- }
+ case RND_ROUND:
+ decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
break;
- case FIX_FLOOR_EXPR:
- switch (kind)
- {
- case 4:
- n = BUILT_IN_FLOORF;
- break;
+ case RND_TRUNC:
+ decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
+ break;
- case 8:
- n = BUILT_IN_FLOOR;
- break;
- }
+ default:
+ gcc_unreachable ();
}
/* Evaluate the argument. */
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
/* Use a builtin function if one exists. */
- if (n != END_BUILTINS)
+ if (decl != NULL_TREE)
{
- tmp = built_in_decls[n];
- se->expr = gfc_build_function_call (tmp, arg);
+ se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
return;
}
/* This code is probably redundant, but we'll keep it lying around just
in case. */
type = gfc_typenode_for_spec (&expr->ts);
- arg = TREE_VALUE (arg);
- arg = gfc_evaluate_now (arg, &se->pre);
+ arg[0] = gfc_evaluate_now (arg[0], &se->pre);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (kind);
mpfr_init (huge);
n = gfc_validate_kind (BT_INTEGER, kind, false);
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
- tmp = gfc_conv_mpfr_to_tree (huge, kind);
- cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
+ tmp);
mpfr_neg (huge, huge, GFC_RND_MODE);
- tmp = gfc_conv_mpfr_to_tree (huge, kind);
- tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
- cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
+ tmp);
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
itype = gfc_get_int_type (kind);
- tmp = build_fix_expr (&se->pre, arg, itype, op);
+ tmp = build_fix_expr (&se->pre, arg[0], itype, op);
tmp = convert (type, tmp);
- se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+ arg[0]);
mpfr_clear (huge);
}
/* Convert to an integer using the specified rounding mode. */
static void
-gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
{
tree type;
- tree arg;
+ tree *args;
+ int nargs;
- /* Evaluate the argument. */
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, nargs);
+
+ /* Evaluate the argument, we process all arguments even though we only
+ use the first one for code generation purposes. */
type = gfc_typenode_for_spec (&expr->ts);
gcc_assert (expr->value.function.actual->expr);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
- if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
+ if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
{
/* Conversion to a different integer kind. */
- se->expr = convert (type, arg);
+ se->expr = convert (type, args[0]);
}
else
{
/* Conversion from complex to non-complex involves taking the real
component of the value. */
- if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
+ if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
&& expr->ts.type != BT_COMPLEX)
{
tree artype;
- artype = TREE_TYPE (TREE_TYPE (arg));
- arg = build1 (REALPART_EXPR, artype, arg);
+ artype = TREE_TYPE (TREE_TYPE (args[0]));
+ args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
+ args[0]);
}
- se->expr = build_fix_expr (&se->pre, arg, type, op);
+ se->expr = build_fix_expr (&se->pre, args[0], type, op);
}
}
{
tree arg;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
- se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (arg)), arg);
}
{
tree arg;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
- se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
+}
+
+
+
+static tree
+define_quad_builtin (const char *name, tree type, bool is_const)
+{
+ tree fndecl;
+ fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
+ type);
+
+ /* Mark the decl as external. */
+ DECL_EXTERNAL (fndecl) = 1;
+ TREE_PUBLIC (fndecl) = 1;
+
+ /* Mark it __attribute__((const)). */
+ TREE_READONLY (fndecl) = is_const;
+
+ rest_of_decl_compilation (fndecl, 1, 0);
+
+ return fndecl;
}
+
/* Initialize function decls for library functions. The external functions
are created as required. Builtin functions are added here. */
gfc_build_intrinsic_lib_fndecls (void)
{
gfc_intrinsic_map_t *m;
+ tree quad_decls[END_BUILTINS + 1];
+
+ if (gfc_real16_is_float128)
+ {
+ /* If we have soft-float types, we create the decls for their
+ C99-like library functions. For now, we only handle __float128
+ q-suffixed functions. */
+
+ tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
+ tree func_lround, func_llround, func_scalbn, func_cpow;
+
+ memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
+
+ type = float128_type_node;
+ complex_type = complex_float128_type_node;
+ /* type (*) (type) */
+ func_1 = build_function_type_list (type, type, NULL_TREE);
+ /* long (*) (type) */
+ func_lround = build_function_type_list (long_integer_type_node,
+ type, NULL_TREE);
+ /* long long (*) (type) */
+ func_llround = build_function_type_list (long_long_integer_type_node,
+ type, NULL_TREE);
+ /* type (*) (type, type) */
+ func_2 = build_function_type_list (type, type, type, NULL_TREE);
+ /* type (*) (type, &int) */
+ func_frexp
+ = build_function_type_list (type,
+ type,
+ build_pointer_type (integer_type_node),
+ NULL_TREE);
+ /* type (*) (type, int) */
+ func_scalbn = build_function_type_list (type,
+ type, integer_type_node, NULL_TREE);
+ /* type (*) (complex type) */
+ func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
+ /* complex type (*) (complex type, complex type) */
+ func_cpow
+ = build_function_type_list (complex_type,
+ complex_type, complex_type, NULL_TREE);
+
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
+#define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
+#define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
+
+ /* Only these built-ins are actually needed here. These are used directly
+ from the code, when calling builtin_decl_for_precision() or
+ builtin_decl_for_float_type(). The others are all constructed by
+ gfc_get_intrinsic_lib_fndecl(). */
+#define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
+ quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
+
+#include "mathbuiltins.def"
+
+#undef OTHER_BUILTIN
+#undef LIB_FUNCTION
+#undef DEFINE_MATH_BUILTIN
+#undef DEFINE_MATH_BUILTIN_C
+
+ }
/* Add GCC builtin functions. */
- for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
+ for (m = gfc_intrinsic_map;
+ m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
{
- if (m->code4 != END_BUILTINS)
- m->real4_decl = built_in_decls[m->code4];
- if (m->code8 != END_BUILTINS)
- m->real8_decl = built_in_decls[m->code8];
+ if (m->float_built_in != END_BUILTINS)
+ m->real4_decl = builtin_decl_explicit (m->float_built_in);
+ if (m->complex_float_built_in != END_BUILTINS)
+ m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
+ if (m->double_built_in != END_BUILTINS)
+ m->real8_decl = builtin_decl_explicit (m->double_built_in);
+ if (m->complex_double_built_in != END_BUILTINS)
+ m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
+
+ /* If real(kind=10) exists, it is always long double. */
+ if (m->long_double_built_in != END_BUILTINS)
+ m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
+ if (m->complex_long_double_built_in != END_BUILTINS)
+ m->complex10_decl
+ = builtin_decl_explicit (m->complex_long_double_built_in);
+
+ if (!gfc_real16_is_float128)
+ {
+ if (m->long_double_built_in != END_BUILTINS)
+ m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
+ if (m->complex_long_double_built_in != END_BUILTINS)
+ m->complex16_decl
+ = builtin_decl_explicit (m->complex_long_double_built_in);
+ }
+ else if (quad_decls[m->double_built_in] != NULL_TREE)
+ {
+ /* Quad-precision function calls are constructed when first
+ needed by builtin_decl_for_precision(), except for those
+ that will be used directly (define by OTHER_BUILTIN). */
+ m->real16_decl = quad_decls[m->double_built_in];
+ }
+ else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
+ {
+ /* Same thing for the complex ones. */
+ m->complex16_decl = quad_decls[m->double_built_in];
+ }
}
}
gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
{
tree type;
- tree argtypes;
+ VEC(tree,gc) *argtypes;
tree fndecl;
gfc_actual_arglist *actual;
tree *pdecl;
case 8:
pdecl = &m->real8_decl;
break;
+ case 10:
+ pdecl = &m->real10_decl;
+ break;
+ case 16:
+ pdecl = &m->real16_decl;
+ break;
default:
gcc_unreachable ();
}
case 8:
pdecl = &m->complex8_decl;
break;
+ case 10:
+ pdecl = &m->complex10_decl;
+ break;
+ case 16:
+ pdecl = &m->complex16_decl;
+ break;
default:
gcc_unreachable ();
}
if (m->libm_name)
{
- gcc_assert (ts->kind == 4 || ts->kind == 8);
- snprintf (name, sizeof (name), "%s%s%s",
- ts->type == BT_COMPLEX ? "c" : "",
- m->name,
- ts->kind == 4 ? "f" : "");
+ int n = gfc_validate_kind (BT_REAL, ts->kind, false);
+ if (gfc_real_kinds[n].c_float)
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+ else if (gfc_real_kinds[n].c_double)
+ snprintf (name, sizeof (name), "%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name);
+ else if (gfc_real_kinds[n].c_long_double)
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+ else if (gfc_real_kinds[n].c_float128)
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
+ else
+ gcc_unreachable ();
}
else
{
ts->kind);
}
- argtypes = NULL_TREE;
+ argtypes = NULL;
for (actual = expr->value.function.actual; actual; actual = actual->next)
{
type = gfc_typenode_for_spec (&actual->expr->ts);
- argtypes = gfc_chainon_list (argtypes, type);
+ VEC_safe_push (tree, gc, argtypes, type);
}
- argtypes = gfc_chainon_list (argtypes, void_type_node);
- type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
- fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
+ type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
+ fndecl = build_decl (input_location,
+ FUNCTION_DECL, get_identifier (name), type);
/* Mark the decl as external. */
DECL_EXTERNAL (fndecl) = 1;
gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
{
gfc_intrinsic_map_t *m;
- tree args;
tree fndecl;
- gfc_generic_isym_id id;
+ tree rettype;
+ tree *args;
+ unsigned int num_args;
+ gfc_isym_id id;
- id = expr->value.function.isym->generic_id;
+ id = expr->value.function.isym->id;
/* Find the entry for this function. */
- for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
+ for (m = gfc_intrinsic_map;
+ m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
{
if (id == m->id)
break;
}
/* Get the decl and generate the call. */
- args = gfc_conv_intrinsic_function_args (se, expr);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
- se->expr = gfc_build_function_call (fndecl, args);
+ rettype = TREE_TYPE (TREE_TYPE (fndecl));
+
+ fndecl = build_addr (fndecl, current_function_decl);
+ se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
+}
+
+
+/* If bounds-checking is enabled, create code to verify at runtime that the
+ string lengths for both expressions are the same (needed for e.g. MERGE).
+ If bounds-checking is not enabled, does nothing. */
+
+void
+gfc_trans_same_strlen_check (const char* intr_name, locus* where,
+ tree a, tree b, stmtblock_t* target)
+{
+ tree cond;
+ tree name;
+
+ /* If bounds-checking is disabled, do nothing. */
+ if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
+ return;
+
+ /* Compare the two string lengths. */
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
+
+ /* Output the runtime-check. */
+ name = gfc_build_cstring_const (intr_name);
+ name = gfc_build_addr_expr (pchar_type_node, name);
+ gfc_trans_runtime_check (true, false, cond, target, where,
+ "Unequal character lengths (%ld/%ld) in %s",
+ fold_convert (long_integer_type_node, a),
+ fold_convert (long_integer_type_node, b), name);
}
-/* Generate code for EXPONENT(X) intrinsic function. */
+
+/* The EXPONENT(s) intrinsic function is translated into
+ int ret;
+ frexp (s, &ret);
+ return ret;
+ */
static void
-gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
+{
+ tree arg, type, res, tmp, frexp;
+
+ frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
+ expr->value.function.actual->expr->ts.kind);
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ res = gfc_create_var (integer_type_node, NULL);
+ tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+ gfc_build_addr_expr (NULL_TREE, res));
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = fold_convert (type, res);
+}
+
+
+/* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
+ AR_FULL, suitable for the scalarizer. */
+
+static gfc_ss *
+walk_coarray (gfc_expr *e)
{
- tree args, fndecl;
- gfc_expr *a1;
+ gfc_ss *ss;
+
+ gcc_assert (gfc_get_corank (e) > 0);
- args = gfc_conv_intrinsic_function_args (se, expr);
+ ss = gfc_walk_expr (e);
- a1 = expr->value.function.actual->expr;
- switch (a1->ts.kind)
+ /* Fix scalar coarray. */
+ if (ss == gfc_ss_terminator)
{
- case 4:
- fndecl = gfor_fndecl_math_exponent4;
- break;
- case 8:
- fndecl = gfor_fndecl_math_exponent8;
- break;
- default:
- gcc_unreachable ();
+ gfc_ref *ref;
+
+ ss = gfc_get_array_ss (gfc_ss_terminator, e, 0, GFC_SS_SECTION);
+
+ ref = e->ref;
+ while (ref)
+ {
+ if (ref->type == REF_ARRAY
+ && ref->u.ar.codimen > 0)
+ break;
+
+ ref = ref->next;
+ }
+
+ gcc_assert (ref != NULL);
+ ref->u.ar.type = AR_FULL;
+ ss->data.info.ref = ref;
}
- se->expr = gfc_build_function_call (fndecl, args);
+ return ss;
}
-/* Evaluate a single upper or lower bound. */
-/* TODO: bound intrinsic generates way too much unnecessary code. */
static void
-gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
+trans_this_image (gfc_se * se, gfc_expr *expr)
{
- gfc_actual_arglist *arg;
- gfc_actual_arglist *arg2;
- tree desc;
- tree type;
- tree bound;
- tree tmp;
- tree cond;
+ stmtblock_t loop;
+ tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
+ lbound, ubound, extent, ml;
gfc_se argse;
gfc_ss *ss;
- int i;
+ int rank, corank;
+
+ /* The case -fcoarray=single is handled elsewhere. */
+ gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
+
+ gfc_init_coarray_decl (false);
+
+ /* Argument-free version: THIS_IMAGE(). */
+ if (expr->value.function.actual->expr == NULL)
+ {
+ se->expr = gfort_gvar_caf_this_image;
+ return;
+ }
+ /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
+
+ type = gfc_get_int_type (gfc_default_integer_kind);
+ corank = gfc_get_corank (expr->value.function.actual->expr);
+ rank = expr->value.function.actual->expr->rank;
+
+ /* Obtain the descriptor of the COARRAY. */
gfc_init_se (&argse, NULL);
- arg = expr->value.function.actual;
- arg2 = arg->next;
+ ss = walk_coarray (expr->value.function.actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ argse.want_coarray = 1;
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = argse.expr;
if (se->ss)
{
/* Create an implicit second parameter from the loop variable. */
- gcc_assert (!arg2->expr);
+ gcc_assert (!expr->value.function.actual->next->expr);
+ gcc_assert (corank > 0);
gcc_assert (se->loop->dimen == 1);
gcc_assert (se->ss->expr == expr);
+
+ dim_arg = se->loop->loopvar[0];
+ dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), 1));
gfc_advance_se_ss_chain (se);
- bound = se->loop->loopvar[0];
- bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
- se->loop->from[0]));
}
else
{
- /* use the passed argument. */
- gcc_assert (arg->next->expr);
+ /* Use the passed DIM= argument. */
+ gcc_assert (expr->value.function.actual->next->expr);
gfc_init_se (&argse, NULL);
- gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
+ gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
+ gfc_array_index_type);
gfc_add_block_to_block (&se->pre, &argse.pre);
- bound = argse.expr;
- /* Convert from one based to zero based. */
- bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
- gfc_index_one_node));
+ dim_arg = argse.expr;
+
+ if (INTEGER_CST_P (dim_arg))
+ {
+ int hi, co_dim;
+
+ hi = TREE_INT_CST_HIGH (dim_arg);
+ co_dim = TREE_INT_CST_LOW (dim_arg);
+ if (hi || co_dim < 1
+ || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", expr->value.function.isym->name,
+ &expr->where);
+ }
+ else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), 1));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ dim_arg, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
}
- /* TODO: don't re-evaluate the descriptor on each iteration. */
- /* Get a descriptor for the first parameter. */
- ss = gfc_walk_expr (arg->expr);
- gcc_assert (ss != gfc_ss_terminator);
- argse.want_pointer = 0;
- gfc_conv_expr_descriptor (&argse, arg->expr, ss);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
+ /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
+ one always has a dim_arg argument.
- desc = argse.expr;
+ m = this_images() - 1
+ i = rank
+ min_var = min (rank + corank - 2, rank + dim_arg - 1)
+ for (;;)
+ {
+ extent = gfc_extent(i)
+ ml = m
+ m = m/extent
+ if (i >= min_var)
+ goto exit_label
+ i++
+ }
+ exit_label:
+ sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank)
+ */
- if (INTEGER_CST_P (bound))
- {
- gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
- i = TREE_INT_CST_LOW (bound);
- gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
- }
- else
- {
- if (flag_bounds_check)
- {
- bound = gfc_evaluate_now (bound, &se->pre);
- cond = fold (build2 (LT_EXPR, boolean_type_node,
- bound, convert (TREE_TYPE (bound),
- integer_zero_node)));
- tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
- tmp = fold (build2 (GE_EXPR, boolean_type_node, bound, tmp));
- cond = fold(build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
- gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
- }
- }
+ m = gfc_create_var (type, NULL);
+ ml = gfc_create_var (type, NULL);
+ loop_var = gfc_create_var (integer_type_node, NULL);
+ min_var = gfc_create_var (integer_type_node, NULL);
+
+ /* m = this_image () - 1. */
+ tmp = fold_convert (type, gfort_gvar_caf_this_image);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
+ build_int_cst (type, 1));
+ gfc_add_modify (&se->pre, m, tmp);
+
+ /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ fold_convert (integer_type_node, dim_arg),
+ build_int_cst (integer_type_node, rank - 1));
+ tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
+ build_int_cst (integer_type_node, rank + corank - 2),
+ tmp);
+ gfc_add_modify (&se->pre, min_var, tmp);
+
+ /* i = rank. */
+ tmp = build_int_cst (integer_type_node, rank);
+ gfc_add_modify (&se->pre, loop_var, tmp);
- if (upper)
- se->expr = gfc_conv_descriptor_ubound(desc, bound);
- else
- se->expr = gfc_conv_descriptor_lbound(desc, bound);
+ exit_label = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (exit_label) = 1;
- type = gfc_typenode_for_spec (&expr->ts);
- se->expr = convert (type, se->expr);
+ /* Loop body. */
+ gfc_init_block (&loop);
+
+ /* ml = m. */
+ gfc_add_modify (&loop, ml, m);
+
+ /* extent = ... */
+ lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
+ ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ extent = fold_convert (type, extent);
+
+ /* m = m/extent. */
+ gfc_add_modify (&loop, m,
+ fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
+ m, extent));
+
+ /* Exit condition: if (i >= min_var) goto exit_label. */
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
+ min_var);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop, tmp);
+
+ /* Increment loop variable: i++. */
+ gfc_add_modify (&loop, loop_var,
+ fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+ loop_var,
+ build_int_cst (integer_type_node, 1)));
+
+ /* Making the loop... actually loop! */
+ tmp = gfc_finish_block (&loop);
+ tmp = build1_v (LOOP_EXPR, tmp);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* The exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
+ : m + lcobound(corank) */
+
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), corank));
+
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, dim_arg,
+ build_int_cst (TREE_TYPE (dim_arg), rank-1)));
+ lbound = fold_convert (type, lbound);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
+ fold_build2_loc (input_location, MULT_EXPR, type,
+ m, extent));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
+ fold_build2_loc (input_location, PLUS_EXPR, type,
+ m, lbound));
}
static void
-gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
+trans_image_index (gfc_se * se, gfc_expr *expr)
{
- tree args;
- tree val;
- int n;
+ tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+ tmp, invalid_bound;
+ gfc_se argse, subse;
+ gfc_ss *ss, *subss;
+ int rank, corank, codim;
- args = gfc_conv_intrinsic_function_args (se, expr);
- gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
- val = TREE_VALUE (args);
+ type = gfc_get_int_type (gfc_default_integer_kind);
+ corank = gfc_get_corank (expr->value.function.actual->expr);
+ rank = expr->value.function.actual->expr->rank;
- switch (expr->value.function.actual->expr->ts.type)
- {
- case BT_INTEGER:
- case BT_REAL:
- se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
- break;
+ /* Obtain the descriptor of the COARRAY. */
+ gfc_init_se (&argse, NULL);
+ ss = walk_coarray (expr->value.function.actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ argse.want_coarray = 1;
+ gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = argse.expr;
- case BT_COMPLEX:
- switch (expr->ts.kind)
+ /* Obtain a handle to the SUB argument. */
+ gfc_init_se (&subse, NULL);
+ subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+ gcc_assert (subss != gfc_ss_terminator);
+ gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+ subss);
+ gfc_add_block_to_block (&se->pre, &subse.pre);
+ gfc_add_block_to_block (&se->post, &subse.post);
+ subdesc = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_descriptor_data_get (subse.expr));
+
+ /* Fortran 2008 does not require that the values remain in the cobounds,
+ thus we need explicitly check this - and return 0 if they are exceeded. */
+
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+ invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ lbound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ fold_convert (gfc_array_index_type, tmp),
+ ubound);
+ invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, invalid_bound, cond);
+ }
+
+ invalid_bound = gfc_unlikely (invalid_bound);
+
+
+ /* See Fortran 2008, C.10 for the following algorithm. */
+
+ /* coindex = sub(corank) - lcobound(n). */
+ coindex = fold_convert (gfc_array_index_type,
+ gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+ NULL));
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, coindex),
+ lbound);
+
+ for (codim = corank + rank - 2; codim >= rank; codim--)
+ {
+ tree extent, ubound;
+
+ /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+ extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+ /* coindex *= extent. */
+ coindex = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, coindex, extent);
+
+ /* coindex += sub(codim). */
+ tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+ coindex = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, coindex,
+ fold_convert (gfc_array_index_type, tmp));
+
+ /* coindex -= lbound(codim). */
+ lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+ coindex = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, coindex, lbound);
+ }
+
+ coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+ fold_convert(type, coindex),
+ build_int_cst (type, 1));
+
+ /* Return 0 if "coindex" exceeds num_images(). */
+
+ if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+ num_images = build_int_cst (type, 1);
+ else
+ {
+ gfc_init_coarray_decl (false);
+ num_images = gfort_gvar_caf_num_images;
+ }
+
+ tmp = gfc_create_var (type, NULL);
+ gfc_add_modify (&se->pre, tmp, coindex);
+
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+ num_images);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+ cond,
+ fold_convert (boolean_type_node, invalid_bound));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), tmp);
+}
+
+
+static void
+trans_num_images (gfc_se * se)
+{
+ gfc_init_coarray_decl (false);
+ se->expr = gfort_gvar_caf_num_images;
+}
+
+
+/* Evaluate a single upper or lower bound. */
+/* TODO: bound intrinsic generates way too much unnecessary code. */
+
+static void
+gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
+{
+ gfc_actual_arglist *arg;
+ gfc_actual_arglist *arg2;
+ tree desc;
+ tree type;
+ tree bound;
+ tree tmp;
+ tree cond, cond1, cond3, cond4, size;
+ tree ubound;
+ tree lbound;
+ gfc_se argse;
+ gfc_ss *ss;
+ gfc_array_spec * as;
+
+ arg = expr->value.function.actual;
+ arg2 = arg->next;
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (!arg2->expr);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->expr == expr);
+ gfc_advance_se_ss_chain (se);
+ bound = se->loop->loopvar[0];
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ se->loop->from[0]);
+ }
+ else
+ {
+ /* use the passed argument. */
+ gcc_assert (arg2->expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ bound = argse.expr;
+ /* Convert from one based to zero based. */
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_index_one_node);
+ }
+
+ /* TODO: don't re-evaluate the descriptor on each iteration. */
+ /* Get a descriptor for the first parameter. */
+ ss = gfc_walk_expr (arg->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+
+ desc = argse.expr;
+
+ if (INTEGER_CST_P (bound))
+ {
+ int hi, low;
+
+ hi = TREE_INT_CST_HIGH (bound);
+ low = TREE_INT_CST_LOW (bound);
+ if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", upper ? "UBOUND" : "LBOUND",
+ &expr->where);
+ }
+ else
+ {
+ if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ bound = gfc_evaluate_now (bound, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ bound, build_int_cst (TREE_TYPE (bound), 0));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ bound, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
+ }
+
+ ubound = gfc_conv_descriptor_ubound_get (desc, bound);
+ lbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
+
+ /* 13.14.53: Result value for LBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, LBOUND(ARRAY, DIM)
+ has the value 1. For a whole array or array structure
+ component, LBOUND(ARRAY, DIM) has the value:
+ (a) equal to the lower bound for subscript DIM of ARRAY if
+ dimension DIM of ARRAY does not have extent zero
+ or if ARRAY is an assumed-size array of rank DIM,
+ or (b) 1 otherwise.
+
+ 13.14.113: Result value for UBOUND
+
+ Case (i): For an array section or for an array expression other than a
+ whole array or array structure component, UBOUND(ARRAY, DIM)
+ has the value equal to the number of elements in the given
+ dimension; otherwise, it has a value equal to the upper bound
+ for subscript DIM of ARRAY if dimension DIM of ARRAY does
+ not have size zero and has value zero if dimension DIM has
+ size zero. */
+
+ if (as)
+ {
+ tree stride = gfc_conv_descriptor_stride_get (desc, bound);
+
+ cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ ubound, lbound);
+ cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+ cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond3, cond1);
+ cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ stride, gfc_index_zero_node);
+
+ if (upper)
{
- case 4:
- n = BUILT_IN_CABSF;
- break;
- case 8:
- n = BUILT_IN_CABS;
+ tree cond5;
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond3, cond4);
+ cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ gfc_index_one_node, lbound);
+ cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond4, cond5);
+
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond, cond5);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ ubound, gfc_index_zero_node);
+ }
+ else
+ {
+ if (as->type == AS_ASSUMED_SIZE)
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ bound, build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank - 1));
+ else
+ cond = boolean_false_node;
+
+ cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond3, cond4);
+ cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, cond, cond1);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+ }
+ else
+ {
+ if (upper)
+ {
+ size = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, size,
+ gfc_index_one_node);
+ se->expr = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_array_index_type, se->expr,
+ gfc_index_zero_node);
+ }
+ else
+ se->expr = gfc_index_one_node;
+ }
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = convert (type, se->expr);
+}
+
+
+static void
+conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
+{
+ gfc_actual_arglist *arg;
+ gfc_actual_arglist *arg2;
+ gfc_se argse;
+ gfc_ss *ss;
+ tree bound, resbound, resbound2, desc, cond, tmp;
+ tree type;
+ int corank;
+
+ gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
+ || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
+
+ arg = expr->value.function.actual;
+ arg2 = arg->next;
+
+ gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
+ corank = gfc_get_corank (arg->expr);
+
+ ss = walk_coarray (arg->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ gfc_init_se (&argse, NULL);
+ argse.want_coarray = 1;
+
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ desc = argse.expr;
+
+ if (se->ss)
+ {
+ /* Create an implicit second parameter from the loop variable. */
+ gcc_assert (!arg2->expr);
+ gcc_assert (corank > 0);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->expr == expr);
+
+ bound = se->loop->loopvar[0];
+ bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ bound, gfc_rank_cst[arg->expr->rank]);
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ {
+ /* use the passed argument. */
+ gcc_assert (arg2->expr);
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ bound = argse.expr;
+
+ if (INTEGER_CST_P (bound))
+ {
+ int hi, low;
+
+ hi = TREE_INT_CST_HIGH (bound);
+ low = TREE_INT_CST_LOW (bound);
+ if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
+ gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
+ "dimension index", expr->value.function.isym->name,
+ &expr->where);
+ }
+ else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
+ {
+ bound = gfc_evaluate_now (bound, &se->pre);
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ bound, build_int_cst (TREE_TYPE (bound), 1));
+ tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ bound, tmp);
+ cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
+ boolean_type_node, cond, tmp);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ gfc_msg_fault);
+ }
+
+
+ /* Substract 1 to get to zero based and add dimensions. */
+ switch (arg->expr->rank)
+ {
+ case 0:
+ bound = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_index_one_node);
+ case 1:
break;
default:
- gcc_unreachable ();
+ bound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, bound,
+ gfc_rank_cst[arg->expr->rank - 1]);
+ }
+ }
+
+ resbound = gfc_conv_descriptor_lbound_get (desc, bound);
+
+ /* Handle UCOBOUND with special handling of the last codimension. */
+ if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
+ {
+ /* Last codimension: For -fcoarray=single just return
+ the lcobound - otherwise add
+ ceiling (real (num_images ()) / real (size)) - 1
+ = (num_images () + size - 1) / size - 1
+ = (num_images - 1) / size(),
+ where size is the product of the extent of all but the last
+ codimension. */
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
+ {
+ tree cosize;
+
+ gfc_init_coarray_decl (false);
+ cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+ gfc_array_index_type, tmp,
+ fold_convert (gfc_array_index_type, cosize));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+ else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ {
+ /* ubound = lbound + num_images() - 1. */
+ gfc_init_coarray_decl (false);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ gfort_gvar_caf_num_images,
+ build_int_cst (gfc_array_index_type, 1));
+ resbound = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, resbound, tmp);
+ }
+
+ if (corank > 1)
+ {
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank + corank - 1));
+
+ resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ resbound, resbound2);
}
- se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
+ else
+ se->expr = resbound;
+ }
+ else
+ se->expr = resbound;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = convert (type, se->expr);
+}
+
+
+static void
+gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, cabs;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+
+ switch (expr->value.function.actual->expr->ts.type)
+ {
+ case BT_INTEGER:
+ case BT_REAL:
+ se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
+ arg);
+ break;
+
+ case BT_COMPLEX:
+ cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
+ se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
break;
default:
static void
gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
{
- tree arg;
tree real;
tree imag;
tree type;
+ tree *args;
+ unsigned int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- real = convert (TREE_TYPE (type), TREE_VALUE (arg));
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ real = convert (TREE_TYPE (type), args[0]);
if (both)
- imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
- else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
+ imag = convert (TREE_TYPE (type), args[1]);
+ else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
{
- arg = TREE_VALUE (arg);
- imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
+ imag = fold_build1_loc (input_location, IMAGPART_EXPR,
+ TREE_TYPE (TREE_TYPE (args[0])), args[0]);
imag = convert (TREE_TYPE (type), imag);
}
else
imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
- se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
+ se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
}
-/* Remainder function MOD(A, P) = A - INT(A / P) * P.
- MODULO(A, P) = (A==0 .or. !(A>0 .xor. P>0))? MOD(A,P):MOD(A,P)+P. */
+/* Remainder function MOD(A, P) = A - INT(A / P) * P
+ MODULO(A, P) = A - FLOOR (A / P) * P */
/* TODO: MOD(x, 0) */
static void
gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
{
- tree arg;
- tree arg2;
tree type;
tree itype;
tree tmp;
- tree zero;
tree test;
tree test2;
+ tree fmod;
mpfr_t huge;
- int n;
+ int n, ikind;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
switch (expr->ts.type)
{
case BT_INTEGER:
/* Integer case is easy, we've got a builtin op. */
- se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
+ type = TREE_TYPE (args[0]);
+
+ if (modulo)
+ se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
+ args[0], args[1]);
+ else
+ se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
+ args[0], args[1]);
break;
case BT_REAL:
- /* Real values we have to do the hard way. */
- arg = gfc_evaluate_now (arg, &se->pre);
- arg2 = gfc_evaluate_now (arg2, &se->pre);
+ fmod = NULL_TREE;
+ /* Check if we have a builtin fmod. */
+ fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
+
+ /* Use it if it exists. */
+ if (fmod != NULL_TREE)
+ {
+ tmp = build_addr (fmod, current_function_decl);
+ se->expr = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (fmod)),
+ tmp, 2, args);
+ if (modulo == 0)
+ return;
+ }
+
+ type = TREE_TYPE (args[0]);
+
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
+
+ /* Definition:
+ modulo = arg - floor (arg/arg2) * arg2, so
+ = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
+ where
+ test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
+ thereby avoiding another division and retaining the accuracy
+ of the builtin function. */
+ if (fmod != NULL_TREE && modulo)
+ {
+ tree zero = gfc_build_const (type, integer_zero_node);
+ tmp = gfc_evaluate_now (se->expr, &se->pre);
+ test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ args[0], zero);
+ test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ args[1], zero);
+ test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
+ boolean_type_node, test, test2);
+ test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ tmp, zero);
+ test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, test, test2);
+ test = gfc_evaluate_now (test, &se->pre);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ type, tmp, args[1]), tmp);
+ return;
+ }
+
+ /* If we do not have a built_in fmod, the calculation is going to
+ have to be done longhand. */
+ tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
- tmp = build2 (RDIV_EXPR, type, arg, arg2);
/* Test if the value is too large to handle sensibly. */
gfc_set_model_kind (expr->ts.kind);
mpfr_init (huge);
- n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+ n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
+ ikind = expr->ts.kind;
+ if (n < 0)
+ {
+ n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
+ ikind = gfc_max_integer_kind;
+ }
mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
- test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
- test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
+ test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
+ test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+ tmp, test);
mpfr_neg (huge, huge, GFC_RND_MODE);
- test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
- test = build2 (GT_EXPR, boolean_type_node, tmp, test);
- test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
-
- itype = gfc_get_int_type (expr->ts.kind);
- tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
+ test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
+ test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+ test);
+ test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, test, test2);
+
+ itype = gfc_get_int_type (ikind);
+ if (modulo)
+ tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
+ else
+ tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
tmp = convert (type, tmp);
- tmp = build3 (COND_EXPR, type, test2, tmp, arg);
- tmp = build2 (MULT_EXPR, type, tmp, arg2);
- se->expr = build2 (MINUS_EXPR, type, arg, tmp);
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
+ args[0]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
+ se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
+ tmp);
mpfr_clear (huge);
break;
default:
gcc_unreachable ();
}
+}
- if (modulo)
- {
- zero = gfc_build_const (type, integer_zero_node);
- /* Build !(A > 0 .xor. P > 0). */
- test = build2 (GT_EXPR, boolean_type_node, arg, zero);
- test2 = build2 (GT_EXPR, boolean_type_node, arg2, zero);
- test = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
- test = build1 (TRUTH_NOT_EXPR, boolean_type_node, test);
- /* Build (A == 0) .or. !(A > 0 .xor. P > 0). */
- test2 = build2 (EQ_EXPR, boolean_type_node, arg, zero);
- test = build2 (TRUTH_OR_EXPR, boolean_type_node, test, test2);
+/* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
+ DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
+ where the right shifts are logical (i.e. 0's are shifted in).
+ Because SHIFT_EXPR's want shifts strictly smaller than the integral
+ type width, we have to special-case both S == 0 and S == BITSIZE(J):
+ DSHIFTL(I,J,0) = I
+ DSHIFTL(I,J,BITSIZE) = J
+ DSHIFTR(I,J,0) = J
+ DSHIFTR(I,J,BITSIZE) = I. */
- se->expr = build3 (COND_EXPR, type, test, se->expr,
- build2 (PLUS_EXPR, type, se->expr, arg2));
- }
+static void
+gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
+{
+ tree type, utype, stype, arg1, arg2, shift, res, left, right;
+ tree args[3], cond, tmp;
+ int bitsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+
+ gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
+ type = TREE_TYPE (args[0]);
+ bitsize = TYPE_PRECISION (type);
+ utype = unsigned_type_for (type);
+ stype = TREE_TYPE (args[2]);
+
+ arg1 = gfc_evaluate_now (args[0], &se->pre);
+ arg2 = gfc_evaluate_now (args[1], &se->pre);
+ shift = gfc_evaluate_now (args[2], &se->pre);
+
+ /* The generic case. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
+ build_int_cst (stype, bitsize), shift);
+ left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ arg1, dshiftl ? shift : tmp);
+
+ right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
+ fold_convert (utype, arg2), dshiftl ? tmp : shift);
+ right = fold_convert (type, right);
+
+ res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
+
+ /* Special cases. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+ build_int_cst (stype, 0));
+ res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ dshiftl ? arg1 : arg2, res);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
+ build_int_cst (stype, bitsize));
+ res = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ dshiftl ? arg2 : arg1, res);
+
+ se->expr = res;
}
+
/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
static void
gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
tree val;
tree tmp;
tree type;
tree zero;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- val = build2 (MINUS_EXPR, type, arg, arg2);
+ val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
val = gfc_evaluate_now (val, &se->pre);
zero = gfc_build_const (type, integer_zero_node);
- tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
- se->expr = build3 (COND_EXPR, type, tmp, zero, val);
+ tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
}
/* SIGN(A, B) is absolute value of A times sign of B.
The real value versions use library functions to ensure the correct
handling of negative zero. Integer case implemented as:
- SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
+ SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
*/
static void
gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
{
tree tmp;
- tree arg;
- tree arg2;
tree type;
- tree zero;
- tree testa;
- tree testb;
+ tree args[2];
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
if (expr->ts.type == BT_REAL)
{
- switch (expr->ts.kind)
+ tree abs;
+
+ tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+ abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+
+ /* We explicitly have to ignore the minus sign. We do so by using
+ result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
+ if (!gfc_option.flag_sign_zero
+ && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
{
- case 4:
- tmp = built_in_decls[BUILT_IN_COPYSIGNF];
- break;
- case 8:
- tmp = built_in_decls[BUILT_IN_COPYSIGN];
- break;
- default:
- gcc_unreachable ();
+ tree cond, zero;
+ zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ args[1], zero);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ TREE_TYPE (args[0]), cond,
+ build_call_expr_loc (input_location, abs, 1,
+ args[0]),
+ build_call_expr_loc (input_location, tmp, 2,
+ args[0], args[1]));
}
- se->expr = fold (gfc_build_function_call (tmp, arg));
+ else
+ se->expr = build_call_expr_loc (input_location, tmp, 2,
+ args[0], args[1]);
return;
}
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
- zero = gfc_build_const (type, integer_zero_node);
-
- testa = fold (build2 (GE_EXPR, boolean_type_node, arg, zero));
- testb = fold (build2 (GE_EXPR, boolean_type_node, arg2, zero));
- tmp = fold (build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
- se->expr = fold (build3 (COND_EXPR, type, tmp,
- build1 (NEGATE_EXPR, type, arg), arg));
+ /* Having excluded floating point types, we know we are now dealing
+ with signed integer types. */
+ type = TREE_TYPE (args[0]);
+
+ /* Args[0] is used multiple times below. */
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+
+ /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
+ the signs of A and B are the same, and of all ones if they differ. */
+ tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
+ tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
+ build_int_cst (type, TYPE_PRECISION (type) - 1));
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+
+ /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
+ is all ones (i.e. -1). */
+ se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ type, args[0], tmp), tmp);
}
static void
gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
tree type;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
/* Convert the args to double precision before multiplying. */
type = gfc_typenode_for_spec (&expr->ts);
- arg = convert (type, arg);
- arg2 = convert (type, arg2);
- se->expr = build2 (MULT_EXPR, type, arg, arg2);
+ args[0] = convert (type, args[0]);
+ args[1] = convert (type, args[1]);
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
+ args[1]);
}
static void
gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
{
- tree arg;
+ tree arg[2];
tree var;
tree type;
+ unsigned int num_args;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
- /* We currently don't support character types != 1. */
- gcc_assert (expr->ts.kind == 1);
- type = gfc_character1_type_node;
+ type = gfc_get_char_type (expr->ts.kind);
var = gfc_create_var (type, "char");
- arg = convert (type, arg);
- gfc_add_modify_expr (&se->pre, var, arg);
+ arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
+ gfc_add_modify (&se->pre, var, arg[0]);
se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
- se->string_length = integer_one_node;
+ se->string_length = build_int_cst (gfc_charlen_type_node, 1);
}
-/* Get the minimum/maximum value of all the parameters.
- minmax (a1, a2, a3, ...)
- {
- if (a2 .op. a1)
- mvar = a2;
- else
- mvar = a1;
- if (a3 .op. mvar)
- mvar = a3;
- ...
+static void
+gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
+{
+ tree var;
+ tree len;
+ tree tmp;
+ tree cond;
+ tree fndecl;
+ tree *args;
+ unsigned int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = XALLOCAVEC (tree, num_args);
+
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_charlen_type_node, "len");
+
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+ fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+ fndecl, num_args, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ len, build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
+static void
+gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
+{
+ tree var;
+ tree len;
+ tree tmp;
+ tree cond;
+ tree fndecl;
+ tree *args;
+ unsigned int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = XALLOCAVEC (tree, num_args);
+
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_charlen_type_node, "len");
+
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+ fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+ fndecl, num_args, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ len, build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
+/* Return a character string containing the tty name. */
+
+static void
+gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
+{
+ tree var;
+ tree len;
+ tree tmp;
+ tree cond;
+ tree fndecl;
+ tree *args;
+ unsigned int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = XALLOCAVEC (tree, num_args);
+
+ var = gfc_create_var (pchar_type_node, "pstr");
+ len = gfc_create_var (gfc_charlen_type_node, "len");
+
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = gfc_build_addr_expr (NULL_TREE, var);
+ args[1] = gfc_build_addr_expr (NULL_TREE, len);
+
+ fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+ fndecl, num_args, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ len, build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
+/* Get the minimum/maximum value of all the parameters.
+ minmax (a1, a2, a3, ...)
+ {
+ mvar = a1;
+ if (a2 .op. mvar || isnan(mvar))
+ mvar = a2;
+ if (a3 .op. mvar || isnan(mvar))
+ mvar = a3;
+ ...
return mvar
}
*/
/* TODO: Mismatching types can occur when specific names are used.
These should be handled during resolution. */
static void
-gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
- tree limit;
tree tmp;
tree mvar;
tree val;
tree thencase;
- tree elsecase;
- tree arg;
+ tree *args;
tree type;
+ gfc_actual_arglist *argexpr;
+ unsigned int i, nargs;
- arg = gfc_conv_intrinsic_function_args (se, expr);
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, nargs);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, nargs);
type = gfc_typenode_for_spec (&expr->ts);
- limit = TREE_VALUE (arg);
- if (TREE_TYPE (limit) != type)
- limit = convert (type, limit);
+ argexpr = expr->value.function.actual;
+ if (TREE_TYPE (args[0]) != type)
+ args[0] = convert (type, args[0]);
/* Only evaluate the argument once. */
- if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
- limit = gfc_evaluate_now(limit, &se->pre);
+ if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
mvar = gfc_create_var (type, "M");
- elsecase = build2_v (MODIFY_EXPR, mvar, limit);
- for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
+ gfc_add_modify (&se->pre, mvar, args[0]);
+ for (i = 1, argexpr = argexpr->next; i < nargs; i++)
{
- val = TREE_VALUE (arg);
- if (TREE_TYPE (val) != type)
- val = convert (type, val);
+ tree cond, isnan;
+
+ val = args[i];
+
+ /* Handle absent optional arguments by ignoring the comparison. */
+ if (argexpr->expr->expr_type == EXPR_VARIABLE
+ && argexpr->expr->symtree->n.sym->attr.optional
+ && TREE_CODE (val) == INDIRECT_REF)
+ cond = fold_build2_loc (input_location,
+ NE_EXPR, boolean_type_node,
+ TREE_OPERAND (val, 0),
+ build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+ else
+ {
+ cond = NULL_TREE;
- /* Only evaluate the argument once. */
- if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
- val = gfc_evaluate_now(val, &se->pre);
+ /* Only evaluate the argument once. */
+ if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
+ val = gfc_evaluate_now (val, &se->pre);
+ }
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
- tmp = build2 (op, boolean_type_node, val, limit);
- tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
+ tmp = fold_build2_loc (input_location, op, boolean_type_node,
+ convert (type, val), mvar);
+
+ /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
+ __builtin_isnan might be made dependent on that module being loaded,
+ to help performance of programs that don't rely on IEEE semantics. */
+ if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
+ {
+ isnan = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISNAN),
+ 1, mvar);
+ tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, tmp,
+ fold_convert (boolean_type_node, isnan));
+ }
+ tmp = build3_v (COND_EXPR, tmp, thencase,
+ build_empty_stmt (input_location));
+
+ if (cond != NULL_TREE)
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
+
gfc_add_expr_to_block (&se->pre, tmp);
- elsecase = build_empty_stmt ();
- limit = mvar;
+ argexpr = argexpr->next;
}
se->expr = mvar;
}
-/* Create a symbol node for this intrinsic. The symbol form the frontend
- is for the generic name. */
+/* Generate library calls for MIN and MAX intrinsics for character
+ variables. */
+static void
+gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
+{
+ tree *args;
+ tree var, len, fndecl, tmp, cond, function;
+ unsigned int nargs;
+
+ nargs = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, nargs + 4);
+ gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
+
+ /* Create the result variables. */
+ len = gfc_create_var (gfc_charlen_type_node, "len");
+ args[0] = gfc_build_addr_expr (NULL_TREE, len);
+ var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
+ args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
+ args[2] = build_int_cst (integer_type_node, op);
+ args[3] = build_int_cst (integer_type_node, nargs / 2);
+
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_minmax;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_minmax_char4;
+ else
+ gcc_unreachable ();
+
+ /* Make the function call. */
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
+ nargs + 4, args);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ len, build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
+/* Create a symbol node for this intrinsic. The symbol from the frontend
+ has the generic name. */
static gfc_symbol *
gfc_get_symbol_for_expr (gfc_expr * expr)
sym->as->rank = expr->rank;
}
- /* TODO: proper argument lists for external intrinsics. */
+ gfc_copy_formal_args_intr (sym, expr->value.function.isym);
+
return sym;
}
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
+ VEC(tree,gc) *append_args;
gcc_assert (!se->ss || se->ss->expr == expr);
gcc_assert (expr->rank == 0);
sym = gfc_get_symbol_for_expr (expr);
- gfc_conv_function_call (se, sym, expr->value.function.actual);
- gfc_free (sym);
+
+ /* Calls to libgfortran_matmul need to be appended special arguments,
+ to be able to call the BLAS ?gemm functions if required and possible. */
+ append_args = NULL;
+ if (expr->value.function.isym->id == GFC_ISYM_MATMUL
+ && sym->ts.type != BT_LOGICAL)
+ {
+ tree cint = gfc_get_int_type (gfc_c_int_kind);
+
+ if (gfc_option.flag_external_blas
+ && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
+ && (sym->ts.kind == gfc_default_real_kind
+ || sym->ts.kind == gfc_default_double_kind))
+ {
+ tree gemm_fndecl;
+
+ if (sym->ts.type == BT_REAL)
+ {
+ if (sym->ts.kind == gfc_default_real_kind)
+ gemm_fndecl = gfor_fndecl_sgemm;
+ else
+ gemm_fndecl = gfor_fndecl_dgemm;
+ }
+ else
+ {
+ if (sym->ts.kind == gfc_default_real_kind)
+ gemm_fndecl = gfor_fndecl_cgemm;
+ else
+ gemm_fndecl = gfor_fndecl_zgemm;
+ }
+
+ append_args = VEC_alloc (tree, gc, 3);
+ VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
+ VEC_quick_push (tree, append_args,
+ build_int_cst (cint, gfc_option.blas_matmul_limit));
+ VEC_quick_push (tree, append_args,
+ gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
+ }
+ else
+ {
+ append_args = VEC_alloc (tree, gc, 3);
+ VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
+ VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
+ VEC_quick_push (tree, append_args, null_pointer_node);
+ }
+ }
+
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
+ gfc_free_symbol (sym);
}
/* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
}
*/
static void
-gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree resvar;
stmtblock_t block;
tmp = convert (type, boolean_true_node);
else
tmp = convert (type, boolean_false_node);
- gfc_add_modify_expr (&se->pre, resvar, tmp);
+ gfc_add_modify (&se->pre, resvar, tmp);
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
gfc_mark_ss_chain_used (arrayss, 1);
/* Generate the loop body. */
tmp = convert (type, boolean_false_node);
else
tmp = convert (type, boolean_true_node);
- gfc_add_modify_expr (&block, resvar, tmp);
+ gfc_add_modify (&block, resvar, tmp);
/* And break out of the loop. */
tmp = build1_v (GOTO_EXPR, exit_label);
gfc_conv_expr_val (&arrayse, actual->expr);
gfc_add_block_to_block (&body, &arrayse.pre);
- tmp = build2 (op, boolean_type_node, arrayse.expr,
- fold_convert (TREE_TYPE (arrayse.expr),
- integer_zero_node));
- tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
+ tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
+ build_int_cst (TREE_TYPE (arrayse.expr), 0));
+ tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
gfc_add_block_to_block (&body, &arrayse.post);
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
resvar = gfc_create_var (type, "count");
- gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
+ gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
gfc_mark_ss_chain_used (arrayss, 1);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
- tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
- convert (TREE_TYPE (resvar), integer_one_node));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
+ resvar, build_int_cst (TREE_TYPE (resvar), 1));
tmp = build2_v (MODIFY_EXPR, resvar, tmp);
gfc_init_se (&arrayse, NULL);
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, actual->expr);
- tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
+ build_empty_stmt (input_location));
gfc_add_block_to_block (&body, &arrayse.pre);
gfc_add_expr_to_block (&body, tmp);
/* Inline implementation of the sum and product intrinsics. */
static void
-gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
+ bool norm2)
{
tree resvar;
+ tree scale = NULL_TREE;
tree type;
stmtblock_t body;
stmtblock_t block;
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
resvar = gfc_create_var (type, "val");
- if (op == PLUS_EXPR)
+ if (norm2)
+ {
+ /* result = 0.0;
+ scale = 1.0. */
+ scale = gfc_create_var (type, "scale");
+ gfc_add_modify (&se->pre, scale,
+ gfc_build_const (type, integer_one_node));
+ tmp = gfc_build_const (type, integer_zero_node);
+ }
+ else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
tmp = gfc_build_const (type, integer_zero_node);
+ else if (op == NE_EXPR)
+ /* PARITY. */
+ tmp = convert (type, boolean_false_node);
+ else if (op == BIT_AND_EXPR)
+ tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
+ type, integer_one_node));
else
tmp = gfc_build_const (type, integer_one_node);
- gfc_add_modify_expr (&se->pre, resvar, tmp);
+ gfc_add_modify (&se->pre, resvar, tmp);
/* Walk the arguments. */
actual = expr->value.function.actual;
arrayss = gfc_walk_expr (arrayexpr);
gcc_assert (arrayss != gfc_ss_terminator);
- actual = actual->next->next;
- gcc_assert (actual);
- maskexpr = actual->expr;
- if (maskexpr)
+ if (op == NE_EXPR || norm2)
+ /* PARITY and NORM2. */
+ maskexpr = NULL;
+ else
+ {
+ actual = actual->next->next;
+ gcc_assert (actual);
+ maskexpr = actual->expr;
+ }
+
+ if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- tmp = build2 (op, type, resvar, arrayse.expr);
- gfc_add_modify_expr (&block, resvar, tmp);
+ if (norm2)
+ {
+ /* if (x(i) != 0.0)
+ {
+ absX = abs(x(i))
+ if (absX > scale)
+ {
+ val = scale/absX;
+ result = 1.0 + result * val * val;
+ scale = absX;
+ }
+ else
+ {
+ val = absX/scale;
+ result += val * val;
+ }
+ } */
+ tree res1, res2, cond, absX, val;
+ stmtblock_t ifblock1, ifblock2, ifblock3;
+
+ gfc_init_block (&ifblock1);
+
+ absX = gfc_create_var (type, "absX");
+ gfc_add_modify (&ifblock1, absX,
+ fold_build1_loc (input_location, ABS_EXPR, type,
+ arrayse.expr));
+ val = gfc_create_var (type, "val");
+ gfc_add_expr_to_block (&ifblock1, val);
+
+ gfc_init_block (&ifblock2);
+ gfc_add_modify (&ifblock2, val,
+ fold_build2_loc (input_location, RDIV_EXPR, type, scale,
+ absX));
+ res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
+ res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
+ res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
+ gfc_build_const (type, integer_one_node));
+ gfc_add_modify (&ifblock2, resvar, res1);
+ gfc_add_modify (&ifblock2, scale, absX);
+ res1 = gfc_finish_block (&ifblock2);
+
+ gfc_init_block (&ifblock3);
+ gfc_add_modify (&ifblock3, val,
+ fold_build2_loc (input_location, RDIV_EXPR, type, absX,
+ scale));
+ res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
+ res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
+ gfc_add_modify (&ifblock3, resvar, res2);
+ res2 = gfc_finish_block (&ifblock3);
+
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ absX, scale);
+ tmp = build3_v (COND_EXPR, cond, res1, res2);
+ gfc_add_expr_to_block (&ifblock1, tmp);
+ tmp = gfc_finish_block (&ifblock1);
+
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ arrayse.expr,
+ gfc_build_const (type, integer_zero_node));
+
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
+ gfc_add_modify (&block, resvar, tmp);
+ }
+
gfc_add_block_to_block (&block, &arrayse.post);
if (maskss)
{
/* We enclose the above in if (mask) {...} . */
- tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = gfc_finish_block (&block);
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
}
else
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&body, tmp);
gfc_trans_scalarizing_loops (&loop, &body);
+
+ /* For a scalar mask, enclose the loop in an if statement. */
+ if (maskexpr && maskss == NULL)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_init_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ tmp = gfc_finish_block (&block);
+
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&se->pre, &block);
+ }
+ else
+ {
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ }
+
+ gfc_cleanup_loop (&loop);
+
+ if (norm2)
+ {
+ /* result = scale * sqrt(result). */
+ tree sqrt;
+ sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
+ resvar = build_call_expr_loc (input_location,
+ sqrt, 1, resvar);
+ resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
+ }
+
+ se->expr = resvar;
+}
+
+
+/* Inline implementation of the dot_product intrinsic. This function
+ is based on gfc_conv_intrinsic_arith (the previous function). */
+static void
+gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
+{
+ tree resvar;
+ tree type;
+ stmtblock_t body;
+ stmtblock_t block;
+ tree tmp;
+ gfc_loopinfo loop;
+ gfc_actual_arglist *actual;
+ gfc_ss *arrayss1, *arrayss2;
+ gfc_se arrayse1, arrayse2;
+ gfc_expr *arrayexpr1, *arrayexpr2;
+
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ /* Initialize the result. */
+ resvar = gfc_create_var (type, "val");
+ if (expr->ts.type == BT_LOGICAL)
+ tmp = build_int_cst (type, 0);
+ else
+ tmp = gfc_build_const (type, integer_zero_node);
+
+ gfc_add_modify (&se->pre, resvar, tmp);
+
+ /* Walk argument #1. */
+ actual = expr->value.function.actual;
+ arrayexpr1 = actual->expr;
+ arrayss1 = gfc_walk_expr (arrayexpr1);
+ gcc_assert (arrayss1 != gfc_ss_terminator);
+
+ /* Walk argument #2. */
+ actual = actual->next;
+ arrayexpr2 = actual->expr;
+ arrayss2 = gfc_walk_expr (arrayexpr2);
+ gcc_assert (arrayss2 != gfc_ss_terminator);
+
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, arrayss1);
+ gfc_add_ss_to_loop (&loop, arrayss2);
+
+ /* Initialize the loop. */
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ gfc_mark_ss_chain_used (arrayss1, 1);
+ gfc_mark_ss_chain_used (arrayss2, 1);
+
+ /* Generate the loop body. */
+ gfc_start_scalarized_body (&loop, &body);
+ gfc_init_block (&block);
+
+ /* Make the tree expression for [conjg(]array1[)]. */
+ gfc_init_se (&arrayse1, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse1, &loop);
+ arrayse1.ss = arrayss1;
+ gfc_conv_expr_val (&arrayse1, arrayexpr1);
+ if (expr->ts.type == BT_COMPLEX)
+ arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
+ arrayse1.expr);
+ gfc_add_block_to_block (&block, &arrayse1.pre);
+
+ /* Make the tree expression for array2. */
+ gfc_init_se (&arrayse2, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse2, &loop);
+ arrayse2.ss = arrayss2;
+ gfc_conv_expr_val (&arrayse2, arrayexpr2);
+ gfc_add_block_to_block (&block, &arrayse2.pre);
+
+ /* Do the actual product and sum. */
+ if (expr->ts.type == BT_LOGICAL)
+ {
+ tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
+ arrayse1.expr, arrayse2.expr);
+ tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
+ }
+ else
+ {
+ tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
+ arrayse2.expr);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
+ }
+ gfc_add_modify (&block, resvar, tmp);
+
+ /* Finish up the loop block and the loop. */
+ tmp = gfc_finish_block (&block);
+ gfc_add_expr_to_block (&body, tmp);
+
+ gfc_trans_scalarizing_loops (&loop, &body);
gfc_add_block_to_block (&se->pre, &loop.pre);
gfc_add_block_to_block (&se->pre, &loop.post);
gfc_cleanup_loop (&loop);
se->expr = resvar;
}
+
+/* Emit code for minloc or maxloc intrinsic. There are many different cases
+ we need to handle. For performance reasons we sometimes create two
+ loops instead of one, where the second one is much simpler.
+ Examples for minloc intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) {
+ if (pos == 0) pos = S + (1 - from);
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not:
+ limit = Infinity;
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ if (from <= to) pos = 1;
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 4) NaNs aren't supported, array mask is used:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = 0;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
+ S++;
+ }
+ goto lab2;
+ lab1:;
+ while (S <= to) {
+ if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ lab2:;
+ 5) Same without array mask:
+ limit = infinities_supported ? Infinity : huge (limit);
+ pos = (from <= to) ? 1 : 0;
+ S = from;
+ while (S <= to) {
+ if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
+ S++;
+ }
+ For 3) and 5), if mask is scalar, this all goes into a conditional,
+ setting pos = 0; in the else branch. */
+
static void
-gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
stmtblock_t body;
stmtblock_t block;
stmtblock_t ifblock;
+ stmtblock_t elseblock;
tree limit;
tree type;
tree tmp;
- tree ifbody;
tree cond;
+ tree elsetmp;
+ tree ifbody;
+ tree offset;
+ tree nonempty;
+ tree lab1, lab2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
/* Initialize the result. */
pos = gfc_create_var (gfc_array_index_type, "pos");
+ offset = gfc_create_var (gfc_array_index_type, "offset");
type = gfc_typenode_for_spec (&expr->ts);
/* Walk the arguments. */
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
- if (maskexpr)
+ nonempty = NULL;
+ if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
- n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+ tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
break;
case BT_INTEGER:
+ n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
arrayexpr->ts.kind);
break;
gcc_unreachable ();
}
- /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
+ /* We start with the most negative possible value for MAXLOC, and the most
+ positive possible value for MINLOC. The most negative possible value is
+ -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+ possible value is HUGE in both cases. */
if (op == GT_EXPR)
- tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
- gfc_add_modify_expr (&se->pre, limit, tmp);
+ tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
+
+ gfc_add_modify (&se->pre, limit, tmp);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
gcc_assert (loop.dimen == 1);
+ if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
+ nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ loop.from[0], loop.to[0]);
+
+ lab1 = NULL;
+ lab2 = NULL;
+ /* Initialize the position to zero, following Fortran 2003. We are free
+ to do this because Fortran 95 allows the result of an entirely false
+ mask to be processor dependent. If we know at compile time the array
+ is non-empty and no MASK is used, we can initialize to 1 to simplify
+ the inner loop. */
+ if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
+ gfc_add_modify (&loop.pre, pos,
+ fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type,
+ nonempty, gfc_index_one_node,
+ gfc_index_zero_node));
+ else
+ {
+ gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ lab1 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab1) = 1;
+ lab2 = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab2) = 1;
+ }
- /* Initialize the position to the first element. If the array has zero
- size we need to return zero. Otherwise use the first element of the
- array, in case all elements are equal to the limit.
- i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
- loop.from[0], gfc_index_one_node));
- cond = fold (build2 (GE_EXPR, boolean_type_node,
- loop.to[0], loop.from[0]));
- tmp = fold (build3 (COND_EXPR, gfc_array_index_type, cond,
- loop.from[0], tmp));
- gfc_add_modify_expr (&loop.pre, pos, tmp);
-
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
gfc_start_block (&ifblock);
/* Assign the value to the limit... */
- gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+ /* Remember where we are. An offset must be added to the loop
+ counter to obtain the required position. */
+ if (loop.from[0])
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ else
+ tmp = gfc_index_one_node;
- /* Remember where we are. */
- gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
+ gfc_add_modify (&block, offset, tmp);
+
+ if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
+ {
+ stmtblock_t ifblock2;
+ tree ifbody2;
+
+ gfc_start_block (&ifblock2);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock2, pos, tmp);
+ ifbody2 = gfc_finish_block (&ifblock2);
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
+ gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, cond, ifbody2,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ if (lab1)
+ gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value. */
- tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
+ if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (lab1)
+ cond = fold_build2_loc (input_location,
+ op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ else
+ cond = fold_build2_loc (input_location, op, boolean_type_node,
+ arrayse.expr, limit);
+
+ ifbody = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+ }
+ gfc_add_expr_to_block (&block, ifbody);
if (maskss)
{
/* We enclose the above in if (mask) {...}. */
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
}
else
tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&body, tmp);
+ if (lab1)
+ {
+ gfc_trans_scalarized_loop_end (&loop, 0, &body);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (nonempty != NULL)
+ {
+ ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
+ tmp = build3_v (COND_EXPR, nonempty, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&loop.code[0], tmp);
+ }
+ }
+
+ gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
+ gfc_start_block (&body);
+
+ /* If we have a mask, only check this element if the mask is set. */
+ if (maskss)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_copy_loopinfo_to_se (&maskse, &loop);
+ maskse.ss = maskss;
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_add_block_to_block (&body, &maskse.pre);
+
+ gfc_start_block (&block);
+ }
+ else
+ gfc_init_block (&block);
+
+ /* Compare with the current limit. */
+ gfc_init_se (&arrayse, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse, &loop);
+ arrayse.ss = arrayss;
+ gfc_conv_expr_val (&arrayse, arrayexpr);
+ gfc_add_block_to_block (&block, &arrayse.pre);
+
+ /* We do the following if this is a more extreme value. */
+ gfc_start_block (&ifblock);
+
+ /* Assign the value to the limit... */
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+
+ /* Remember where we are. An offset must be added to the loop
+ counter to obtain the required position. */
+ if (loop.from[0])
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, loop.from[0]);
+ else
+ tmp = gfc_index_one_node;
+
+ gfc_add_modify (&block, offset, tmp);
+
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ ifbody = gfc_finish_block (&ifblock);
+
+ cond = fold_build2_loc (input_location, op, boolean_type_node,
+ arrayse.expr, limit);
+
+ tmp = build3_v (COND_EXPR, cond, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (maskss)
+ {
+ /* We enclose the above in if (mask) {...}. */
+ tmp = gfc_finish_block (&block);
+
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ }
+ else
+ tmp = gfc_finish_block (&block);
+ gfc_add_expr_to_block (&body, tmp);
+ /* Avoid initializing loopvar[0] again, it should be left where
+ it finished by the first loop. */
+ loop.from[0] = loop.loopvar[0];
+ }
+
gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ if (lab2)
+ gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
+
+ /* For a scalar mask, enclose the loop in an if statement. */
+ if (maskexpr && maskss == NULL)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_init_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ tmp = gfc_finish_block (&block);
+
+ /* For the else part of the scalar mask, just initialize
+ the pos variable the same way as above. */
+
+ gfc_init_block (&elseblock);
+ gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
+ elsetmp = gfc_finish_block (&elseblock);
+
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&se->pre, &block);
+ }
+ else
+ {
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ }
gfc_cleanup_loop (&loop);
- /* Return a value in the range 1..SIZE(array). */
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
- gfc_index_one_node));
- tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp));
- /* And convert to the required type. */
- se->expr = convert (type, tmp);
+ se->expr = convert (type, pos);
}
+/* Emit code for minval or maxval intrinsic. There are many different cases
+ we need to handle. For performance reasons we sometimes create two
+ loops instead of one, where the second one is much simpler.
+ Examples for minval intrinsic:
+ 1) Result is an array, a call is generated
+ 2) Array mask is used and NaNs need to be supported, rank 1:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
+ S++;
+ }
+ limit = nonempty ? NaN : huge (limit);
+ lab:
+ while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
+ 3) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank 1:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { if (a[S] <= limit) goto lab; S++; }
+ limit = (from <= to) ? NaN : huge (limit);
+ lab:
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ 4) Array mask is used and NaNs need to be supported, rank > 1:
+ limit = Infinity;
+ nonempty = false;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (mask[S1][S2]) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ nonempty = true;
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = nonempty ? NaN : huge (limit);
+ 5) NaNs need to be supported, but it is known at compile time or cheaply
+ at runtime whether array is nonempty or not, rank > 1:
+ limit = Infinity;
+ fast = false;
+ S1 = from1;
+ while (S1 <= to1) {
+ S2 = from2;
+ while (S2 <= to2) {
+ if (fast) limit = min (a[S1][S2], limit);
+ else {
+ if (a[S1][S2] <= limit) {
+ limit = a[S1][S2];
+ fast = true;
+ }
+ }
+ S2++;
+ }
+ S1++;
+ }
+ if (!fast)
+ limit = (nonempty_array) ? NaN : huge (limit);
+ 6) NaNs aren't supported, but infinities are. Array mask is used:
+ limit = Infinity;
+ nonempty = false;
+ S = from;
+ while (S <= to) {
+ if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
+ S++;
+ }
+ limit = nonempty ? limit : huge (limit);
+ 7) Same without array mask:
+ limit = Infinity;
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++; }
+ limit = (from <= to) ? limit : huge (limit);
+ 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
+ limit = huge (limit);
+ S = from;
+ while (S <= to) { limit = min (a[S], limit); S++); }
+ (or
+ while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
+ with array mask instead).
+ For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
+ setting limit = huge (limit); in the else branch. */
+
static void
-gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree limit;
tree type;
tree tmp;
tree ifbody;
+ tree nonempty;
+ tree nonempty_var;
+ tree lab;
+ tree fast;
+ tree huge_cst = NULL, nan_cst = NULL;
stmtblock_t body;
- stmtblock_t block;
+ stmtblock_t block, block2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
switch (expr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
- break;
-
+ huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ expr->ts.kind, 0);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (type, real);
+ }
+ else
+ tmp = huge_cst;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_nan (&real, "", 1, DECL_MODE (limit));
+ nan_cst = build_real (type, real);
+ }
+ break;
+
case BT_INTEGER:
tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
break;
gcc_unreachable ();
}
- /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
+ /* We start with the most negative possible value for MAXVAL, and the most
+ positive possible value for MINVAL. The most negative possible value is
+ -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
+ possible value is HUGE in both cases. */
if (op == GT_EXPR)
- tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
- gfc_add_modify_expr (&se->pre, limit, tmp);
+ {
+ tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ if (huge_cst)
+ huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
+ TREE_TYPE (huge_cst), huge_cst);
+ }
+
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
+ tmp, build_int_cst (type, 1));
+
+ gfc_add_modify (&se->pre, limit, tmp);
/* Walk the arguments. */
actual = expr->value.function.actual;
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
- if (maskexpr)
+ nonempty = NULL;
+ if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
}
else
- maskss = NULL;
+ {
+ mpz_t asize;
+ if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
+ {
+ nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
+ mpz_clear (asize);
+ nonempty = fold_build2_loc (input_location, GT_EXPR,
+ boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
/* Initialize the loop. */
gfc_conv_ss_startstride (&loop);
- gfc_conv_loop_setup (&loop);
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ if (nonempty == NULL && maskss == NULL
+ && loop.dimen == 1 && loop.from[0] && loop.to[0])
+ nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ loop.from[0], loop.to[0]);
+ nonempty_var = NULL;
+ if (nonempty == NULL
+ && (HONOR_INFINITIES (DECL_MODE (limit))
+ || HONOR_NANS (DECL_MODE (limit))))
+ {
+ nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
+ gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
+ nonempty = nonempty_var;
+ }
+ lab = NULL;
+ fast = NULL;
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ if (loop.dimen == 1)
+ {
+ lab = gfc_build_label_decl (NULL_TREE);
+ TREE_USED (lab) = 1;
+ }
+ else
+ {
+ fast = gfc_create_var (boolean_type_node, "fast");
+ gfc_add_modify (&se->pre, fast, boolean_false_node);
+ }
+ }
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- /* Assign the value to the limit... */
- ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ gfc_init_block (&block2);
+
+ if (nonempty_var)
+ gfc_add_modify (&block2, nonempty_var, boolean_true_node);
+
+ if (HONOR_NANS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ if (lab)
+ ifbody = build1_v (GOTO_EXPR, lab);
+ else
+ {
+ stmtblock_t ifblock;
+
+ gfc_init_block (&ifblock);
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+ gfc_add_modify (&ifblock, fast, boolean_true_node);
+ ifbody = gfc_finish_block (&ifblock);
+ }
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2_loc (input_location, op, boolean_type_node,
+ arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block2, tmp);
+ }
+ else
+ {
+ tmp = fold_build2_loc (input_location,
+ op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block2, limit, tmp);
+ }
+ }
+
+ if (fast)
+ {
+ tree elsebody = gfc_finish_block (&block2);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2_loc (input_location, op, boolean_type_node,
+ arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ ifbody = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ }
+ else
+ {
+ tmp = fold_build2_loc (input_location,
+ op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ }
+ tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ gfc_add_block_to_block (&block, &block2);
- /* If it is a more extreme value. */
- tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
- tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
- gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
tmp = gfc_finish_block (&block);
if (maskss)
/* We enclose the above in if (mask) {...}. */
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
+ if (lab)
+ {
+ gfc_trans_scalarized_loop_end (&loop, 0, &body);
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+ nan_cst, huge_cst);
+ gfc_add_modify (&loop.code[0], limit, tmp);
+ gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
+
+ gfc_start_block (&body);
+
+ /* If we have a mask, only add this element if the mask is set. */
+ if (maskss)
+ {
+ gfc_init_se (&maskse, NULL);
+ gfc_copy_loopinfo_to_se (&maskse, &loop);
+ maskse.ss = maskss;
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_add_block_to_block (&body, &maskse.pre);
+
+ gfc_start_block (&block);
+ }
+ else
+ gfc_init_block (&block);
+
+ /* Compare with the current limit. */
+ gfc_init_se (&arrayse, NULL);
+ gfc_copy_loopinfo_to_se (&arrayse, &loop);
+ arrayse.ss = arrayss;
+ gfc_conv_expr_val (&arrayse, arrayexpr);
+ gfc_add_block_to_block (&block, &arrayse.pre);
+
+ /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
+ signed zeros. */
+ if (HONOR_NANS (DECL_MODE (limit))
+ || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
+ {
+ tmp = fold_build2_loc (input_location, op, boolean_type_node,
+ arrayse.expr, limit);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
+ tmp = build3_v (COND_EXPR, tmp, ifbody,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ }
+ else
+ {
+ tmp = fold_build2_loc (input_location,
+ op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
+ type, arrayse.expr, limit);
+ gfc_add_modify (&block, limit, tmp);
+ }
+
+ gfc_add_block_to_block (&block, &arrayse.post);
+
+ tmp = gfc_finish_block (&block);
+ if (maskss)
+ /* We enclose the above in if (mask) {...}. */
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+ /* Avoid initializing loopvar[0] again, it should be left where
+ it finished by the first loop. */
+ loop.from[0] = loop.loopvar[0];
+ }
gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ if (fast)
+ {
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
+ nan_cst, huge_cst);
+ ifbody = build2_v (MODIFY_EXPR, limit, tmp);
+ tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
+ ifbody);
+ gfc_add_expr_to_block (&loop.pre, tmp);
+ }
+ else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
+ {
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
+ huge_cst);
+ gfc_add_modify (&loop.pre, limit, tmp);
+ }
+
+ /* For a scalar mask, enclose the loop in an if statement. */
+ if (maskexpr && maskss == NULL)
+ {
+ tree else_stmt;
+
+ gfc_init_se (&maskse, NULL);
+ gfc_conv_expr_val (&maskse, maskexpr);
+ gfc_init_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
+ tmp = gfc_finish_block (&block);
+
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
+ else
+ else_stmt = build_empty_stmt (input_location);
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&se->pre, &block);
+ }
+ else
+ {
+ gfc_add_block_to_block (&se->pre, &loop.pre);
+ gfc_add_block_to_block (&se->pre, &loop.post);
+ }
+
gfc_cleanup_loop (&loop);
se->expr = limit;
static void
gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
tree tmp;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- tmp = build2 (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
- tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
- tmp = fold (build2 (NE_EXPR, boolean_type_node, tmp,
- convert (type, integer_zero_node)));
+ tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ build_int_cst (type, 1), args[1]);
+ tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (type, 0));
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, tmp);
}
-/* Generate code to perform the specified operation. */
+
+/* Generate code for BGE, BGT, BLE and BLT intrinsics. */
static void
-gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
- tree arg;
- tree arg2;
- tree type;
+ tree args[2];
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
- se->expr = fold (build2 (op, type, arg, arg2));
+ /* Convert both arguments to the unsigned type of the same size. */
+ args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
+ args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
+
+ /* If they have unequal type size, convert to the larger one. */
+ if (TYPE_PRECISION (TREE_TYPE (args[0]))
+ > TYPE_PRECISION (TREE_TYPE (args[1])))
+ args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
+ else if (TYPE_PRECISION (TREE_TYPE (args[1]))
+ > TYPE_PRECISION (TREE_TYPE (args[0])))
+ args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
+
+ /* Now, we compare them. */
+ se->expr = fold_build2_loc (input_location, op, boolean_type_node,
+ args[0], args[1]);
+}
+
+
+/* Generate code to perform the specified operation. */
+static void
+gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
+{
+ tree args[2];
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
+ args[0], args[1]);
}
/* Bitwise not. */
{
tree arg;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
-
- se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
+ TREE_TYPE (arg), arg);
}
/* Set or clear a single bit. */
static void
gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
tree tmp;
- int op;
+ enum tree_code op;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ type = TREE_TYPE (args[0]);
- tmp = fold (build2 (LSHIFT_EXPR, type,
- convert (type, integer_one_node), arg2));
+ tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
+ build_int_cst (type, 1), args[1]);
if (set)
op = BIT_IOR_EXPR;
else
{
op = BIT_AND_EXPR;
- tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
+ tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
}
- se->expr = fold (build2 (op, type, arg, tmp));
+ se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
}
/* Extract a sequence of bits.
static void
gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
- tree arg3;
+ tree args[3];
tree type;
tree tmp;
tree mask;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_CHAIN (arg);
- arg3 = TREE_VALUE (TREE_CHAIN (arg2));
- arg = TREE_VALUE (arg);
- arg2 = TREE_VALUE (arg2);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+ type = TREE_TYPE (args[0]);
+
+ mask = build_int_cst (type, -1);
+ mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
+ mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
+
+ tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
+
+ se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
+}
+
+static void
+gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
+ bool arithmetic)
+{
+ tree args[2], type, num_bits, cond;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
- mask = build_int_cst (NULL_TREE, -1);
- mask = build2 (LSHIFT_EXPR, type, mask, arg3);
- mask = build1 (BIT_NOT_EXPR, type, mask);
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
+ type = TREE_TYPE (args[0]);
+
+ if (!arithmetic)
+ args[0] = fold_convert (unsigned_type_for (type), args[0]);
+ else
+ gcc_assert (right_shift);
- tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
+ se->expr = fold_build2_loc (input_location,
+ right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+ TREE_TYPE (args[0]), args[0], args[1]);
- se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
+ if (!arithmetic)
+ se->expr = fold_convert (type, se->expr);
+
+ /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+ gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+ special case. */
+ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
+ args[1], num_bits);
+
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), se->expr);
}
-/* ISHFT (I, SHIFT) = (shift >= 0) ? i << shift : i >> -shift. */
+/* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
+ ? 0
+ : ((shift >= 0) ? i << shift : i >> -shift)
+ where all shifts are logical shifts. */
static void
gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
+ tree args[2];
tree type;
+ tree utype;
tree tmp;
+ tree width;
+ tree num_bits;
+ tree cond;
tree lshift;
tree rshift;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
- /* Left shift if positive. */
- lshift = build2 (LSHIFT_EXPR, type, arg, arg2);
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
- /* Right shift if negative. This will perform an arithmetic shift as
- we are dealing with signed integers. Section 13.5.7 allows this. */
- tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
- rshift = build2 (RSHIFT_EXPR, type, arg, tmp);
+ type = TREE_TYPE (args[0]);
+ utype = unsigned_type_for (type);
- tmp = build2 (GT_EXPR, boolean_type_node, arg2,
- convert (TREE_TYPE (arg2), integer_zero_node));
- rshift = build3 (COND_EXPR, type, tmp, lshift, rshift);
+ width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
+ args[1]);
- /* Do nothing if shift == 0. */
- tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
- convert (TREE_TYPE (arg2), integer_zero_node));
- se->expr = build3 (COND_EXPR, type, tmp, arg, rshift);
+ /* Left shift if positive. */
+ lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
+
+ /* Right shift if negative.
+ We convert to an unsigned type because we want a logical shift.
+ The standard doesn't define the case of shifting negative
+ numbers, and we try to be compatible with other compilers, most
+ notably g77, here. */
+ rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
+ utype, convert (utype, args[0]), width));
+
+ tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
+ build_int_cst (TREE_TYPE (args[1]), 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
+
+ /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
+ gcc requires a shift width < BIT_SIZE(I), so we have to catch this
+ special case. */
+ num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
+ num_bits);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+ build_int_cst (type, 0), tmp);
}
+
/* Circular shift. AKA rotate or barrel shift. */
+
static void
gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- tree arg2;
- tree arg3;
+ tree *args;
tree type;
tree tmp;
tree lrot;
tree rrot;
+ tree zero;
+ unsigned int num_args;
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_CHAIN (arg);
- arg3 = TREE_CHAIN (arg2);
- if (arg3)
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+
+ if (num_args == 3)
{
/* Use a library function for the 3 parameter version. */
- type = TREE_TYPE (TREE_VALUE (arg));
- /* Convert all args to the same type otherwise we need loads of library
- functions. SIZE and SHIFT cannot have values > BIT_SIZE (I) so the
- conversion is safe. */
- tmp = convert (type, TREE_VALUE (arg2));
- TREE_VALUE (arg2) = tmp;
- tmp = convert (type, TREE_VALUE (arg3));
- TREE_VALUE (arg3) = tmp;
+ tree int4type = gfc_get_int_type (4);
+
+ type = TREE_TYPE (args[0]);
+ /* We convert the first argument to at least 4 bytes, and
+ convert back afterwards. This removes the need for library
+ functions for all argument sizes, and function will be
+ aligned to at least 32 bits, so there's no loss. */
+ if (expr->ts.kind < 4)
+ args[0] = convert (int4type, args[0]);
+
+ /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
+ need loads of library functions. They cannot have values >
+ BIT_SIZE (I) so the conversion is safe. */
+ args[1] = convert (int4type, args[1]);
+ args[2] = convert (int4type, args[2]);
switch (expr->ts.kind)
{
+ case 1:
+ case 2:
case 4:
tmp = gfor_fndecl_math_ishftc4;
break;
case 8:
tmp = gfor_fndecl_math_ishftc8;
break;
+ case 16:
+ tmp = gfor_fndecl_math_ishftc16;
+ break;
default:
gcc_unreachable ();
}
- se->expr = gfc_build_function_call (tmp, arg);
+ se->expr = build_call_expr_loc (input_location,
+ tmp, 3, args[0], args[1], args[2]);
+ /* Convert the result back to the original type, if we extended
+ the first argument's width above. */
+ if (expr->ts.kind < 4)
+ se->expr = convert (type, se->expr);
+
return;
}
- arg = TREE_VALUE (arg);
- arg2 = TREE_VALUE (arg2);
- type = TREE_TYPE (arg);
+ type = TREE_TYPE (args[0]);
+
+ /* Evaluate arguments only once. */
+ args[0] = gfc_evaluate_now (args[0], &se->pre);
+ args[1] = gfc_evaluate_now (args[1], &se->pre);
/* Rotate left if positive. */
- lrot = build2 (LROTATE_EXPR, type, arg, arg2);
+ lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
/* Rotate right if negative. */
- tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
- rrot = build2 (RROTATE_EXPR, type, arg, tmp);
+ tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
+ args[1]);
+ rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
- tmp = build2 (GT_EXPR, boolean_type_node, arg2,
- convert (TREE_TYPE (arg2), integer_zero_node));
- rrot = build3 (COND_EXPR, type, tmp, lrot, rrot);
+ zero = build_int_cst (TREE_TYPE (args[1]), 0);
+ tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
+ zero);
+ rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
/* Do nothing if shift == 0. */
- tmp = build2 (EQ_EXPR, boolean_type_node, arg2,
- convert (TREE_TYPE (arg2), integer_zero_node));
- se->expr = build3 (COND_EXPR, type, tmp, arg, rrot);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
+ zero);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
+ rrot);
+}
+
+
+/* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
+ : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
+
+ The conditional expression is necessary because the result of LEADZ(0)
+ is defined, but the result of __builtin_clz(0) is undefined for most
+ targets.
+
+ For INTEGER kinds smaller than the C 'int' type, we have to subtract the
+ difference in bit size between the argument of LEADZ and the C int. */
+
+static void
+gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree leadz;
+ tree bit_size;
+ tree tmp;
+ tree func;
+ int s, argsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+ /* Which variant of __builtin_clz* should we call? */
+ if (argsize <= INT_TYPE_SIZE)
+ {
+ arg_type = unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CLZ);
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CLZL);
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CLZLL);
+ }
+ else
+ {
+ gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+ arg_type = gfc_build_uint_type (argsize);
+ func = NULL_TREE;
+ }
+
+ /* Convert the actual argument twice: first, to the unsigned type of the
+ same size; then, to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ arg = fold_convert (gfc_build_uint_type (argsize), arg);
+ arg = fold_convert (arg_type, arg);
+ arg = gfc_evaluate_now (arg, &se->pre);
+ result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+ /* Compute LEADZ for the case i .ne. 0. */
+ if (func)
+ {
+ s = TYPE_PRECISION (arg_type) - argsize;
+ tmp = fold_convert (result_type,
+ build_call_expr_loc (input_location, func,
+ 1, arg));
+ leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
+ tmp, build_int_cst (result_type, s));
+ }
+ else
+ {
+ /* We end up here if the argument type is larger than 'long long'.
+ We generate this code:
+
+ if (x & (ULL_MAX << ULL_SIZE) != 0)
+ return clzll ((unsigned long long) (x >> ULLSIZE));
+ else
+ return ULL_SIZE + clzll ((unsigned long long) x);
+ where ULL_MAX is the largest value that a ULL_MAX can hold
+ (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+ is the bit-size of the long long type (64 in this example). */
+ tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+ ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+ ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+ long_long_unsigned_type_node,
+ build_int_cst (long_long_unsigned_type_node,
+ 0));
+
+ cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
+ fold_convert (arg_type, ullmax), ullsize);
+ cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
+ arg, cond);
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ cond, build_int_cst (arg_type, 0));
+
+ tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+ arg, ullsize);
+ tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+ btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+ tmp1 = fold_convert (result_type,
+ build_call_expr_loc (input_location, btmp, 1, tmp1));
+
+ tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+ btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
+ tmp2 = fold_convert (result_type,
+ build_call_expr_loc (input_location, btmp, 1, tmp2));
+ tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+ tmp2, ullsize);
+
+ leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
+ cond, tmp1, tmp2);
+ }
+
+ /* Build BIT_SIZE. */
+ bit_size = build_int_cst (result_type, argsize);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg, build_int_cst (arg_type, 0));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+ bit_size, leadz);
}
+
+/* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
+
+ The conditional expression is necessary because the result of TRAILZ(0)
+ is defined, but the result of __builtin_ctz(0) is undefined for most
+ targets. */
+
+static void
+gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
+{
+ tree arg;
+ tree arg_type;
+ tree cond;
+ tree result_type;
+ tree trailz;
+ tree bit_size;
+ tree func;
+ int argsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
+
+ /* Which variant of __builtin_ctz* should we call? */
+ if (argsize <= INT_TYPE_SIZE)
+ {
+ arg_type = unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CTZ);
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CTZL);
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = builtin_decl_explicit (BUILT_IN_CTZLL);
+ }
+ else
+ {
+ gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+ arg_type = gfc_build_uint_type (argsize);
+ func = NULL_TREE;
+ }
+
+ /* Convert the actual argument twice: first, to the unsigned type of the
+ same size; then, to the proper argument type for the built-in
+ function. But the return type is of the default INTEGER kind. */
+ arg = fold_convert (gfc_build_uint_type (argsize), arg);
+ arg = fold_convert (arg_type, arg);
+ arg = gfc_evaluate_now (arg, &se->pre);
+ result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+ /* Compute TRAILZ for the case i .ne. 0. */
+ if (func)
+ trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+ func, 1, arg));
+ else
+ {
+ /* We end up here if the argument type is larger than 'long long'.
+ We generate this code:
+
+ if ((x & ULL_MAX) == 0)
+ return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
+ else
+ return ctzll ((unsigned long long) x);
+
+ where ULL_MAX is the largest value that a ULL_MAX can hold
+ (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
+ is the bit-size of the long long type (64 in this example). */
+ tree ullsize, ullmax, tmp1, tmp2, btmp;
+
+ ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
+ ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
+ long_long_unsigned_type_node,
+ build_int_cst (long_long_unsigned_type_node, 0));
+
+ cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
+ fold_convert (arg_type, ullmax));
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
+ build_int_cst (arg_type, 0));
+
+ tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
+ arg, ullsize);
+ tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
+ btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+ tmp1 = fold_convert (result_type,
+ build_call_expr_loc (input_location, btmp, 1, tmp1));
+ tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+ tmp1, ullsize);
+
+ tmp2 = fold_convert (long_long_unsigned_type_node, arg);
+ btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
+ tmp2 = fold_convert (result_type,
+ build_call_expr_loc (input_location, btmp, 1, tmp2));
+
+ trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
+ cond, tmp1, tmp2);
+ }
+
+ /* Build BIT_SIZE. */
+ bit_size = build_int_cst (result_type, argsize);
+
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg, build_int_cst (arg_type, 0));
+ se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
+ bit_size, trailz);
+}
+
+/* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
+ for types larger than "long long", we call the long long built-in for
+ the lower and higher bits and combine the result. */
+
+static void
+gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
+{
+ tree arg;
+ tree arg_type;
+ tree result_type;
+ tree func;
+ int argsize;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
+ result_type = gfc_get_int_type (gfc_default_integer_kind);
+
+ /* Which variant of the builtin should we call? */
+ if (argsize <= INT_TYPE_SIZE)
+ {
+ arg_type = unsigned_type_node;
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITY
+ : BUILT_IN_POPCOUNT);
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYL
+ : BUILT_IN_POPCOUNTL);
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYLL
+ : BUILT_IN_POPCOUNTLL);
+ }
+ else
+ {
+ /* Our argument type is larger than 'long long', which mean none
+ of the POPCOUNT builtins covers it. We thus call the 'long long'
+ variant multiple times, and add the results. */
+ tree utype, arg2, call1, call2;
+
+ /* For now, we only cover the case where argsize is twice as large
+ as 'long long'. */
+ gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
+
+ func = builtin_decl_explicit (parity
+ ? BUILT_IN_PARITYLL
+ : BUILT_IN_POPCOUNTLL);
+
+ /* Convert it to an integer, and store into a variable. */
+ utype = gfc_build_uint_type (argsize);
+ arg = fold_convert (utype, arg);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ /* Call the builtin twice. */
+ call1 = build_call_expr_loc (input_location, func, 1,
+ fold_convert (long_long_unsigned_type_node,
+ arg));
+
+ arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
+ build_int_cst (utype, LONG_LONG_TYPE_SIZE));
+ call2 = build_call_expr_loc (input_location, func, 1,
+ fold_convert (long_long_unsigned_type_node,
+ arg2));
+
+ /* Combine the results. */
+ if (parity)
+ se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
+ call1, call2);
+ else
+ se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
+ call1, call2);
+
+ return;
+ }
+
+ /* Convert the actual argument twice: first, to the unsigned type of the
+ same size; then, to the proper argument type for the built-in
+ function. */
+ arg = fold_convert (gfc_build_uint_type (argsize), arg);
+ arg = fold_convert (arg_type, arg);
+
+ se->expr = fold_convert (result_type,
+ build_call_expr_loc (input_location, func, 1, arg));
+}
+
+
+/* Process an intrinsic with unspecified argument-types that has an optional
+ argument (which could be of type character), e.g. EOSHIFT. For those, we
+ need to append the string length of the optional argument if it is not
+ present and the type is really character.
+ primary specifies the position (starting at 1) of the non-optional argument
+ specifying the type and optional gives the position of the optional
+ argument in the arglist. */
+
+static void
+conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
+ unsigned primary, unsigned optional)
+{
+ gfc_actual_arglist* prim_arg;
+ gfc_actual_arglist* opt_arg;
+ unsigned cur_pos;
+ gfc_actual_arglist* arg;
+ gfc_symbol* sym;
+ VEC(tree,gc) *append_args;
+
+ /* Find the two arguments given as position. */
+ cur_pos = 0;
+ prim_arg = NULL;
+ opt_arg = NULL;
+ for (arg = expr->value.function.actual; arg; arg = arg->next)
+ {
+ ++cur_pos;
+
+ if (cur_pos == primary)
+ prim_arg = arg;
+ if (cur_pos == optional)
+ opt_arg = arg;
+
+ if (cur_pos >= primary && cur_pos >= optional)
+ break;
+ }
+ gcc_assert (prim_arg);
+ gcc_assert (prim_arg->expr);
+ gcc_assert (opt_arg);
+
+ /* If we do have type CHARACTER and the optional argument is really absent,
+ append a dummy 0 as string length. */
+ append_args = NULL;
+ if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
+ {
+ tree dummy;
+
+ dummy = build_int_cst (gfc_charlen_type_node, 0);
+ append_args = VEC_alloc (tree, gc, 1);
+ VEC_quick_push (tree, append_args, dummy);
+ }
+
+ /* Build the call itself. */
+ sym = gfc_get_symbol_for_expr (expr);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
+ free (sym);
+}
+
+
/* The length of a character string. */
static void
gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
gfc_symbol *sym;
gfc_se argse;
gfc_expr *arg;
+ gfc_ss *ss;
gcc_assert (!se->ss);
switch (arg->expr_type)
{
case EXPR_CONSTANT:
- len = build_int_cst (NULL_TREE, arg->value.character.length);
+ len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
break;
- default:
- if (arg->expr_type == EXPR_VARIABLE
- && (arg->ref == NULL || (arg->ref->next == NULL
- && arg->ref->type == REF_ARRAY)))
- {
- /* This doesn't catch all cases.
- See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
- and the surrounding thread. */
- sym = arg->symtree->n.sym;
- decl = gfc_get_symbol_decl (sym);
- if (decl == current_function_decl && sym->attr.function
+ case EXPR_ARRAY:
+ /* Obtain the string length from the function used by
+ trans-array.c(gfc_trans_array_constructor). */
+ len = NULL_TREE;
+ get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
+ break;
+
+ case EXPR_VARIABLE:
+ if (arg->ref == NULL
+ || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
+ {
+ /* This doesn't catch all cases.
+ See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
+ and the surrounding thread. */
+ sym = arg->symtree->n.sym;
+ decl = gfc_get_symbol_decl (sym);
+ if (decl == current_function_decl && sym->attr.function
&& (sym->result == sym))
- decl = gfc_get_fake_result_decl (sym);
+ decl = gfc_get_fake_result_decl (sym, 0);
- len = sym->ts.cl->backend_decl;
- gcc_assert (len);
- }
- else
- {
- /* Anybody stupid enough to do this deserves inefficient code. */
- gfc_init_se (&argse, se);
- gfc_conv_expr (&argse, arg);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- len = argse.string_length;
+ len = sym->ts.u.cl->backend_decl;
+ gcc_assert (len);
+ break;
}
+
+ /* Otherwise fall through. */
+
+ default:
+ /* Anybody stupid enough to do this deserves inefficient code. */
+ ss = gfc_walk_expr (arg);
+ gfc_init_se (&argse, se);
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr (&argse, arg);
+ else
+ gfc_conv_expr_descriptor (&argse, arg, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ len = argse.string_length;
break;
}
se->expr = convert (type, len);
static void
gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
{
- tree args;
- tree type;
+ int kind = expr->value.function.actual->expr->ts.kind;
+ tree args[2], type, fndecl;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
+
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_len_trim;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_len_trim_char4;
+ else
+ gcc_unreachable ();
+
+ se->expr = build_call_expr_loc (input_location,
+ fndecl, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
/* Returns the starting position of a substring within a string. */
static void
-gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
+ tree function)
{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
+ tree logical4_type_node = gfc_get_logical_type (4);
tree type;
- tree tmp;
+ tree fndecl;
+ tree *args;
+ unsigned int num_args;
- args = gfc_conv_intrinsic_function_args (se, expr);
+ args = XALLOCAVEC (tree, 5);
+
+ /* Get number of arguments; characters count double due to the
+ string length argument. Kind= is not passed to the library
+ and thus ignored. */
+ if (expr->value.function.actual->next->next->expr == NULL)
+ num_args = 4;
+ else
+ num_args = 5;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
- {
- back = convert (gfc_logical4_type_node, integer_one_node);
- back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
- TREE_CHAIN (tmp) = back;
- }
+
+ if (num_args == 4)
+ args[4] = build_int_cst (logical4_type_node, 0);
else
- {
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
- }
+ args[4] = convert (logical4_type_node, args[4]);
- se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
+ fndecl = build_addr (function, current_function_decl);
+ se->expr = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
+ 5, args);
se->expr = convert (type, se->expr);
+
}
/* The ascii value for a single character. */
static void
gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
{
+ tree args[2], type, pchartype;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
+ pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
+ args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ args[1]);
+ se->expr = convert (type, se->expr);
+}
+
+
+/* Intrinsic ISNAN calls __builtin_isnan. */
+
+static void
+gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
+{
tree arg;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_ISNAN),
+ 1, arg);
+ STRIP_TYPE_NOPS (se->expr);
+ se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
+
+
+/* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
+ their argument against a constant integer value. */
+
+static void
+gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
+{
+ tree arg;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ se->expr = fold_build2_loc (input_location, EQ_EXPR,
+ gfc_typenode_for_spec (&expr->ts),
+ arg, build_int_cst (TREE_TYPE (arg), value));
+}
+
+
+
+/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
+
+static void
+gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
+{
+ tree tsource;
+ tree fsource;
+ tree mask;
tree type;
+ tree len, len2;
+ tree *args;
+ unsigned int num_args;
+
+ num_args = gfc_intrinsic_argument_list_length (expr);
+ args = XALLOCAVEC (tree, num_args);
+
+ gfc_conv_intrinsic_function_args (se, expr, args, num_args);
+ if (expr->ts.type != BT_CHARACTER)
+ {
+ tsource = args[0];
+ fsource = args[1];
+ mask = args[2];
+ }
+ else
+ {
+ /* We do the same as in the non-character case, but the argument
+ list is different because of the string length arguments. We
+ also have to set the string length for the result. */
+ len = args[0];
+ tsource = args[1];
+ len2 = args[2];
+ fsource = args[3];
+ mask = args[4];
+
+ gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
+ &se->pre);
+ se->string_length = len;
+ }
+ type = TREE_TYPE (tsource);
+ se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
+ fold_convert (type, fsource));
+}
+
+
+/* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
+
+static void
+gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
+{
+ tree args[3], mask, type;
+
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+ mask = gfc_evaluate_now (args[2], &se->pre);
+
+ type = TREE_TYPE (args[0]);
+ gcc_assert (TREE_TYPE (args[1]) == type);
+ gcc_assert (TREE_TYPE (mask) == type);
+
+ args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
+ args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
+ fold_build1_loc (input_location, BIT_NOT_EXPR,
+ type, mask));
+ se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
+ args[0], args[1]);
+}
+
+
+/* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
+ MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
+
+static void
+gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
+{
+ tree arg, allones, type, utype, res, cond, bitsize;
+ int i;
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ type = gfc_get_int_type (expr->ts.kind);
+ utype = unsigned_type_for (type);
+
+ i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+ bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
+
+ allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
+ build_int_cst (utype, 0));
+
+ if (left)
+ {
+ /* Left-justified mask. */
+ res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
+ bitsize, arg);
+ res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+ fold_convert (utype, res));
+
+ /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
+ smaller than type width. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+ build_int_cst (TREE_TYPE (arg), 0));
+ res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
+ build_int_cst (utype, 0), res);
+ }
+ else
+ {
+ /* Right-justified mask. */
+ res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
+ fold_convert (utype, arg));
+ res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
+
+ /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
+ strictly smaller than type width. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg, bitsize);
+ res = fold_build3_loc (input_location, COND_EXPR, utype,
+ cond, allones, res);
+ }
+
+ se->expr = fold_convert (type, res);
+}
+
+
+/* FRACTION (s) is translated into frexp (s, &dummy_int). */
+static void
+gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, tmp, frexp;
+
+ frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ tmp = gfc_create_var (integer_type_node, NULL);
+ se->expr = build_call_expr_loc (input_location, frexp, 2,
+ fold_convert (type, arg),
+ gfc_build_addr_expr (NULL_TREE, tmp));
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+/* NEAREST (s, dir) is translated into
+ tmp = copysign (HUGE_VAL, dir);
+ return nextafter (s, tmp);
+ */
+static void
+gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
+{
+ tree args[2], type, tmp, nextafter, copysign, huge_val;
+
+ nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
+ copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+ huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
+ tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
+ fold_convert (type, args[1]));
+ se->expr = build_call_expr_loc (input_location, nextafter, 2,
+ fold_convert (type, args[0]), tmp);
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+/* SPACING (s) is translated into
+ int e;
+ if (s == 0)
+ res = tiny;
+ else
+ {
+ frexp (s, &e);
+ e = e - prec;
+ e = MAX_EXPR (e, emin);
+ res = scalbn (1., e);
+ }
+ return res;
+
+ where prec is the precision of s, gfc_real_kinds[k].digits,
+ emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
+ and tiny is tiny(s), gfc_real_kinds[k].tiny. */
+
+static void
+gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, prec, emin, tiny, res, e;
+ tree cond, tmp, frexp, scalbn;
+ int k;
+ stmtblock_t block;
+
+ k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+ prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
+ emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
+ tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
+
+ frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ e = gfc_create_var (integer_type_node, NULL);
+ res = gfc_create_var (type, NULL);
+
+
+ /* Build the block for s /= 0. */
+ gfc_start_block (&block);
+ tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+ gfc_build_addr_expr (NULL_TREE, e));
+ gfc_add_expr_to_block (&block, tmp);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
+ prec);
+ gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
+ integer_type_node, tmp, emin));
+
+ tmp = build_call_expr_loc (input_location, scalbn, 2,
+ build_real_from_int_cst (type, integer_one_node), e);
+ gfc_add_modify (&block, res, tmp);
+
+ /* Finish by building the IF statement. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
+ build_real_from_int_cst (type, integer_zero_node));
+ tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
+ gfc_finish_block (&block));
+
+ gfc_add_expr_to_block (&se->pre, tmp);
+ se->expr = res;
+}
+
+
+/* RRSPACING (s) is translated into
+ int e;
+ real x;
+ x = fabs (s);
+ if (x != 0)
+ {
+ frexp (s, &e);
+ x = scalbn (x, precision - e);
+ }
+ return x;
+
+ where precision is gfc_real_kinds[k].digits. */
+
+static void
+gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
+{
+ tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
+ int prec, k;
+ stmtblock_t block;
+
+ k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
+ prec = gfc_real_kinds[k].digits;
+
+ frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+ fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ arg = gfc_evaluate_now (arg, &se->pre);
+
+ e = gfc_create_var (integer_type_node, NULL);
+ x = gfc_create_var (type, NULL);
+ gfc_add_modify (&se->pre, x,
+ build_call_expr_loc (input_location, fabs, 1, arg));
+
+
+ gfc_start_block (&block);
+ tmp = build_call_expr_loc (input_location, frexp, 2, arg,
+ gfc_build_addr_expr (NULL_TREE, e));
+ gfc_add_expr_to_block (&block, tmp);
+
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
+ build_int_cst (integer_type_node, prec), e);
+ tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
+ gfc_add_modify (&block, x, tmp);
+ stmt = gfc_finish_block (&block);
+
+ cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
+ build_real_from_int_cst (type, integer_zero_node));
+ tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = fold_convert (type, x);
+}
+
+
+/* SCALE (s, i) is translated into scalbn (s, i). */
+static void
+gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
+{
+ tree args[2], type, scalbn;
+
+ scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (TREE_CHAIN (arg));
- gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
- arg = build1 (NOP_EXPR, pchar_type_node, arg);
type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ se->expr = build_call_expr_loc (input_location, scalbn, 2,
+ fold_convert (type, args[0]),
+ fold_convert (integer_type_node, args[1]));
+ se->expr = fold_convert (type, se->expr);
+}
+
- se->expr = gfc_build_indirect_ref (arg);
+/* SET_EXPONENT (s, i) is translated into
+ scalbn (frexp (s, &dummy_int), i). */
+static void
+gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
+{
+ tree args[2], type, tmp, frexp, scalbn;
+
+ frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+
+ type = gfc_typenode_for_spec (&expr->ts);
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+
+ tmp = gfc_create_var (integer_type_node, NULL);
+ tmp = build_call_expr_loc (input_location, frexp, 2,
+ fold_convert (type, args[0]),
+ gfc_build_addr_expr (NULL_TREE, tmp));
+ se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
+ fold_convert (integer_type_node, args[1]));
+ se->expr = fold_convert (type, se->expr);
+}
+
+
+static void
+gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
+{
+ gfc_actual_arglist *actual;
+ tree arg1;
+ tree type;
+ tree fncall0;
+ tree fncall1;
+ gfc_se argse;
+ gfc_ss *ss;
+
+ gfc_init_se (&argse, NULL);
+ actual = expr->value.function.actual;
+
+ ss = gfc_walk_expr (actual->expr);
+ gcc_assert (ss != gfc_ss_terminator);
+ argse.want_pointer = 1;
+ argse.data_not_needed = 1;
+ gfc_conv_expr_descriptor (&argse, actual->expr, ss);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ arg1 = gfc_evaluate_now (argse.expr, &se->pre);
+
+ /* Build the call to size0. */
+ fncall0 = build_call_expr_loc (input_location,
+ gfor_fndecl_size0, 1, arg1);
+
+ actual = actual->next;
+
+ if (actual->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_type (&argse, actual->expr,
+ gfc_array_index_type);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+
+ /* Unusually, for an intrinsic, size does not exclude
+ an optional arg2, so we must test for it. */
+ if (actual->expr->expr_type == EXPR_VARIABLE
+ && actual->expr->symtree->n.sym->attr.dummy
+ && actual->expr->symtree->n.sym->attr.optional)
+ {
+ tree tmp;
+ /* Build the call to size1. */
+ fncall1 = build_call_expr_loc (input_location,
+ gfor_fndecl_size1, 2,
+ arg1, argse.expr);
+
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 1;
+ argse.data_not_needed = 1;
+ gfc_conv_expr (&argse, actual->expr);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ argse.expr, null_pointer_node);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->expr = fold_build3_loc (input_location, COND_EXPR,
+ pvoid_type_node, tmp, fncall1, fncall0);
+ }
+ else
+ {
+ se->expr = NULL_TREE;
+ argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type,
+ argse.expr, gfc_index_one_node);
+ }
+ }
+ else if (expr->value.function.actual->expr->rank == 1)
+ {
+ argse.expr = gfc_index_zero_node;
+ se->expr = NULL_TREE;
+ }
+ else
+ se->expr = fncall0;
+
+ if (se->expr == NULL_TREE)
+ {
+ tree ubound, lbound;
+
+ arg1 = build_fold_indirect_ref_loc (input_location,
+ arg1);
+ ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
+ lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
+ se->expr = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, ubound, lbound);
+ se->expr = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type,
+ se->expr, gfc_index_one_node);
+ se->expr = fold_build2_loc (input_location, MAX_EXPR,
+ gfc_array_index_type, se->expr,
+ gfc_index_zero_node);
+ }
+
+ type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
}
-/* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
+/* Helper function to compute the size of a character variable,
+ excluding the terminating null characters. The result has
+ gfc_array_index_type type. */
+
+static tree
+size_of_string_in_bytes (int kind, tree string_length)
+{
+ tree bytesize;
+ int i = gfc_validate_kind (BT_CHARACTER, kind, false);
+
+ bytesize = build_int_cst (gfc_array_index_type,
+ gfc_character_kinds[i].bit_size / 8);
+
+ return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ bytesize,
+ fold_convert (gfc_array_index_type, string_length));
+}
+
+
+static void
+gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
+{
+ gfc_expr *arg;
+ gfc_ss *ss;
+ gfc_se argse;
+ tree source_bytes;
+ tree type;
+ tree tmp;
+ tree lower;
+ tree upper;
+ int n;
+
+ arg = expr->value.function.actual->expr;
+
+ gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (arg);
+
+ if (ss == gfc_ss_terminator)
+ {
+ if (arg->ts.type == BT_CLASS)
+ gfc_add_data_component (arg);
+
+ gfc_conv_expr_reference (&argse, arg);
-static void
-gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
-{
- tree arg;
- tree tsource;
- tree fsource;
- tree mask;
- tree type;
- tree len;
+ type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
- arg = gfc_conv_intrinsic_function_args (se, expr);
- if (expr->ts.type != BT_CHARACTER)
- {
- tsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- fsource = TREE_VALUE (arg);
- mask = TREE_VALUE (TREE_CHAIN (arg));
+ /* Obtain the source word length. */
+ if (arg->ts.type == BT_CHARACTER)
+ se->expr = size_of_string_in_bytes (arg->ts.kind,
+ argse.string_length);
+ else
+ se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
}
else
{
- /* We do the same as in the non-character case, but the argument
- list is different because of the string length arguments. We
- also have to set the string length for the result. */
- len = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- tsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (TREE_CHAIN (arg));
- fsource = TREE_VALUE (arg);
- mask = TREE_VALUE (TREE_CHAIN (arg));
+ source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg, ss);
+ type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+ /* Obtain the argument's word length. */
+ if (arg->ts.type == BT_CHARACTER)
+ tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (type));
+ gfc_add_modify (&argse.pre, source_bytes, tmp);
- se->string_length = len;
+ /* Obtain the size of the array in bytes. */
+ for (n = 0; n < arg->rank; n++)
+ {
+ tree idx;
+ idx = gfc_rank_cst[n];
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, upper, lower);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, tmp, gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, source_bytes);
+ gfc_add_modify (&argse.pre, source_bytes, tmp);
+ }
+ se->expr = source_bytes;
}
- type = TREE_TYPE (tsource);
- se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
+
+ gfc_add_block_to_block (&se->pre, &argse.pre);
}
static void
-gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
{
- gfc_actual_arglist *actual;
- tree args;
- tree type;
- tree fndecl;
- gfc_se argse;
+ gfc_expr *arg;
gfc_ss *ss;
+ gfc_se argse,eight;
+ tree type, result_type, tmp;
+ arg = expr->value.function.actual->expr;
+ gfc_init_se (&eight, NULL);
+ gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
+
gfc_init_se (&argse, NULL);
- actual = expr->value.function.actual;
-
- ss = gfc_walk_expr (actual->expr);
- gcc_assert (ss != gfc_ss_terminator);
- argse.want_pointer = 1;
- gfc_conv_expr_descriptor (&argse, actual->expr, ss);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- gfc_add_block_to_block (&se->post, &argse.post);
- args = gfc_chainon_list (NULL_TREE, argse.expr);
+ ss = gfc_walk_expr (arg);
+ result_type = gfc_get_int_type (expr->ts.kind);
- actual = actual->next;
- if (actual->expr)
+ if (ss == gfc_ss_terminator)
{
- gfc_init_se (&argse, NULL);
- gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
- gfc_add_block_to_block (&se->pre, &argse.pre);
- args = gfc_chainon_list (args, argse.expr);
- fndecl = gfor_fndecl_size1;
+ if (arg->ts.type == BT_CLASS)
+ {
+ gfc_add_vptr_component (arg);
+ gfc_add_size_component (arg);
+ gfc_conv_expr (&argse, arg);
+ tmp = fold_convert (result_type, argse.expr);
+ goto done;
+ }
+
+ gfc_conv_expr_reference (&argse, arg);
+ type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
+ }
+ else
+ {
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg, ss);
+ type = gfc_get_element_type (TREE_TYPE (argse.expr));
}
+
+ /* Obtain the argument's word length. */
+ if (arg->ts.type == BT_CHARACTER)
+ tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
else
- fndecl = gfor_fndecl_size0;
+ tmp = fold_convert (result_type, size_in_bytes (type));
- se->expr = gfc_build_function_call (fndecl, args);
- type = gfc_typenode_for_spec (&expr->ts);
- se->expr = convert (type, se->expr);
+done:
+ se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
+ eight.expr);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
}
/* Intrinsic string comparison functions. */
- static void
-gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
+static void
+gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
- tree type;
- tree args;
+ tree args[4];
- args = gfc_conv_intrinsic_function_args (se, expr);
- /* Build a call for the comparison. */
- se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
+ gfc_conv_intrinsic_function_args (se, expr, args, 4);
- type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build2 (op, type, se->expr,
- convert (TREE_TYPE (se->expr), integer_zero_node));
+ se->expr
+ = gfc_build_compare_string (args[0], args[1], args[2], args[3],
+ expr->value.function.actual->expr->ts.kind,
+ op);
+ se->expr = fold_build2_loc (input_location, op,
+ gfc_typenode_for_spec (&expr->ts), se->expr,
+ build_int_cst (TREE_TYPE (se->expr), 0));
}
/* Generate a call to the adjustl/adjustr library function. */
static void
gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
{
- tree args;
+ tree args[3];
tree len;
tree type;
tree var;
tree tmp;
- args = gfc_conv_intrinsic_function_args (se, expr);
- len = TREE_VALUE (args);
+ gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
+ len = args[1];
- type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
+ type = TREE_TYPE (args[2]);
var = gfc_conv_string_tmp (se, type, len);
- args = tree_cons (NULL_TREE, var, args);
+ args[0] = var;
- tmp = gfc_build_function_call (fndecl, args);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 3, args[0], args[1], args[2]);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = var;
se->string_length = len;
}
-/* Scalar transfer statement.
- TRANSFER (source, mold) = *(typeof<mould> *)&source */
-
+/* Generate code for the TRANSFER intrinsic:
+ For scalar results:
+ DEST = TRANSFER (SOURCE, MOLD)
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ MOLD is scalar.
+
+ For array results:
+ DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
+ where:
+ typeof<DEST> = typeof<MOLD>
+ and:
+ N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
+ sizeof (DEST(0) * SIZE). */
static void
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
{
+ tree tmp;
+ tree tmpdecl;
+ tree ptr;
+ tree extent;
+ tree source;
+ tree source_type;
+ tree source_bytes;
+ tree mold_type;
+ tree dest_word_len;
+ tree size_words;
+ tree size_bytes;
+ tree upper;
+ tree lower;
+ tree stmt;
gfc_actual_arglist *arg;
gfc_se argse;
- tree type;
- tree ptr;
gfc_ss *ss;
+ gfc_ss_info *info;
+ stmtblock_t block;
+ int n;
+ bool scalar_mold;
- gcc_assert (!se->ss);
+ info = NULL;
+ if (se->loop)
+ info = &se->ss->data.info;
- /* Get a pointer to the source. */
+ /* Convert SOURCE. The output from this stage is:-
+ source_bytes = length of the source in bytes
+ source = pointer to the source data. */
arg = expr->value.function.actual;
+
+ /* Ensure double transfer through LOGICAL preserves all
+ the needed bits. */
+ if (arg->expr->expr_type == EXPR_FUNCTION
+ && arg->expr->value.function.esym == NULL
+ && arg->expr->value.function.isym != NULL
+ && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
+ && arg->expr->ts.type == BT_LOGICAL
+ && expr->ts.type != arg->expr->ts.type)
+ arg->expr->value.function.name = "__transfer_in_transfer";
+
+ gfc_init_se (&argse, NULL);
ss = gfc_walk_expr (arg->expr);
+
+ source_bytes = gfc_create_var (gfc_array_index_type, NULL);
+
+ /* Obtain the pointer to source and the length of source in bytes. */
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&argse, arg->expr);
+ source = argse.expr;
+
+ source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
+
+ /* Obtain the source word length. */
+ if (arg->expr->ts.type == BT_CHARACTER)
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (source_type));
+ }
+ else
+ {
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ source = gfc_conv_descriptor_data_get (argse.expr);
+ source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+
+ /* Repack the source if not a full variable array. */
+ if (arg->expr->expr_type == EXPR_VARIABLE
+ && arg->expr->ref->u.ar.type != AR_FULL)
+ {
+ tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
+
+ if (gfc_option.warn_array_temp)
+ gfc_warning ("Creating array temporary at %L", &expr->where);
+
+ source = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, tmp);
+ source = gfc_evaluate_now (source, &argse.pre);
+
+ /* Free the temporary. */
+ gfc_start_block (&block);
+ tmp = gfc_call_free (convert (pvoid_type_node, source));
+ gfc_add_expr_to_block (&block, tmp);
+ stmt = gfc_finish_block (&block);
+
+ /* Clean up if it was repacked. */
+ gfc_init_block (&block);
+ tmp = gfc_conv_array_data (argse.expr);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ source, tmp);
+ tmp = build3_v (COND_EXPR, tmp, stmt,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &se->post);
+ gfc_init_block (&se->post);
+ gfc_add_block_to_block (&se->post, &block);
+ }
+
+ /* Obtain the source word length. */
+ if (arg->expr->ts.type == BT_CHARACTER)
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind,
+ argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (source_type));
+
+ /* Obtain the size of the array in bytes. */
+ extent = gfc_create_var (gfc_array_index_type, NULL);
+ for (n = 0; n < arg->expr->rank; n++)
+ {
+ tree idx;
+ idx = gfc_rank_cst[n];
+ gfc_add_modify (&argse.pre, source_bytes, tmp);
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, upper, lower);
+ gfc_add_modify (&argse.pre, extent, tmp);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, extent,
+ gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, tmp, source_bytes);
+ }
+ }
+
+ gfc_add_modify (&argse.pre, source_bytes, tmp);
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+
+ /* Now convert MOLD. The outputs are:
+ mold_type = the TREE type of MOLD
+ dest_word_len = destination word length in bytes. */
+ arg = arg->next;
+
gfc_init_se (&argse, NULL);
+ ss = gfc_walk_expr (arg->expr);
+
+ scalar_mold = arg->expr->rank == 0;
+
if (ss == gfc_ss_terminator)
- gfc_conv_expr_reference (&argse, arg->expr);
+ {
+ gfc_conv_expr_reference (&argse, arg->expr);
+ mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
+ }
else
- gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
+ {
+ gfc_init_se (&argse, NULL);
+ argse.want_pointer = 0;
+ gfc_conv_expr_descriptor (&argse, arg->expr, ss);
+ mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
+ }
+
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- ptr = argse.expr;
+ if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
+ {
+ /* If this TRANSFER is nested in another TRANSFER, use a type
+ that preserves all bits. */
+ if (arg->expr->ts.type == BT_LOGICAL)
+ mold_type = gfc_get_int_type (arg->expr->ts.kind);
+ }
+
+ if (arg->expr->ts.type == BT_CHARACTER)
+ {
+ tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
+ mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
+ }
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (mold_type));
+
+ dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
+ gfc_add_modify (&se->pre, dest_word_len, tmp);
+
+ /* Finally convert SIZE, if it is present. */
arg = arg->next;
- type = gfc_typenode_for_spec (&expr->ts);
- ptr = convert (build_pointer_type (type), ptr);
- if (expr->ts.type == BT_CHARACTER)
+ size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+ if (arg->expr)
{
gfc_init_se (&argse, NULL);
- gfc_conv_expr (&argse, arg->expr);
+ gfc_conv_expr_reference (&argse, arg->expr);
+ tmp = convert (gfc_array_index_type,
+ build_fold_indirect_ref_loc (input_location,
+ argse.expr));
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- se->expr = ptr;
- se->string_length = argse.string_length;
+ }
+ else
+ tmp = NULL_TREE;
+
+ /* Separate array and scalar results. */
+ if (scalar_mold && tmp == NULL_TREE)
+ goto scalar_transfer;
+
+ size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+ if (tmp != NULL_TREE)
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
+ else
+ tmp = source_bytes;
+
+ gfc_add_modify (&se->pre, size_bytes, tmp);
+ gfc_add_modify (&se->pre, size_words,
+ fold_build2_loc (input_location, CEIL_DIV_EXPR,
+ gfc_array_index_type,
+ size_bytes, dest_word_len));
+
+ /* Evaluate the bounds of the result. If the loop range exists, we have
+ to check if it is too large. If so, we modify loop->to be consistent
+ with min(size, size(source)). Otherwise, size is made consistent with
+ the loop range, so that the right number of bytes is transferred.*/
+ n = se->loop->order[0];
+ if (se->loop->to[n] != NULL_TREE)
+ {
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ se->loop->to[n], se->loop->from[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
+ tmp, size_words);
+ gfc_add_modify (&se->pre, size_words, tmp);
+ gfc_add_modify (&se->pre, size_bytes,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type,
+ size_words, dest_word_len));
+ upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ size_words, se->loop->from[n]);
+ upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ upper, gfc_index_one_node);
+ }
+ else
+ {
+ upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ size_words, gfc_index_one_node);
+ se->loop->from[n] = gfc_index_zero_node;
+ }
+
+ se->loop->to[n] = upper;
+
+ /* Build a destination descriptor, using the pointer, source, as the
+ data field. */
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
+ info, mold_type, NULL_TREE, false, true, false,
+ &expr->where);
+
+ /* Cast the pointer to the result. */
+ tmp = gfc_conv_descriptor_data_get (info->descriptor);
+ tmp = fold_convert (pvoid_type_node, tmp);
+
+ /* Use memcpy to do the transfer. */
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMCPY),
+ 3,
+ tmp,
+ fold_convert (pvoid_type_node, source),
+ fold_build2_loc (input_location, MIN_EXPR,
+ gfc_array_index_type,
+ size_bytes, source_bytes));
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = info->descriptor;
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
+
+ return;
+
+/* Deal with scalar results. */
+scalar_transfer:
+ extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
+ dest_word_len, source_bytes);
+ extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
+
+ if (expr->ts.type == BT_CHARACTER)
+ {
+ tree direct;
+ tree indirect;
+
+ ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
+ tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
+ "transfer");
+
+ /* If source is longer than the destination, use a pointer to
+ the source directly. */
+ gfc_init_block (&block);
+ gfc_add_modify (&block, tmpdecl, ptr);
+ direct = gfc_finish_block (&block);
+
+ /* Otherwise, allocate a string with the length of the destination
+ and copy the source into it. */
+ gfc_init_block (&block);
+ tmp = gfc_get_pchar_type (expr->ts.kind);
+ tmp = gfc_call_malloc (&block, tmp, dest_word_len);
+ gfc_add_modify (&block, tmpdecl,
+ fold_convert (TREE_TYPE (ptr), tmp));
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+ fold_convert (pvoid_type_node, tmpdecl),
+ fold_convert (pvoid_type_node, ptr),
+ extent);
+ gfc_add_expr_to_block (&block, tmp);
+ indirect = gfc_finish_block (&block);
+
+ /* Wrap it up with the condition. */
+ tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
+ dest_word_len, source_bytes);
+ tmp = build3_v (COND_EXPR, tmp, direct, indirect);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = tmpdecl;
+ se->string_length = dest_word_len;
}
else
{
- se->expr = gfc_build_indirect_ref (ptr);
+ tmpdecl = gfc_create_var (mold_type, "transfer");
+
+ ptr = convert (build_pointer_type (mold_type), source);
+
+ /* Use memcpy to do the transfer. */
+ tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
+ fold_convert (pvoid_type_node, tmp),
+ fold_convert (pvoid_type_node, ptr),
+ extent);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = tmpdecl;
}
}
gfc_init_se (&arg1se, NULL);
arg1 = expr->value.function.actual;
ss1 = gfc_walk_expr (arg1->expr);
- arg1se.descriptor_only = 1;
- gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- tmp = gfc_conv_descriptor_data (arg1se.expr);
- tmp = build2 (NE_EXPR, boolean_type_node, tmp,
- fold_convert (TREE_TYPE (tmp), null_pointer_node));
+ if (ss1 == gfc_ss_terminator)
+ {
+ /* Allocatable scalar. */
+ arg1se.want_pointer = 1;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_data_component (arg1->expr);
+ gfc_conv_expr (&arg1se, arg1->expr);
+ tmp = arg1se.expr;
+ }
+ else
+ {
+ /* Allocatable array. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ tmp = gfc_conv_descriptor_data_get (arg1se.expr);
+ }
+
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
+ fold_convert (TREE_TYPE (tmp), null_pointer_node));
se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
gfc_se arg2se;
tree tmp2;
tree tmp;
- tree args, fndecl;
+ tree nonzero_charlen;
+ tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
gfc_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_data_component (arg1->expr);
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
else
{
/* A pointer to an array. */
- arg1se.descriptor_only = 1;
- gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp2 = gfc_conv_descriptor_data (arg1se.expr);
+ gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
+ tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
}
- tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
- fold_convert (TREE_TYPE (tmp2), null_pointer_node));
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
+ fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
}
else
{
/* An optional target. */
+ if (arg2->expr->ts.type == BT_CLASS)
+ gfc_add_data_component (arg2->expr);
ss2 = gfc_walk_expr (arg2->expr);
+
+ nonzero_charlen = NULL_TREE;
+ if (arg1->expr->ts.type == BT_CHARACTER)
+ nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ arg1->expr->ts.u.cl->backend_decl,
+ integer_zero_node);
+
if (ss1 == gfc_ss_terminator)
{
/* A pointer to a scalar. */
gfc_conv_expr (&arg1se, arg1->expr);
arg2se.want_pointer = 1;
gfc_conv_expr (&arg2se, arg2->expr);
- tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
- se->expr = tmp;
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ arg1se.expr, arg2se.expr);
+ tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ arg1se.expr, null_pointer_node);
+ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, tmp, tmp2);
}
else
{
+ /* An array pointer of zero length is not associated if target is
+ present. */
+ arg1se.descriptor_only = 1;
+ gfc_conv_expr_lhs (&arg1se, arg1->expr);
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
+ gfc_rank_cst[arg1->expr->rank - 1]);
+ nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node, tmp,
+ build_int_cst (TREE_TYPE (tmp), 0));
+
/* A pointer to an array, call library function _gfor_associated. */
gcc_assert (ss2 != gfc_ss_terminator);
- args = NULL_TREE;
arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- args = gfc_chainon_list (args, arg1se.expr);
+
arg2se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
gfc_add_block_to_block (&se->pre, &arg2se.pre);
gfc_add_block_to_block (&se->post, &arg2se.post);
- args = gfc_chainon_list (args, arg2se.expr);
- fndecl = gfor_fndecl_associated;
- se->expr = gfc_build_function_call (fndecl, args);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_associated, 2,
+ arg1se.expr, arg2se.expr);
+ se->expr = convert (boolean_type_node, se->expr);
+ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, se->expr,
+ nonzero_arraylen);
}
- }
- se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
-}
-
-
-/* Scan a string for any one of the characters in a set of characters. */
-
-static void
-gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
-{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
- tree type;
- tree tmp;
- args = gfc_conv_intrinsic_function_args (se, expr);
- type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
- {
- back = convert (gfc_logical4_type_node, integer_one_node);
- back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
- TREE_CHAIN (tmp) = back;
- }
- else
- {
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
+ /* If target is present zero character length pointers cannot
+ be associated. */
+ if (nonzero_charlen != NULL_TREE)
+ se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node,
+ se->expr, nonzero_charlen);
}
- se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
- se->expr = convert (type, se->expr);
+ se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
-/* Verify that a set of characters contains all the characters in a string
- by identifying the position of the first character in a string of
- characters that does not appear in a given set of characters. */
+/* Generate code for the SAME_TYPE_AS intrinsic.
+ Generate inline code that directly checks the vindices. */
static void
-gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
- tree args;
- tree back;
- tree type;
+ gfc_expr *a, *b;
+ gfc_se se1, se2;
tree tmp;
- args = gfc_conv_intrinsic_function_args (se, expr);
- type = gfc_typenode_for_spec (&expr->ts);
- tmp = gfc_advance_chain (args, 3);
- if (TREE_CHAIN (tmp) == NULL_TREE)
+ gfc_init_se (&se1, NULL);
+ gfc_init_se (&se2, NULL);
+
+ a = expr->value.function.actual->expr;
+ b = expr->value.function.actual->next->expr;
+
+ if (a->ts.type == BT_CLASS)
{
- back = convert (gfc_logical4_type_node, integer_one_node);
- back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
- TREE_CHAIN (tmp) = back;
+ gfc_add_vptr_component (a);
+ gfc_add_hash_component (a);
}
- else
+ else if (a->ts.type == BT_DERIVED)
+ a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ a->ts.u.derived->hash_value);
+
+ if (b->ts.type == BT_CLASS)
{
- back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
+ gfc_add_vptr_component (b);
+ gfc_add_hash_component (b);
}
+ else if (b->ts.type == BT_DERIVED)
+ b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ b->ts.u.derived->hash_value);
- se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
- se->expr = convert (type, se->expr);
-}
-
-/* Prepare components and related information of a real number which is
- the first argument of a elemental functions to manipulate reals. */
-
-static
-void prepare_arg_info (gfc_se * se, gfc_expr * expr,
- real_compnt_info * rcs, int all)
-{
- tree arg;
- tree masktype;
- tree tmp;
- tree wbits;
- tree one;
- tree exponent, fraction;
- int n;
- gfc_expr *a1;
-
- if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
- gfc_todo_error ("Non-IEEE floating format");
-
- gcc_assert (expr->expr_type == EXPR_FUNCTION);
-
- arg = gfc_conv_intrinsic_function_args (se, expr);
- arg = TREE_VALUE (arg);
- rcs->type = TREE_TYPE (arg);
-
- /* Force arg'type to integer by unaffected convert */
- a1 = expr->value.function.actual->expr;
- masktype = gfc_get_int_type (a1->ts.kind);
- rcs->mtype = masktype;
- tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
- arg = gfc_create_var (masktype, "arg");
- gfc_add_modify_expr(&se->pre, arg, tmp);
- rcs->arg = arg;
-
- /* Caculate the numbers of bits of exponent, fraction and word */
- n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
- tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
- rcs->fdigits = convert (masktype, tmp);
- wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
- wbits = convert (masktype, wbits);
- rcs->edigits = fold (build2 (MINUS_EXPR, masktype, wbits, tmp));
-
- /* Form masks for exponent/fraction/sign */
- one = gfc_build_const (masktype, integer_one_node);
- rcs->smask = fold (build2 (LSHIFT_EXPR, masktype, one, wbits));
- rcs->f1 = fold (build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits));
- rcs->emask = fold (build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
- rcs->fmask = fold (build2 (MINUS_EXPR, masktype, rcs->f1, one));
- /* Form bias. */
- tmp = fold (build2 (MINUS_EXPR, masktype, rcs->edigits, one));
- tmp = fold (build2 (LSHIFT_EXPR, masktype, one, tmp));
- rcs->bias = fold (build2 (MINUS_EXPR, masktype, tmp ,one));
-
- if (all)
- {
- /* exponent, and fraction */
- tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
- exponent = gfc_create_var (masktype, "exponent");
- gfc_add_modify_expr(&se->pre, exponent, tmp);
- rcs->expn = exponent;
-
- tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
- fraction = gfc_create_var (masktype, "fraction");
- gfc_add_modify_expr(&se->pre, fraction, tmp);
- rcs->frac = fraction;
- }
-}
-
-/* Build a call to __builtin_clz. */
-
-static tree
-call_builtin_clz (tree result_type, tree op0)
-{
- tree fn, parms, call;
- enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
-
- if (op0_mode == TYPE_MODE (integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZ];
- else if (op0_mode == TYPE_MODE (long_integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZL];
- else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
- fn = built_in_decls[BUILT_IN_CLZLL];
- else
- gcc_unreachable ();
-
- parms = tree_cons (NULL, op0, NULL);
- call = gfc_build_function_call (fn, parms);
+ gfc_conv_expr (&se1, a);
+ gfc_conv_expr (&se2, b);
- return convert (result_type, call);
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
+ se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
+ se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
}
-/* Generate code for SPACING (X) intrinsic function.
- SPACING (X) = POW (2, e-p)
-
- We generate:
-
- t = expn - fdigits // e - p.
- res = t << fdigits // Form the exponent. Fraction is zero.
- if (t < 0) // The result is out of range. Denormalized case.
- res = tiny(X)
- */
+/* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
-gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
{
- tree arg;
- tree masktype;
- tree tmp, t1, cond;
- tree tiny, zero;
- tree fdigits;
- real_compnt_info rcs;
-
- prepare_arg_info (se, expr, &rcs, 0);
- arg = rcs.arg;
- masktype = rcs.mtype;
- fdigits = rcs.fdigits;
- tiny = rcs.f1;
- zero = gfc_build_const (masktype, integer_zero_node);
- tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
- cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
- t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
- tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
-
- se->expr = tmp;
-}
-
-/* Generate code for RRSPACING (X) intrinsic function.
- RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
-
- So the result's exponent is p. And if X is normalized, X's fraction part
- is the result's fraction. If X is denormalized, to get the X's fraction we
- shift X's fraction part to left until the first '1' is removed.
-
- We generate:
-
- if (expn == 0 && frac == 0)
- res = 0;
- else
- {
- // edigits is the number of exponent bits. Add the sign bit.
- sedigits = edigits + 1;
+ tree args[2];
- if (expn == 0) // Denormalized case.
- {
- t1 = leadzero (frac);
- frac = frac << (t1 + 1); //Remove the first '1'.
- frac = frac >> (sedigits); //Form the fraction.
- }
+ gfc_conv_intrinsic_function_args (se, expr, args, 2);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_sc_kind, 2, args[0], args[1]);
+ se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
+}
- //fdigits is the number of fraction bits. Form the exponent.
- t = bias + fdigits;
- res = (t << fdigits) | frac;
- }
-*/
+/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
static void
-gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
{
- tree masktype;
- tree tmp, t1, t2, cond, cond2;
- tree one, zero;
- tree fdigits, fraction;
- real_compnt_info rcs;
+ tree arg, type;
- prepare_arg_info (se, expr, &rcs, 1);
- masktype = rcs.mtype;
- fdigits = rcs.fdigits;
- fraction = rcs.frac;
- one = gfc_build_const (masktype, integer_one_node);
- zero = gfc_build_const (masktype, integer_zero_node);
- t2 = fold (build2 (PLUS_EXPR, masktype, rcs.edigits, one));
+ gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- t1 = call_builtin_clz (masktype, fraction);
- tmp = build2 (PLUS_EXPR, masktype, t1, one);
- tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
- tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
- cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
- fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
+ /* The argument to SELECTED_INT_KIND is INTEGER(4). */
+ type = gfc_get_int_type (4);
+ arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
- tmp = fold (build2 (PLUS_EXPR, masktype, rcs.bias, fdigits));
- tmp = fold (build2 (LSHIFT_EXPR, masktype, tmp, fdigits));
- tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
-
- cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
- cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
- tmp = build3 (COND_EXPR, masktype, cond,
- convert (masktype, integer_zero_node), tmp);
-
- tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
- se->expr = tmp;
+ /* Convert it to the required type. */
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_si_kind, 1, arg);
+ se->expr = fold_convert (type, se->expr);
}
-/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
-
-static void
-gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
-{
- tree args;
-
- args = gfc_conv_intrinsic_function_args (se, expr);
- args = TREE_VALUE (args);
- args = gfc_build_addr_expr (NULL, args);
- args = tree_cons (NULL_TREE, args, NULL_TREE);
- se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
-}
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
static void
-gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
+gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *actual;
- tree args;
+ tree type;
gfc_se argse;
+ VEC(tree,gc) *args = NULL;
- args = NULL_TREE;
for (actual = expr->value.function.actual; actual; actual = actual->next)
{
gfc_init_se (&argse, se);
if (actual->expr == NULL)
argse.expr = null_pointer_node;
else
- gfc_conv_expr_reference (&argse, actual->expr);
+ {
+ gfc_typespec ts;
+ gfc_clear_ts (&ts);
+
+ if (actual->expr->ts.kind != gfc_c_int_kind)
+ {
+ /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_c_int_kind;
+ gfc_convert_type (actual->expr, &ts, 2);
+ }
+ gfc_conv_expr_reference (&argse, actual->expr);
+ }
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
- args = gfc_chainon_list (args, argse.expr);
+ VEC_safe_push (tree, gc, args, argse.expr);
}
- se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
+
+ /* Convert it to the required type. */
+ type = gfc_typenode_for_spec (&expr->ts);
+ se->expr = build_call_expr_loc_vec (input_location,
+ gfor_fndecl_sr_kind, args);
+ se->expr = fold_convert (type, se->expr);
}
static void
gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
tree var;
tree len;
tree addr;
tree tmp;
- tree arglist;
- tree type;
tree cond;
+ tree fndecl;
+ tree function;
+ tree *args;
+ unsigned int num_args;
- arglist = NULL_TREE;
+ num_args = gfc_intrinsic_argument_list_length (expr) + 2;
+ args = XALLOCAVEC (tree, num_args);
- type = build_pointer_type (gfc_character1_type_node);
- var = gfc_create_var (type, "pstr");
+ var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
addr = gfc_build_addr_expr (ppvoid_type_node, var);
- len = gfc_create_var (gfc_int4_type_node, "len");
+ len = gfc_create_var (gfc_charlen_type_node, "len");
- tmp = gfc_conv_intrinsic_function_args (se, expr);
- arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
- arglist = gfc_chainon_list (arglist, addr);
- arglist = chainon (arglist, tmp);
-
- tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
+ gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
+ args[0] = gfc_build_addr_expr (NULL_TREE, len);
+ args[1] = addr;
+
+ if (expr->ts.kind == 1)
+ function = gfor_fndecl_string_trim;
+ else if (expr->ts.kind == 4)
+ function = gfor_fndecl_string_trim_char4;
+ else
+ gcc_unreachable ();
+
+ fndecl = build_addr (function, current_function_decl);
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
+ num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build2 (GT_EXPR, boolean_type_node, len,
- convert (TREE_TYPE (len), integer_zero_node));
- arglist = gfc_chainon_list (NULL_TREE, var);
- tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
- tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ len, build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
static void
gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
- tree tmp;
- tree len;
- tree args;
- tree arglist;
- tree ncopies;
- tree var;
- tree type;
+ tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
+ tree type, cond, tmp, count, exit_label, n, max, largest;
+ tree size;
+ stmtblock_t block, body;
+ int i;
+
+ /* We store in charsize the size of a character. */
+ i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
+ size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
+
+ /* Get the arguments. */
+ gfc_conv_intrinsic_function_args (se, expr, args, 3);
+ slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
+ src = args[1];
+ ncopies = gfc_evaluate_now (args[2], &se->pre);
+ ncopies_type = TREE_TYPE (ncopies);
+
+ /* Check that NCOPIES is not negative. */
+ cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
+ build_int_cst (ncopies_type, 0));
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ "Argument NCOPIES of REPEAT intrinsic is negative "
+ "(its value is %lld)",
+ fold_convert (long_integer_type_node, ncopies));
+
+ /* If the source length is zero, any non negative value of NCOPIES
+ is valid, and nothing happens. */
+ n = gfc_create_var (ncopies_type, "ncopies");
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
+ build_int_cst (ncopies_type, 0), ncopies);
+ gfc_add_modify (&se->pre, n, tmp);
+ ncopies = n;
+
+ /* Check that ncopies is not too large: ncopies should be less than
+ (or equal to) MAX / slen, where MAX is the maximal integer of
+ the gfc_charlen_type_node type. If slen == 0, we need a special
+ case to avoid the division by zero. */
+ i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
+ max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
+ max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
+ fold_convert (size_type_node, max), slen);
+ largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
+ ? size_type_node : ncopies_type;
+ cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+ fold_convert (largest, ncopies),
+ fold_convert (largest, max));
+ tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
+ boolean_false_node, cond);
+ gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
+ "Argument NCOPIES of REPEAT intrinsic is too large");
+
+ /* Compute the destination length. */
+ dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node, slen),
+ fold_convert (gfc_charlen_type_node, ncopies));
+ type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
+ dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
+
+ /* Generate the code to do the repeat operation:
+ for (i = 0; i < ncopies; i++)
+ memmove (dest + (i * slen * size), src, slen*size); */
+ gfc_start_block (&block);
+ count = gfc_create_var (ncopies_type, "count");
+ gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
+ exit_label = gfc_build_label_decl (NULL_TREE);
+
+ /* Start the loop body. */
+ gfc_start_block (&body);
+
+ /* Exit the loop if count >= ncopies. */
+ cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
+ ncopies);
+ tmp = build1_v (GOTO_EXPR, exit_label);
+ TREE_USED (exit_label) = 1;
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Call memmove (dest + (i*slen*size), src, slen*size). */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+ fold_convert (gfc_charlen_type_node, slen),
+ fold_convert (gfc_charlen_type_node, count));
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
+ tmp, fold_convert (gfc_charlen_type_node, size));
+ tmp = fold_build_pointer_plus_loc (input_location,
+ fold_convert (pvoid_type_node, dest), tmp);
+ tmp = build_call_expr_loc (input_location,
+ builtin_decl_explicit (BUILT_IN_MEMMOVE),
+ 3, tmp, src,
+ fold_build2_loc (input_location, MULT_EXPR,
+ size_type_node, slen,
+ fold_convert (size_type_node,
+ size)));
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Increment count. */
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
+ count, build_int_cst (TREE_TYPE (count), 1));
+ gfc_add_modify (&body, count, tmp);
+
+ /* Build the loop. */
+ tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+ gfc_add_expr_to_block (&block, tmp);
- args = gfc_conv_intrinsic_function_args (se, expr);
- len = TREE_VALUE (args);
- tmp = gfc_advance_chain (args, 2);
- ncopies = TREE_VALUE (tmp);
- len = fold (build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies));
- type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
- var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
-
- arglist = NULL_TREE;
- arglist = gfc_chainon_list (arglist, var);
- arglist = chainon (arglist, args);
- tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
+ /* Add the exit label. */
+ tmp = build1_v (LABEL_EXPR, exit_label);
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* Finish the block. */
+ tmp = gfc_finish_block (&block);
gfc_add_expr_to_block (&se->pre, tmp);
- se->expr = var;
- se->string_length = len;
+ /* Set the result value. */
+ se->expr = dest;
+ se->string_length = dlen;
}
-/* Generate code for the IARGC intrinsic. If args_only is true this is
- actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
+/* Generate code for the IARGC intrinsic. */
static void
-gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
+gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
{
tree tmp;
tree fndecl;
/* Call the library function. This always returns an INTEGER(4). */
fndecl = gfor_fndecl_iargc;
- tmp = gfc_build_function_call (fndecl, NULL_TREE);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 0);
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
tmp = fold_convert (type, tmp);
- if (args_only)
- tmp = build2 (MINUS_EXPR, type, tmp, convert (type, integer_one_node));
- se->expr = tmp;
+ se->expr = tmp;
+}
+
+
+/* The loc intrinsic returns the address of its argument as
+ gfc_index_integer_kind integer. */
+
+static void
+gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
+{
+ tree temp_var;
+ gfc_expr *arg_expr;
+ gfc_ss *ss;
+
+ gcc_assert (!se->ss);
+
+ arg_expr = expr->value.function.actual->expr;
+ ss = gfc_walk_expr (arg_expr);
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr_reference (se, arg_expr);
+ else
+ gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
+ se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
+
+ /* Create a temporary variable for loc return value. Without this,
+ we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
+ temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
+ gfc_add_modify (&se->pre, temp_var, se->expr);
+ se->expr = temp_var;
}
/* Generate code for an intrinsic function. Some map directly to library
void
gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{
- gfc_intrinsic_sym *isym;
- char *name;
- int lib;
-
- isym = expr->value.function.isym;
+ const char *name;
+ int lib, kind;
+ tree fndecl;
name = &expr->value.function.name[2];
{
if (lib == 1)
se->ignore_optional = 1;
- gfc_conv_intrinsic_funcall (se, expr);
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_EOSHIFT:
+ case GFC_ISYM_PACK:
+ case GFC_ISYM_RESHAPE:
+ /* For all of those the first argument specifies the type and the
+ third is optional. */
+ conv_generic_with_optional_char_arg (se, expr, 1, 3);
+ break;
+
+ default:
+ gfc_conv_intrinsic_funcall (se, expr);
+ break;
+ }
+
return;
}
}
- switch (expr->value.function.isym->generic_id)
+ switch (expr->value.function.isym->id)
{
case GFC_ISYM_NONE:
gcc_unreachable ();
gfc_conv_intrinsic_trim (se, expr);
break;
+ case GFC_ISYM_SC_KIND:
+ gfc_conv_intrinsic_sc_kind (se, expr);
+ break;
+
case GFC_ISYM_SI_KIND:
gfc_conv_intrinsic_si_kind (se, expr);
break;
gfc_conv_intrinsic_exponent (se, expr);
break;
- case GFC_ISYM_SPACING:
- gfc_conv_intrinsic_spacing (se, expr);
- break;
-
- case GFC_ISYM_RRSPACING:
- gfc_conv_intrinsic_rrspacing (se, expr);
- break;
-
case GFC_ISYM_SCAN:
- gfc_conv_intrinsic_scan (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_scan;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_scan_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_VERIFY:
- gfc_conv_intrinsic_verify (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_verify;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_verify_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_ALLOCATED:
gfc_conv_associated(se, expr);
break;
+ case GFC_ISYM_SAME_TYPE_AS:
+ gfc_conv_same_type_as (se, expr);
+ break;
+
case GFC_ISYM_ABS:
gfc_conv_intrinsic_abs (se, expr);
break;
case GFC_ISYM_ADJUSTL:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustl;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustl_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_ADJUSTR:
- gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
+ if (expr->ts.kind == 1)
+ fndecl = gfor_fndecl_adjustr;
+ else if (expr->ts.kind == 4)
+ fndecl = gfor_fndecl_adjustr_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_adjust (se, expr, fndecl);
break;
case GFC_ISYM_AIMAG:
break;
case GFC_ISYM_AINT:
- gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
+ gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
break;
case GFC_ISYM_ALL:
break;
case GFC_ISYM_ANINT:
- gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
+ gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
+ break;
+
+ case GFC_ISYM_AND:
+ gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
break;
case GFC_ISYM_ANY:
gfc_conv_intrinsic_btest (se, expr);
break;
+ case GFC_ISYM_BGE:
+ gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
+ break;
+
+ case GFC_ISYM_BGT:
+ gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
+ break;
+
+ case GFC_ISYM_BLE:
+ gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
+ break;
+
+ case GFC_ISYM_BLT:
+ gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
+ break;
+
case GFC_ISYM_ACHAR:
case GFC_ISYM_CHAR:
gfc_conv_intrinsic_char (se, expr);
gfc_conv_intrinsic_conversion (se, expr);
break;
- /* Integer conversions are handled seperately to make sure we get the
+ /* Integer conversions are handled separately to make sure we get the
correct rounding mode. */
case GFC_ISYM_INT:
- gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
+ case GFC_ISYM_INT2:
+ case GFC_ISYM_INT8:
+ case GFC_ISYM_LONG:
+ gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
break;
case GFC_ISYM_NINT:
- gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
+ gfc_conv_intrinsic_int (se, expr, RND_ROUND);
break;
case GFC_ISYM_CEILING:
- gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
+ gfc_conv_intrinsic_int (se, expr, RND_CEIL);
break;
case GFC_ISYM_FLOOR:
- gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
+ gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
break;
case GFC_ISYM_MOD:
break;
case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
- gfc_conv_intrinsic_iargc (se, expr, TRUE);
+ gfc_conv_intrinsic_iargc (se, expr);
+ break;
+
+ case GFC_ISYM_COMPLEX:
+ gfc_conv_intrinsic_cmplx (se, expr, 1);
break;
case GFC_ISYM_CONJG:
gfc_conv_intrinsic_count (se, expr);
break;
+ case GFC_ISYM_CTIME:
+ gfc_conv_intrinsic_ctime (se, expr);
+ break;
+
case GFC_ISYM_DIM:
gfc_conv_intrinsic_dim (se, expr);
break;
+ case GFC_ISYM_DOT_PRODUCT:
+ gfc_conv_intrinsic_dot_product (se, expr);
+ break;
+
case GFC_ISYM_DPROD:
gfc_conv_intrinsic_dprod (se, expr);
break;
+ case GFC_ISYM_DSHIFTL:
+ gfc_conv_intrinsic_dshift (se, expr, true);
+ break;
+
+ case GFC_ISYM_DSHIFTR:
+ gfc_conv_intrinsic_dshift (se, expr, false);
+ break;
+
+ case GFC_ISYM_FDATE:
+ gfc_conv_intrinsic_fdate (se, expr);
+ break;
+
+ case GFC_ISYM_FRACTION:
+ gfc_conv_intrinsic_fraction (se, expr);
+ break;
+
+ case GFC_ISYM_IALL:
+ gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
+ break;
+
case GFC_ISYM_IAND:
gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
break;
+ case GFC_ISYM_IANY:
+ gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
+ break;
+
case GFC_ISYM_IBCLR:
gfc_conv_intrinsic_singlebitop (se, expr, 0);
break;
break;
case GFC_ISYM_IARGC:
- gfc_conv_intrinsic_iargc (se, expr, FALSE);
+ gfc_conv_intrinsic_iargc (se, expr);
break;
case GFC_ISYM_IEOR:
break;
case GFC_ISYM_INDEX:
- gfc_conv_intrinsic_index (se, expr);
+ kind = expr->value.function.actual->expr->ts.kind;
+ if (kind == 1)
+ fndecl = gfor_fndecl_string_index;
+ else if (kind == 4)
+ fndecl = gfor_fndecl_string_index_char4;
+ else
+ gcc_unreachable ();
+
+ gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
break;
case GFC_ISYM_IOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
+ case GFC_ISYM_IPARITY:
+ gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
+ break;
+
+ case GFC_ISYM_IS_IOSTAT_END:
+ gfc_conv_has_intvalue (se, expr, LIBERROR_END);
+ break;
+
+ case GFC_ISYM_IS_IOSTAT_EOR:
+ gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
+ break;
+
+ case GFC_ISYM_ISNAN:
+ gfc_conv_intrinsic_isnan (se, expr);
+ break;
+
+ case GFC_ISYM_LSHIFT:
+ gfc_conv_intrinsic_shift (se, expr, false, false);
+ break;
+
+ case GFC_ISYM_RSHIFT:
+ gfc_conv_intrinsic_shift (se, expr, true, true);
+ break;
+
+ case GFC_ISYM_SHIFTA:
+ gfc_conv_intrinsic_shift (se, expr, true, true);
+ break;
+
+ case GFC_ISYM_SHIFTL:
+ gfc_conv_intrinsic_shift (se, expr, false, false);
+ break;
+
+ case GFC_ISYM_SHIFTR:
+ gfc_conv_intrinsic_shift (se, expr, true, false);
+ break;
+
case GFC_ISYM_ISHFT:
gfc_conv_intrinsic_ishft (se, expr);
break;
gfc_conv_intrinsic_ishftc (se, expr);
break;
+ case GFC_ISYM_LEADZ:
+ gfc_conv_intrinsic_leadz (se, expr);
+ break;
+
+ case GFC_ISYM_TRAILZ:
+ gfc_conv_intrinsic_trailz (se, expr);
+ break;
+
+ case GFC_ISYM_POPCNT:
+ gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
+ break;
+
+ case GFC_ISYM_POPPAR:
+ gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
+ break;
+
case GFC_ISYM_LBOUND:
gfc_conv_intrinsic_bound (se, expr, 0);
break;
+ case GFC_ISYM_LCOBOUND:
+ conv_intrinsic_cobound (se, expr);
+ break;
+
+ case GFC_ISYM_TRANSPOSE:
+ /* The scalarizer has already been set up for reversed dimension access
+ order ; now we just get the argument value normally. */
+ gfc_conv_expr (se, expr->value.function.actual->expr);
+ break;
+
case GFC_ISYM_LEN:
gfc_conv_intrinsic_len (se, expr);
break;
gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
break;
+ case GFC_ISYM_MASKL:
+ gfc_conv_intrinsic_mask (se, expr, 1);
+ break;
+
+ case GFC_ISYM_MASKR:
+ gfc_conv_intrinsic_mask (se, expr, 0);
+ break;
+
case GFC_ISYM_MAX:
- gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
+ if (expr->ts.type == BT_CHARACTER)
+ gfc_conv_intrinsic_minmax_char (se, expr, 1);
+ else
+ gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
break;
case GFC_ISYM_MAXLOC:
gfc_conv_intrinsic_merge (se, expr);
break;
+ case GFC_ISYM_MERGE_BITS:
+ gfc_conv_intrinsic_merge_bits (se, expr);
+ break;
+
case GFC_ISYM_MIN:
- gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
+ if (expr->ts.type == BT_CHARACTER)
+ gfc_conv_intrinsic_minmax_char (se, expr, -1);
+ else
+ gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
break;
case GFC_ISYM_MINLOC:
gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
break;
+ case GFC_ISYM_NEAREST:
+ gfc_conv_intrinsic_nearest (se, expr);
+ break;
+
+ case GFC_ISYM_NORM2:
+ gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
+ break;
+
case GFC_ISYM_NOT:
gfc_conv_intrinsic_not (se, expr);
break;
+ case GFC_ISYM_OR:
+ gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
+ break;
+
+ case GFC_ISYM_PARITY:
+ gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
+ break;
+
case GFC_ISYM_PRESENT:
gfc_conv_intrinsic_present (se, expr);
break;
case GFC_ISYM_PRODUCT:
- gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
+ gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
+ break;
+
+ case GFC_ISYM_RRSPACING:
+ gfc_conv_intrinsic_rrspacing (se, expr);
+ break;
+
+ case GFC_ISYM_SET_EXPONENT:
+ gfc_conv_intrinsic_set_exponent (se, expr);
+ break;
+
+ case GFC_ISYM_SCALE:
+ gfc_conv_intrinsic_scale (se, expr);
break;
case GFC_ISYM_SIGN:
gfc_conv_intrinsic_size (se, expr);
break;
+ case GFC_ISYM_SIZEOF:
+ case GFC_ISYM_C_SIZEOF:
+ gfc_conv_intrinsic_sizeof (se, expr);
+ break;
+
+ case GFC_ISYM_STORAGE_SIZE:
+ gfc_conv_intrinsic_storage_size (se, expr);
+ break;
+
+ case GFC_ISYM_SPACING:
+ gfc_conv_intrinsic_spacing (se, expr);
+ break;
+
case GFC_ISYM_SUM:
- gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
+ gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
break;
case GFC_ISYM_TRANSFER:
- gfc_conv_intrinsic_transfer (se, expr);
+ if (se->ss && se->ss->useflags)
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ else
+ gfc_conv_intrinsic_transfer (se, expr);
+ break;
+
+ case GFC_ISYM_TTYNAM:
+ gfc_conv_intrinsic_ttynam (se, expr);
break;
case GFC_ISYM_UBOUND:
gfc_conv_intrinsic_bound (se, expr, 1);
break;
- case GFC_ISYM_DOT_PRODUCT:
- case GFC_ISYM_MATMUL:
- case GFC_ISYM_IRAND:
- case GFC_ISYM_RAND:
+ case GFC_ISYM_UCOBOUND:
+ conv_intrinsic_cobound (se, expr);
+ break;
+
+ case GFC_ISYM_XOR:
+ gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
+ break;
+
+ case GFC_ISYM_LOC:
+ gfc_conv_intrinsic_loc (se, expr);
+ break;
+
+ case GFC_ISYM_THIS_IMAGE:
+ /* For num_images() == 1, handle as LCOBOUND. */
+ if (expr->value.function.actual->expr
+ && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+ conv_intrinsic_cobound (se, expr);
+ else
+ trans_this_image (se, expr);
+ break;
+
+ case GFC_ISYM_IMAGE_INDEX:
+ trans_image_index (se, expr);
+ break;
+
+ case GFC_ISYM_NUM_IMAGES:
+ trans_num_images (se);
+ break;
+
+ case GFC_ISYM_ACCESS:
+ case GFC_ISYM_CHDIR:
+ case GFC_ISYM_CHMOD:
+ case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
- case GFC_ISYM_SECOND:
+ case GFC_ISYM_EXTENDS_TYPE_OF:
+ case GFC_ISYM_FGET:
+ case GFC_ISYM_FGETC:
+ case GFC_ISYM_FNUM:
+ case GFC_ISYM_FPUT:
+ case GFC_ISYM_FPUTC:
+ case GFC_ISYM_FSTAT:
+ case GFC_ISYM_FTELL:
case GFC_ISYM_GETCWD:
case GFC_ISYM_GETGID:
case GFC_ISYM_GETPID:
case GFC_ISYM_GETUID:
+ case GFC_ISYM_HOSTNM:
+ case GFC_ISYM_KILL:
+ case GFC_ISYM_IERRNO:
+ case GFC_ISYM_IRAND:
+ case GFC_ISYM_ISATTY:
+ case GFC_ISYM_JN2:
+ case GFC_ISYM_LINK:
+ case GFC_ISYM_LSTAT:
+ case GFC_ISYM_MALLOC:
+ case GFC_ISYM_MATMUL:
+ case GFC_ISYM_MCLOCK:
+ case GFC_ISYM_MCLOCK8:
+ case GFC_ISYM_RAND:
+ case GFC_ISYM_RENAME:
+ case GFC_ISYM_SECOND:
+ case GFC_ISYM_SECNDS:
+ case GFC_ISYM_SIGNAL:
+ case GFC_ISYM_STAT:
+ case GFC_ISYM_SYMLNK:
case GFC_ISYM_SYSTEM:
+ case GFC_ISYM_TIME:
+ case GFC_ISYM_TIME8:
case GFC_ISYM_UMASK:
case GFC_ISYM_UNLINK:
+ case GFC_ISYM_YN2:
gfc_conv_intrinsic_funcall (se, expr);
break;
+ case GFC_ISYM_EOSHIFT:
+ case GFC_ISYM_PACK:
+ case GFC_ISYM_RESHAPE:
+ /* For those, expr->rank should always be >0 and thus the if above the
+ switch should have matched. */
+ gcc_unreachable ();
+ break;
+
default:
gfc_conv_intrinsic_lib_function (se, expr);
break;
}
+static gfc_ss *
+walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
+{
+ gfc_ss *arg_ss, *tmp_ss;
+ gfc_actual_arglist *arg;
+
+ arg = expr->value.function.actual;
+
+ gcc_assert (arg->expr);
+
+ arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
+ gcc_assert (arg_ss != gfc_ss_terminator);
+
+ for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
+ {
+ if (tmp_ss->type != GFC_SS_SCALAR
+ && tmp_ss->type != GFC_SS_REFERENCE)
+ {
+ int tmp_dim;
+ gfc_ss_info *info;
+
+ info = &tmp_ss->data.info;
+ gcc_assert (info->dimen == 2);
+
+ /* We just invert dimensions. */
+ tmp_dim = info->dim[0];
+ info->dim[0] = info->dim[1];
+ info->dim[1] = tmp_dim;
+ }
+
+ /* Stop when tmp_ss points to the last valid element of the chain... */
+ if (tmp_ss->next == gfc_ss_terminator)
+ break;
+ }
+
+ /* ... so that we can attach the rest of the chain to it. */
+ tmp_ss->next = ss;
+
+ return arg_ss;
+}
+
+
+static gfc_ss *
+walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
+{
+
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return walk_inline_intrinsic_transpose (ss, expr);
+
+ default:
+ gcc_unreachable ();
+ }
+ gcc_unreachable ();
+}
+
+
/* This generates code to execute before entering the scalarization loop.
Currently does nothing. */
void
gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
{
- switch (ss->expr->value.function.isym->generic_id)
+ switch (ss->expr->value.function.isym->id)
{
case GFC_ISYM_UBOUND:
case GFC_ISYM_LBOUND:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_LCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
break;
default:
}
-/* UBOUND and LBOUND intrinsics with one parameter are expanded into code
- inside the scalarization loop. */
+/* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
+ are expanded into code inside the scalarization loop. */
static gfc_ss *
gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
-
/* The two argument version returns a scalar. */
if (expr->value.function.actual->next->expr)
return ss;
- newss = gfc_get_ss ();
- newss->type = GFC_SS_INTRINSIC;
- newss->expr = expr;
- newss->next = ss;
-
- return newss;
+ return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
}
static gfc_ss *
gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
{
- gfc_ss *newss;
-
gcc_assert (expr->rank > 0);
+ return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
+}
+
+
+/* Return whether the function call expression EXPR will be expanded
+ inline by gfc_conv_intrinsic_function. */
+
+bool
+gfc_inline_intrinsic_function_p (gfc_expr *expr)
+{
+ if (!expr->value.function.isym)
+ return false;
- newss = gfc_get_ss ();
- newss->type = GFC_SS_FUNCTION;
- newss->expr = expr;
- newss->next = ss;
- newss->data.info.dimen = expr->rank;
+ switch (expr->value.function.isym->id)
+ {
+ case GFC_ISYM_TRANSPOSE:
+ return true;
- return newss;
+ default:
+ return false;
+ }
}
-/* Returns nonzero if the specified intrinsic function call maps directly to a
+/* Returns nonzero if the specified intrinsic function call maps directly to
an external library call. Should only be used for functions that return
arrays. */
gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
gcc_assert (expr->rank > 0);
- switch (expr->value.function.isym->generic_id)
+ if (gfc_inline_intrinsic_function_p (expr))
+ return 0;
+
+ switch (expr->value.function.isym->id)
{
case GFC_ISYM_ALL:
case GFC_ISYM_ANY:
case GFC_ISYM_COUNT:
+ case GFC_ISYM_JN2:
+ case GFC_ISYM_IANY:
+ case GFC_ISYM_IALL:
+ case GFC_ISYM_IPARITY:
case GFC_ISYM_MATMUL:
case GFC_ISYM_MAXLOC:
case GFC_ISYM_MAXVAL:
case GFC_ISYM_MINLOC:
case GFC_ISYM_MINVAL:
+ case GFC_ISYM_NORM2:
+ case GFC_ISYM_PARITY:
case GFC_ISYM_PRODUCT:
case GFC_ISYM_SUM:
case GFC_ISYM_SHAPE:
case GFC_ISYM_SPREAD:
- case GFC_ISYM_TRANSPOSE:
+ case GFC_ISYM_YN2:
/* Ignore absent optional parameters. */
return 1;
gcc_assert (isym);
if (isym->elemental)
- return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
+ return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
+ GFC_SS_SCALAR);
if (expr->rank == 0)
return ss;
+ if (gfc_inline_intrinsic_function_p (expr))
+ return walk_inline_intrinsic_function (ss, expr);
+
if (gfc_is_intrinsic_libcall (expr))
return gfc_walk_intrinsic_libfunc (ss, expr);
/* Special cases. */
- switch (isym->generic_id)
+ switch (isym->id)
{
case GFC_ISYM_LBOUND:
+ case GFC_ISYM_LCOBOUND:
case GFC_ISYM_UBOUND:
+ case GFC_ISYM_UCOBOUND:
+ case GFC_ISYM_THIS_IMAGE:
return gfc_walk_intrinsic_bound (ss, expr);
+ case GFC_ISYM_TRANSFER:
+ return gfc_walk_intrinsic_libfunc (ss, expr);
+
default:
/* This probably meant someone forgot to add an intrinsic to the above
- list(s) when they implemented it, or something's gone horribly wrong.
- */
- gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
- expr->value.function.name);
+ list(s) when they implemented it, or something's gone horribly
+ wrong. */
+ gcc_unreachable ();
+ }
+}
+
+
+static tree
+conv_intrinsic_atomic_def (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&atom, code->ext.actual->expr);
+ gfc_conv_expr (&value, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, atom.expr,
+ fold_convert (TREE_TYPE (atom.expr), value.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_atomic_ref (gfc_code *code)
+{
+ gfc_se atom, value;
+ stmtblock_t block;
+
+ gfc_init_se (&atom, NULL);
+ gfc_init_se (&value, NULL);
+ gfc_conv_expr (&value, code->ext.actual->expr);
+ gfc_conv_expr (&atom, code->ext.actual->next->expr);
+
+ gfc_init_block (&block);
+ gfc_add_modify (&block, value.expr,
+ fold_convert (TREE_TYPE (value.expr), atom.expr));
+ return gfc_finish_block (&block);
+}
+
+
+static tree
+conv_intrinsic_move_alloc (gfc_code *code)
+{
+ if (code->ext.actual->expr->rank == 0)
+ {
+ /* Scalar arguments: Generate pointer assignments. */
+ gfc_expr *from, *to, *deal;
+ stmtblock_t block;
+ tree tmp;
+ gfc_se se;
+
+ from = code->ext.actual->expr;
+ to = code->ext.actual->next->expr;
+
+ gfc_start_block (&block);
+
+ /* Deallocate 'TO' argument. */
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ deal = gfc_copy_expr (to);
+ if (deal->ts.type == BT_CLASS)
+ gfc_add_data_component (deal);
+ gfc_conv_expr (&se, deal);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
+ deal, deal->ts);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_free_expr (deal);
+
+ if (to->ts.type == BT_CLASS)
+ tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
+ else
+ tmp = gfc_trans_pointer_assignment (to, from);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (from->ts.type == BT_CLASS)
+ tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
+ EXEC_POINTER_ASSIGN);
+ else
+ tmp = gfc_trans_pointer_assignment (from,
+ gfc_get_null_expr (NULL));
+ gfc_add_expr_to_block (&block, tmp);
+
+ return gfc_finish_block (&block);
+ }
+ else
+ /* Array arguments: Generate library code. */
+ return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
+}
+
+
+tree
+gfc_conv_intrinsic_subroutine (gfc_code *code)
+{
+ tree res;
+
+ gcc_assert (code->resolved_isym);
+
+ switch (code->resolved_isym->id)
+ {
+ case GFC_ISYM_MOVE_ALLOC:
+ res = conv_intrinsic_move_alloc (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_DEF:
+ res = conv_intrinsic_atomic_def (code);
+ break;
+
+ case GFC_ISYM_ATOMIC_REF:
+ res = conv_intrinsic_atomic_ref (code);
+ break;
+
+ default:
+ res = NULL_TREE;
+ break;
}
+
+ return res;
}
#include "gt-fortran-trans-intrinsic.h"
OSDN Git Service
