/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
#include "config.h"
#include "system.h"
#include "coretypes.h"
-#include "tm.h"
+#include "tm.h" /* For UNITS_PER_WORD. */
#include "tree.h"
#include "ggc.h"
-#include "toplev.h"
-#include "real.h"
-#include "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_isym_id id;
/* Enum value from the "language-independent", aka C-centric, part
of gcc, or END_BUILTINS of no such value set. */
- enum built_in_function code_r4;
- enum built_in_function code_r8;
- enum built_in_function code_r10;
- enum built_in_function code_r16;
- enum built_in_function code_c4;
- enum built_in_function code_c8;
- enum built_in_function code_c10;
- enum built_in_function code_c16;
+ 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
except for atan2. */
#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
{ GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
- BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
- false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
+ 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_ ## ID ## L, BUILT_IN_C ## ID ## F, \
- BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, 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},
+ 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, END_BUILTINS, END_BUILTINS, \
+ { 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) \
+ { GFC_ISYM_NONE, 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},
+
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 libgfortran. */
LIB_FUNCTION (NONE, NULL, false)
};
+#undef OTHER_BUILTIN
#undef LIB_FUNCTION
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
-/* 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)
{
- 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 = 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;
+
+ return (i == END_BUILTINS ? NULL_TREE : built_in_decls[i]);
+}
+
+
+static tree
+builtin_decl_for_float_kind (enum built_in_function double_built_in, int kind)
+{
+ int i = gfc_validate_kind (BT_REAL, kind, false);
+ return builtin_decl_for_precision (double_built_in,
+ gfc_real_kinds[i].mode_precision);
}
-real_compnt_info;
-enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
/* Evaluate the arguments to an intrinsic function. The value
of NARGS may be less than the actual number of arguments in EXPR
/* Call the library function that will perform the conversion. */
gcc_assert (nargs >= 2);
- tmp = build_call_expr (fndecl, 3, addr, args[0], args[1]);
+ 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. */
gcc_unreachable ();
/* Now, depending on the argument type, we choose between intrinsics. */
- if (argprec == TYPE_PRECISION (float_type_node))
- fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
- else if (argprec == TYPE_PRECISION (double_type_node))
- fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
- else if (argprec == TYPE_PRECISION (long_double_type_node))
- fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
+ if (longlong)
+ fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
else
- gcc_unreachable ();
+ fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
- return fold_convert (restype, build_call_expr (fn, 1, arg));
+ return fold_convert (restype, build_call_expr_loc (input_location,
+ fn, 1, arg));
}
tree arg[2];
tree tmp;
tree cond;
+ tree decl;
mpfr_t huge;
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 RND_ROUND:
- switch (kind)
- {
- case 4:
- n = BUILT_IN_ROUNDF;
- break;
-
- case 8:
- n = BUILT_IN_ROUND;
- break;
-
- case 10:
- case 16:
- n = BUILT_IN_ROUNDL;
- break;
- }
+ decl = builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
break;
case RND_TRUNC:
- switch (kind)
- {
- case 4:
- n = BUILT_IN_TRUNCF;
- break;
-
- case 8:
- n = BUILT_IN_TRUNC;
- break;
-
- case 10:
- case 16:
- n = BUILT_IN_TRUNCL;
- break;
- }
+ decl = builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
break;
default:
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 = build_call_expr (tmp, 1, arg[0]);
+ se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
return;
}
gfc_intrinsic_map_t *m;
/* 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->code_r4 != END_BUILTINS)
- m->real4_decl = built_in_decls[m->code_r4];
- if (m->code_r8 != END_BUILTINS)
- m->real8_decl = built_in_decls[m->code_r8];
- if (m->code_r10 != END_BUILTINS)
- m->real10_decl = built_in_decls[m->code_r10];
- if (m->code_r16 != END_BUILTINS)
- m->real16_decl = built_in_decls[m->code_r16];
- if (m->code_c4 != END_BUILTINS)
- m->complex4_decl = built_in_decls[m->code_c4];
- if (m->code_c8 != END_BUILTINS)
- m->complex8_decl = built_in_decls[m->code_c8];
- if (m->code_c10 != END_BUILTINS)
- m->complex10_decl = built_in_decls[m->code_c10];
- if (m->code_c16 != END_BUILTINS)
- m->complex16_decl = built_in_decls[m->code_c16];
+ if (m->float_built_in != END_BUILTINS)
+ m->real4_decl = built_in_decls[m->float_built_in];
+ if (m->complex_float_built_in != END_BUILTINS)
+ m->complex4_decl = built_in_decls[m->complex_float_built_in];
+ if (m->double_built_in != END_BUILTINS)
+ m->real8_decl = built_in_decls[m->double_built_in];
+ if (m->complex_double_built_in != END_BUILTINS)
+ m->complex8_decl = built_in_decls[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 = built_in_decls[m->long_double_built_in];
+ if (m->complex_long_double_built_in != END_BUILTINS)
+ m->complex10_decl = built_in_decls[m->complex_long_double_built_in];
+
+ /* For now, we assume that if real(kind=16) exists, it is long double.
+ Later, we will deal with __float128 and break this assumption. */
+ if (m->long_double_built_in != END_BUILTINS)
+ m->real16_decl = built_in_decls[m->long_double_built_in];
+ if (m->complex_long_double_built_in != END_BUILTINS)
+ m->complex16_decl = built_in_decls[m->complex_long_double_built_in];
}
}
if (m->libm_name)
{
- if (ts->kind == 4)
+ 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 (ts->kind == 8)
+ 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);
+ 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
- {
- gcc_assert (ts->kind == 10 || ts->kind == 16);
- snprintf (name, sizeof (name), "%s%s%s",
- ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
- }
+ gcc_unreachable ();
}
else
{
}
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);
+ fndecl = build_decl (input_location,
+ FUNCTION_DECL, get_identifier (name), type);
/* Mark the decl as external. */
DECL_EXTERNAL (fndecl) = 1;
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;
rettype = TREE_TYPE (TREE_TYPE (fndecl));
fndecl = build_addr (fndecl, current_function_decl);
- se->expr = build_call_array (rettype, fndecl, num_args, args);
+ se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
}
static void
gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
{
- tree arg, type, res, tmp;
- int frexp;
+ tree arg, type, res, tmp, frexp;
- switch (expr->value.function.actual->expr->ts.kind)
- {
- case 4:
- frexp = BUILT_IN_FREXPF;
- break;
- case 8:
- frexp = BUILT_IN_FREXP;
- break;
- case 10:
- case 16:
- frexp = BUILT_IN_FREXPL;
- break;
- default:
- gcc_unreachable ();
- }
+ frexp = 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 (built_in_decls[frexp], 2, arg,
- gfc_build_addr_expr (NULL_TREE, res));
+ 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);
tree type;
tree bound;
tree tmp;
- tree cond, cond1, cond2, cond3, cond4, size;
+ tree cond, cond1, cond3, cond4, size;
tree ubound;
tree lbound;
gfc_se argse;
gfc_ss *ss;
gfc_array_spec * as;
- gfc_ref *ref;
arg = expr->value.function.actual;
arg2 = arg->next;
}
}
- ubound = gfc_conv_descriptor_ubound (desc, bound);
- lbound = gfc_conv_descriptor_lbound (desc, bound);
+ ubound = gfc_conv_descriptor_ubound_get (desc, bound);
+ lbound = gfc_conv_descriptor_lbound_get (desc, bound);
- /* Follow any component references. */
- if (arg->expr->expr_type == EXPR_VARIABLE
- || arg->expr->expr_type == EXPR_CONSTANT)
- {
- as = arg->expr->symtree->n.sym->as;
- for (ref = arg->expr->ref; ref; ref = ref->next)
- {
- switch (ref->type)
- {
- case REF_COMPONENT:
- as = ref->u.c.component->as;
- continue;
-
- case REF_SUBSTRING:
- continue;
-
- case REF_ARRAY:
- {
- switch (ref->u.ar.type)
- {
- case AR_ELEMENT:
- case AR_SECTION:
- case AR_UNKNOWN:
- as = NULL;
- continue;
-
- case AR_FULL:
- break;
- }
- break;
- }
- }
- }
- }
- else
- as = NULL;
+ as = gfc_get_full_arrayspec_from_expr (arg->expr);
/* 13.14.53: Result value for LBOUND
if (as)
{
- tree stride = gfc_conv_descriptor_stride (desc, bound);
+ tree stride = gfc_conv_descriptor_stride_get (desc, bound);
cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
- cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
gfc_index_zero_node);
static void
gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
{
- tree arg;
- int n;
+ tree arg, cabs;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
break;
case BT_COMPLEX:
- switch (expr->ts.kind)
- {
- case 4:
- n = BUILT_IN_CABSF;
- break;
- case 8:
- n = BUILT_IN_CABS;
- break;
- case 10:
- case 16:
- n = BUILT_IN_CABSL;
- break;
- default:
- gcc_unreachable ();
- }
- se->expr = build_call_expr (built_in_decls[n], 1, arg);
+ cabs = builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
+ se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
break;
default:
tree tmp;
tree test;
tree test2;
+ tree fmod;
mpfr_t huge;
int n, ikind;
tree args[2];
break;
case BT_REAL:
- n = END_BUILTINS;
+ fmod = NULL_TREE;
/* Check if we have a builtin fmod. */
- switch (expr->ts.kind)
- {
- case 4:
- n = BUILT_IN_FMODF;
- break;
-
- case 8:
- n = BUILT_IN_FMOD;
- break;
-
- case 10:
- case 16:
- n = BUILT_IN_FMODL;
- break;
-
- default:
- break;
- }
+ fmod = builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
/* Use it if it exists. */
- if (n != END_BUILTINS)
+ if (fmod != NULL_TREE)
{
- tmp = build_addr (built_in_decls[n], current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
+ 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;
test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
thereby avoiding another division and retaining the accuracy
of the builtin function. */
- if (n != END_BUILTINS && modulo)
+ if (fmod != NULL_TREE && modulo)
{
tree zero = gfc_build_const (type, integer_zero_node);
tmp = gfc_evaluate_now (se->expr, &se->pre);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
if (expr->ts.type == BT_REAL)
{
- switch (expr->ts.kind)
+ tree abs;
+
+ tmp = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+ abs = 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;
- case 10:
- case 16:
- tmp = built_in_decls[BUILT_IN_COPYSIGNL];
- break;
- default:
- gcc_unreachable ();
+ tree cond, zero;
+ zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
+ se->expr = fold_build3 (COND_EXPR, TREE_TYPE (args[0]), cond,
+ build_call_expr (abs, 1, args[0]),
+ build_call_expr (tmp, 2, args[0], args[1]));
}
- se->expr = build_call_expr (tmp, 2, args[0], args[1]);
+ else
+ se->expr = build_call_expr_loc (input_location, tmp, 2,
+ args[0], args[1]);
return;
}
args[1] = gfc_build_addr_expr (NULL_TREE, len);
fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
+ 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);
cond = fold_build2 (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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
args = (tree *) alloca (sizeof (tree) * num_args);
var = gfc_create_var (pchar_type_node, "pstr");
- len = gfc_create_var (gfc_get_int_type (4), "len");
+ 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 (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
+ 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);
cond = fold_build2 (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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
args = (tree *) alloca (sizeof (tree) * num_args);
var = gfc_create_var (pchar_type_node, "pstr");
- len = gfc_create_var (gfc_get_int_type (4), "len");
+ 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 (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
+ 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);
cond = fold_build2 (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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
/* 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 tmp;
tree mvar;
if (argexpr->expr->expr_type == EXPR_VARIABLE
&& argexpr->expr->symtree->n.sym->attr.optional
&& TREE_CODE (val) == INDIRECT_REF)
- cond = fold_build2
- (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
- build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
+ 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;
to help performance of programs that don't rely on IEEE semantics. */
if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
{
- isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
+ isnan = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_ISNAN], 1, mvar);
tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
fold_convert (boolean_type_node, isnan));
}
- tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
+ 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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp,
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->pre, tmp);
argexpr = argexpr->next;
/* Make the function call. */
fndecl = build_addr (function, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
nargs + 4, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
- tree append_args;
+ VEC(tree,gc) *append_args;
gcc_assert (!se->ss || se->ss->expr == expr);
/* 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_TREE;
+ append_args = NULL;
if (expr->value.function.isym->id == GFC_ISYM_MATMUL
&& sym->ts.type != BT_LOGICAL)
{
gemm_fndecl = gfor_fndecl_zgemm;
}
- append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
- append_args = gfc_chainon_list
- (append_args, build_int_cst
- (cint, gfc_option.blas_matmul_limit));
- append_args = gfc_chainon_list (append_args,
- gfc_build_addr_expr (NULL_TREE,
- gemm_fndecl));
+ 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 = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
- append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
- append_args = gfc_chainon_list (append_args, null_pointer_node);
+ 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_function_call (se, sym, expr->value.function.actual, append_args);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
gfc_free (sym);
}
}
*/
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;
gfc_add_block_to_block (&body, &arrayse.pre);
tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
build_int_cst (TREE_TYPE (arrayse.expr), 0));
- tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
+ 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);
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)
{
tree resvar;
tree type;
/* 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_block_to_block (&block, &loop.post);
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));
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&se->pre, &block);
}
}
+/* 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;
tree limit;
tree type;
tree tmp;
+ tree cond;
tree elsetmp;
tree ifbody;
tree offset;
+ tree nonempty;
+ tree lab1, lab2;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ 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 (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, 0);
+ if (HONOR_INFINITIES (DECL_MODE (limit)))
+ {
+ REAL_VALUE_TYPE real;
+ real_inf (&real);
+ tmp = build_real (TREE_TYPE (limit), real);
+ }
+ else
+ tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
+ arrayexpr->ts.kind, 0);
break;
case BT_INTEGER:
possible value is HUGE in both cases. */
if (op == GT_EXPR)
tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
- gfc_add_modify (&se->pre, limit, tmp);
-
if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
tmp = fold_build2 (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);
gfc_add_ss_to_loop (&loop, arrayss);
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 (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. */
- gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
+ 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 (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;
+ }
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_index_one_node, loop.from[0]);
else
tmp = gfc_index_one_node;
-
+
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 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock2, pos, tmp);
+ ifbody2 = gfc_finish_block (&ifblock2);
+ cond = fold_build2 (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 (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 or pos is still zero and the value
- equal to the limit. */
- tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- fold_build2 (EQ_EXPR, boolean_type_node,
- pos, gfc_index_zero_node),
- fold_build2 (EQ_EXPR, boolean_type_node,
- arrayse.expr, limit));
- tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- fold_build2 (op, boolean_type_node,
- arrayse.expr, limit), tmp);
- 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 (op == GT_EXPR ? GE_EXPR : LE_EXPR,
+ boolean_type_node, arrayse.expr, limit);
+ else
+ cond = fold_build2 (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 (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 (PLUS_EXPR, TREE_TYPE (pos),
+ loop.loopvar[0], offset);
+ gfc_add_modify (&ifblock, pos, tmp);
+
+ ifbody = gfc_finish_block (&ifblock);
+
+ cond = fold_build2 (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);
+ 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)
{
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, 0);
+ 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:
-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);
+ {
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+ if (huge_cst)
+ huge_cst = fold_build1 (NEGATE_EXPR, TREE_TYPE (huge_cst), huge_cst);
+ }
if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
+ 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 (GT_EXPR, boolean_type_node, nonempty,
+ gfc_index_zero_node);
+ }
+ maskss = NULL;
+ }
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_conv_ss_startstride (&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 (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_mark_ss_chain_used (maskss, 1);
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 (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 (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 (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 (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 (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 = fold_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 (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 (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 (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);
+ if (fast)
+ {
+ tmp = fold_build3 (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 (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.post);
tmp = gfc_finish_block (&block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ 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);
}
/* Generate code to perform the specified operation. */
static void
-gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree args[2];
tree args[2];
tree type;
tree tmp;
- int op;
+ enum tree_code op;
gfc_conv_intrinsic_function_args (se, expr, args, 2);
type = TREE_TYPE (args[0]);
default:
gcc_unreachable ();
}
- se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
+ 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)
tree leadz;
tree bit_size;
tree tmp;
- int arg_kind;
- int i, n, s;
+ 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? */
- arg_kind = expr->value.function.actual->expr->ts.kind;
- i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
- switch (arg_kind)
+ if (argsize <= INT_TYPE_SIZE)
{
- case 1:
- case 2:
- case 4:
- arg_type = unsigned_type_node;
- n = BUILT_IN_CLZ;
- break;
-
- case 8:
- arg_type = long_unsigned_type_node;
- n = BUILT_IN_CLZL;
- break;
-
- case 16:
- arg_type = long_long_unsigned_type_node;
- n = BUILT_IN_CLZLL;
- break;
-
- default:
- gcc_unreachable ();
+ arg_type = unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZ];
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZL];
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CLZLL];
+ }
+ else
+ {
+ gcc_assert (argsize == 128);
+ arg_type = gfc_build_uint_type (argsize);
+ func = gfor_fndecl_clz128;
}
- /* Convert the actual argument to the proper argument type for the built-in
+ /* 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);
result_type = gfc_get_int_type (gfc_default_integer_kind);
/* Compute LEADZ for the case i .ne. 0. */
- s = TYPE_PRECISION (arg_type) - gfc_integer_kinds[i].bit_size;
- tmp = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+ s = TYPE_PRECISION (arg_type) - argsize;
+ tmp = fold_convert (result_type, build_call_expr (func, 1, arg));
leadz = fold_build2 (MINUS_EXPR, result_type,
tmp, build_int_cst (result_type, s));
/* Build BIT_SIZE. */
- bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+ bit_size = build_int_cst (result_type, argsize);
- /* ??? For some combinations of targets and integer kinds, the condition
- can be avoided if CLZ_DEFINED_VALUE_AT_ZERO is used. Later. */
cond = fold_build2 (EQ_EXPR, boolean_type_node,
arg, build_int_cst (arg_type, 0));
se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, leadz);
tree result_type;
tree trailz;
tree bit_size;
- int arg_kind;
- int i, n;
+ tree func;
+ int argsize;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
+ argsize = TYPE_PRECISION (TREE_TYPE (arg));
- /* Which variant of __builtin_clz* should we call? */
- arg_kind = expr->value.function.actual->expr->ts.kind;
- i = gfc_validate_kind (BT_INTEGER, arg_kind, false);
- switch (expr->ts.kind)
+ /* Which variant of __builtin_ctz* should we call? */
+ if (argsize <= INT_TYPE_SIZE)
{
- case 1:
- case 2:
- case 4:
- arg_type = unsigned_type_node;
- n = BUILT_IN_CTZ;
- break;
-
- case 8:
- arg_type = long_unsigned_type_node;
- n = BUILT_IN_CTZL;
- break;
-
- case 16:
- arg_type = long_long_unsigned_type_node;
- n = BUILT_IN_CTZLL;
- break;
-
- default:
- gcc_unreachable ();
+ arg_type = unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZ];
+ }
+ else if (argsize <= LONG_TYPE_SIZE)
+ {
+ arg_type = long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZL];
+ }
+ else if (argsize <= LONG_LONG_TYPE_SIZE)
+ {
+ arg_type = long_long_unsigned_type_node;
+ func = built_in_decls[BUILT_IN_CTZLL];
+ }
+ else
+ {
+ gcc_assert (argsize == 128);
+ arg_type = gfc_build_uint_type (argsize);
+ func = gfor_fndecl_ctz128;
}
- /* Convert the actual argument to the proper argument type for the built-in
+ /* 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);
result_type = gfc_get_int_type (gfc_default_integer_kind);
/* Compute TRAILZ for the case i .ne. 0. */
- trailz = fold_convert (result_type, build_call_expr (built_in_decls[n], 1, arg));
+ trailz = fold_convert (result_type, build_call_expr_loc (input_location,
+ func, 1, arg));
/* Build BIT_SIZE. */
- bit_size = build_int_cst (result_type, gfc_integer_kinds[i].bit_size);
+ bit_size = build_int_cst (result_type, argsize);
- /* ??? For some combinations of targets and integer kinds, the condition
- can be avoided if CTZ_DEFINED_VALUE_AT_ZERO is used. Later. */
cond = fold_build2 (EQ_EXPR, boolean_type_node,
arg, build_int_cst (arg_type, 0));
se->expr = fold_build3 (COND_EXPR, result_type, cond, bit_size, trailz);
unsigned cur_pos;
gfc_actual_arglist* arg;
gfc_symbol* sym;
- tree append_args;
+ VEC(tree,gc) *append_args;
/* Find the two arguments given as position. */
cur_pos = 0;
/* If we do have type CHARACTER and the optional argument is really absent,
append a dummy 0 as string length. */
- append_args = NULL_TREE;
+ 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 = gfc_chainon_list (append_args, dummy);
+ 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_function_call (se, sym, expr->value.function.actual, append_args);
+ gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
+ append_args);
gfc_free (sym);
}
&& (sym->result == sym))
decl = gfc_get_fake_result_decl (sym, 0);
- len = sym->ts.cl->backend_decl;
+ len = sym->ts.u.cl->backend_decl;
gcc_assert (len);
break;
}
else
gcc_unreachable ();
- se->expr = build_call_expr (fndecl, 2, args[0], args[1]);
+ se->expr = build_call_expr_loc (input_location,
+ fndecl, 2, args[0], args[1]);
se->expr = convert (type, se->expr);
}
args[4] = convert (logical4_type_node, args[4]);
fndecl = build_addr (function, current_function_decl);
- se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ se->expr = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
5, args);
se->expr = convert (type, se->expr);
args[1] = fold_build1 (NOP_EXPR, pchartype, args[1]);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_fold_indirect_ref (args[1]);
+ se->expr = build_fold_indirect_ref_loc (input_location,
+ args[1]);
se->expr = convert (type, se->expr);
}
tree arg;
gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
- se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
+ se->expr = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_ISNAN], 1, arg);
STRIP_TYPE_NOPS (se->expr);
se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
static void
gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
{
- tree arg, type, tmp;
- int frexp;
+ tree arg, type, tmp, frexp;
- switch (expr->ts.kind)
- {
- case 4:
- frexp = BUILT_IN_FREXPF;
- break;
- case 8:
- frexp = BUILT_IN_FREXP;
- break;
- case 10:
- case 16:
- frexp = BUILT_IN_FREXPL;
- break;
- default:
- gcc_unreachable ();
- }
+ frexp = 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 (built_in_decls[frexp], 2,
- fold_convert (type, arg),
- gfc_build_addr_expr (NULL_TREE, tmp));
+ 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 (INF, dir);
+ 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;
- int nextafter, copysign, inf;
+ tree args[2], type, tmp, nextafter, copysign, huge_val;
- switch (expr->ts.kind)
- {
- case 4:
- nextafter = BUILT_IN_NEXTAFTERF;
- copysign = BUILT_IN_COPYSIGNF;
- inf = BUILT_IN_INFF;
- break;
- case 8:
- nextafter = BUILT_IN_NEXTAFTER;
- copysign = BUILT_IN_COPYSIGN;
- inf = BUILT_IN_INF;
- break;
- case 10:
- case 16:
- nextafter = BUILT_IN_NEXTAFTERL;
- copysign = BUILT_IN_COPYSIGNL;
- inf = BUILT_IN_INFL;
- break;
- default:
- gcc_unreachable ();
- }
+ nextafter = builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
+ copysign = builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
+ huge_val = builtin_decl_for_float_kind (BUILT_IN_HUGE_VAL, expr->ts.kind);
type = gfc_typenode_for_spec (&expr->ts);
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- tmp = build_call_expr (built_in_decls[copysign], 2,
- build_call_expr (built_in_decls[inf], 0),
- fold_convert (type, args[1]));
- se->expr = build_call_expr (built_in_decls[nextafter], 2,
- fold_convert (type, args[0]), tmp);
+ tmp = build_call_expr_loc (input_location, copysign, 2,
+ build_call_expr_loc (input_location, huge_val, 0),
+ 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);
}
gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
{
tree arg, type, prec, emin, tiny, res, e;
- tree cond, tmp;
- int frexp, scalbn, k;
+ tree cond, tmp, frexp, scalbn;
+ int k;
stmtblock_t block;
k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
- switch (expr->ts.kind)
- {
- case 4:
- frexp = BUILT_IN_FREXPF;
- scalbn = BUILT_IN_SCALBNF;
- break;
- case 8:
- frexp = BUILT_IN_FREXP;
- scalbn = BUILT_IN_SCALBN;
- break;
- case 10:
- case 16:
- frexp = BUILT_IN_FREXPL;
- scalbn = BUILT_IN_SCALBNL;
- break;
- default:
- gcc_unreachable ();
- }
+ frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = 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);
/* Build the block for s /= 0. */
gfc_start_block (&block);
- tmp = build_call_expr (built_in_decls[frexp], 2, arg,
- gfc_build_addr_expr (NULL_TREE, e));
+ 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 (MINUS_EXPR, integer_type_node, e, prec);
gfc_add_modify (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
- tmp, emin));
+ tmp, emin));
- tmp = build_call_expr (built_in_decls[scalbn], 2,
+ 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);
static void
gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
{
- tree arg, type, e, x, cond, stmt, tmp;
- int frexp, scalbn, fabs, prec, k;
+ 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;
- switch (expr->ts.kind)
- {
- case 4:
- frexp = BUILT_IN_FREXPF;
- scalbn = BUILT_IN_SCALBNF;
- fabs = BUILT_IN_FABSF;
- break;
- case 8:
- frexp = BUILT_IN_FREXP;
- scalbn = BUILT_IN_SCALBN;
- fabs = BUILT_IN_FABS;
- break;
- case 10:
- case 16:
- frexp = BUILT_IN_FREXPL;
- scalbn = BUILT_IN_SCALBNL;
- fabs = BUILT_IN_FABSL;
- break;
- default:
- gcc_unreachable ();
- }
+
+ frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
+ fabs = 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);
e = gfc_create_var (integer_type_node, NULL);
x = gfc_create_var (type, NULL);
gfc_add_modify (&se->pre, x,
- build_call_expr (built_in_decls[fabs], 1, arg));
+ build_call_expr_loc (input_location, fabs, 1, arg));
gfc_start_block (&block);
- tmp = build_call_expr (built_in_decls[frexp], 2, arg,
- gfc_build_addr_expr (NULL_TREE, e));
+ 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 (MINUS_EXPR, integer_type_node,
build_int_cst (NULL_TREE, prec), e);
- tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
+ 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 (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 ());
+ 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);
static void
gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
{
- tree args[2], type;
- int scalbn;
+ tree args[2], type, scalbn;
- switch (expr->ts.kind)
- {
- case 4:
- scalbn = BUILT_IN_SCALBNF;
- break;
- case 8:
- scalbn = BUILT_IN_SCALBN;
- break;
- case 10:
- case 16:
- scalbn = BUILT_IN_SCALBNL;
- break;
- default:
- gcc_unreachable ();
- }
+ scalbn = 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);
- se->expr = build_call_expr (built_in_decls[scalbn], 2,
- fold_convert (type, args[0]),
- fold_convert (integer_type_node, args[1]));
+ 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);
}
static void
gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
{
- tree args[2], type, tmp;
- int frexp, scalbn;
+ tree args[2], type, tmp, frexp, scalbn;
- switch (expr->ts.kind)
- {
- case 4:
- frexp = BUILT_IN_FREXPF;
- scalbn = BUILT_IN_SCALBNF;
- break;
- case 8:
- frexp = BUILT_IN_FREXP;
- scalbn = BUILT_IN_SCALBN;
- break;
- case 10:
- case 16:
- frexp = BUILT_IN_FREXPL;
- scalbn = BUILT_IN_SCALBNL;
- break;
- default:
- gcc_unreachable ();
- }
+ frexp = builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
+ scalbn = 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 (built_in_decls[frexp], 2,
- fold_convert (type, args[0]),
- gfc_build_addr_expr (NULL_TREE, tmp));
- se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
- fold_convert (integer_type_node, args[1]));
+ 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);
}
arg1 = gfc_evaluate_now (argse.expr, &se->pre);
/* Build the call to size0. */
- fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
+ fncall0 = build_call_expr_loc (input_location,
+ gfor_fndecl_size0, 1, arg1);
actual = actual->next;
{
tree tmp;
/* Build the call to size1. */
- fncall1 = build_call_expr (gfor_fndecl_size1, 2,
+ fncall1 = build_call_expr_loc (input_location,
+ gfor_fndecl_size1, 2,
arg1, argse.expr);
gfc_init_se (&argse, NULL);
{
tree ubound, lbound;
- arg1 = build_fold_indirect_ref (arg1);
- ubound = gfc_conv_descriptor_ubound (arg1, argse.expr);
- lbound = gfc_conv_descriptor_lbound (arg1, argse.expr);
+ 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 (MINUS_EXPR, gfc_array_index_type,
ubound, lbound);
se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, se->expr,
gfc_expr *arg;
gfc_ss *ss;
gfc_se argse;
- tree source;
tree source_bytes;
tree type;
tree tmp;
if (ss == gfc_ss_terminator)
{
+ if (arg->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg, "$data");
+
gfc_conv_expr_reference (&argse, arg);
- source = argse.expr;
- type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
/* Obtain the source word length. */
if (arg->ts.type == BT_CHARACTER)
source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
argse.want_pointer = 0;
gfc_conv_expr_descriptor (&argse, arg, ss);
- source = gfc_conv_descriptor_data_get (argse.expr);
type = gfc_get_element_type (TREE_TYPE (argse.expr));
/* Obtain the argument's word length. */
{
tree idx;
idx = gfc_rank_cst[n];
- lower = gfc_conv_descriptor_lbound (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
upper, lower);
tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
}
+static void
+gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
+{
+ 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);
+ ss = gfc_walk_expr (arg);
+ result_type = gfc_get_int_type (expr->ts.kind);
+
+ if (ss == gfc_ss_terminator)
+ {
+ if (arg->ts.type == BT_CLASS)
+ {
+ gfc_add_component_ref (arg, "$vptr");
+ gfc_add_component_ref (arg, "$size");
+ 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
+ tmp = fold_convert (result_type, size_in_bytes (type));
+
+done:
+ se->expr = fold_build2 (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)
+gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
{
tree args[4];
se->expr
= gfc_build_compare_string (args[0], args[1], args[2], args[3],
- expr->value.function.actual->expr->ts.kind);
+ expr->value.function.actual->expr->ts.kind,
+ op);
se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
build_int_cst (TREE_TYPE (se->expr), 0));
}
var = gfc_conv_string_tmp (se, type, len);
args[0] = var;
- tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
+ 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;
tree size_bytes;
tree upper;
tree lower;
- tree stride;
tree stmt;
gfc_actual_arglist *arg;
gfc_se argse;
gfc_conv_expr_reference (&argse, arg->expr);
source = argse.expr;
- source_type = TREE_TYPE (build_fold_indirect_ref (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)
if (gfc_option.warn_array_temp)
gfc_warning ("Creating array temporary at %L", &expr->where);
- source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
+ source = build_call_expr_loc (input_location,
+ gfor_fndecl_in_pack, 1, tmp);
source = gfc_evaluate_now (source, &argse.pre);
/* Free the temporary. */
gfc_init_block (&block);
tmp = gfc_conv_array_data (argse.expr);
tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
- tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ 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);
tree idx;
idx = gfc_rank_cst[n];
gfc_add_modify (&argse.pre, source_bytes, tmp);
- stride = gfc_conv_descriptor_stride (argse.expr, idx);
- lower = gfc_conv_descriptor_lbound (argse.expr, idx);
- upper = gfc_conv_descriptor_ubound (argse.expr, idx);
+ lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
+ upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
upper, lower);
gfc_add_modify (&argse.pre, extent, tmp);
if (ss == gfc_ss_terminator)
{
gfc_conv_expr_reference (&argse, arg->expr);
- mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
+ argse.expr));
}
else
{
gfc_init_se (&argse, NULL);
gfc_conv_expr_reference (&argse, arg->expr);
tmp = convert (gfc_array_index_type,
- build_fold_indirect_ref (argse.expr));
+ 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);
}
tmp = fold_convert (pvoid_type_node, tmp);
/* Use memcpy to do the transfer. */
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY],
3,
tmp,
fold_convert (pvoid_type_node, source),
scalar_transfer:
extent = fold_build2 (MIN_EXPR, gfc_array_index_type,
dest_word_len, source_bytes);
+ extent = fold_build2 (MAX_EXPR, gfc_array_index_type,
+ extent, gfc_index_zero_node);
if (expr->ts.type == BT_CHARACTER)
{
tmp = gfc_call_malloc (&block, tmp, dest_word_len);
gfc_add_modify (&block, tmpdecl,
fold_convert (TREE_TYPE (ptr), tmp));
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmpdecl),
fold_convert (pvoid_type_node, ptr),
extent);
/* Use memcpy to do the transfer. */
tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMCPY], 3,
fold_convert (pvoid_type_node, tmp),
fold_convert (pvoid_type_node, ptr),
extent);
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_get (arg1se.expr);
+ if (ss1 == gfc_ss_terminator)
+ {
+ /* Allocatable scalar. */
+ arg1se.want_pointer = 1;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg1->expr, "$data");
+ 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 (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_init_se (&arg1se, NULL);
gfc_init_se (&arg2se, NULL);
arg1 = expr->value.function.actual;
+ if (arg1->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg1->expr, "$data");
arg2 = arg1->next;
ss1 = gfc_walk_expr (arg1->expr);
else
{
/* An optional target. */
+ if (arg2->expr->ts.type == BT_CLASS)
+ gfc_add_component_ref (arg2->expr, "$data");
ss2 = gfc_walk_expr (arg2->expr);
nonzero_charlen = NULL_TREE;
if (arg1->expr->ts.type == BT_CHARACTER)
nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
- arg1->expr->ts.cl->backend_decl,
+ arg1->expr->ts.u.cl->backend_decl,
integer_zero_node);
if (ss1 == gfc_ss_terminator)
present. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp = gfc_conv_descriptor_stride (arg1se.expr,
+ tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
gfc_rank_cst[arg1->expr->rank - 1]);
nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
build_int_cst (TREE_TYPE (tmp), 0));
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);
- se->expr = build_call_expr (gfor_fndecl_associated, 2,
+ 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 (TRUTH_AND_EXPR, boolean_type_node,
}
+/* Generate code for the SAME_TYPE_AS intrinsic.
+ Generate inline code that directly checks the vindices. */
+
+static void
+gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
+{
+ gfc_expr *a, *b;
+ gfc_se se1, se2;
+ tree tmp;
+
+ 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)
+ {
+ gfc_add_component_ref (a, "$vptr");
+ gfc_add_component_ref (a, "$hash");
+ }
+ 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)
+ {
+ gfc_add_component_ref (b, "$vptr");
+ gfc_add_component_ref (b, "$hash");
+ }
+ else if (b->ts.type == BT_DERIVED)
+ b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+ b->ts.u.derived->hash_value);
+
+ gfc_conv_expr (&se1, a);
+ gfc_conv_expr (&se2, b);
+
+ tmp = fold_build2 (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 SELECTED_CHAR_KIND (NAME) intrinsic function. */
static void
tree args[2];
gfc_conv_intrinsic_function_args (se, expr, args, 2);
- se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
+ 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);
}
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
+ se->expr = build_call_expr_loc (input_location,
+ gfor_fndecl_si_kind, 1, arg);
se->expr = fold_convert (type, se->expr);
}
gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
{
gfc_actual_arglist *actual;
- tree args, type;
+ 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);
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);
}
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
+ se->expr = build_call_expr_loc_vec (input_location,
+ gfor_fndecl_sr_kind, args);
se->expr = fold_convert (type, se->expr);
}
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_get_int_type (4), "len");
+ 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, len);
gcc_unreachable ();
fndecl = build_addr (function, current_function_decl);
- tmp = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
+ tmp = build_call_array_loc (input_location,
+ TREE_TYPE (TREE_TYPE (function)), fndecl,
num_args, args);
gfc_add_expr_to_block (&se->pre, tmp);
cond = fold_build2 (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 ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
dlen = fold_build2 (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.cl);
+ 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:
tmp = build1_v (GOTO_EXPR, exit_label);
TREE_USED (exit_label) = 1;
tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
- build_empty_stmt ());
+ build_empty_stmt (input_location));
gfc_add_expr_to_block (&body, tmp);
/* Call memmove (dest + (i*slen*size), src, slen*size). */
tmp = fold_build2 (POINTER_PLUS_EXPR, pvoid_type_node,
fold_convert (pvoid_type_node, dest),
fold_convert (sizetype, tmp));
- tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
+ tmp = build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MEMMOVE], 3, tmp, src,
fold_build2 (MULT_EXPR, size_type_node, slen,
fold_convert (size_type_node, size)));
gfc_add_expr_to_block (&body, tmp);
/* Call the library function. This always returns an INTEGER(4). */
fndecl = gfor_fndecl_iargc;
- tmp = build_call_expr (fndecl, 0);
+ tmp = build_call_expr_loc (input_location,
+ fndecl, 0);
/* Convert it to the required type. */
type = gfc_typenode_for_spec (&expr->ts);
if (ss == gfc_ss_terminator)
gfc_conv_expr_reference (se, arg_expr);
else
- gfc_conv_array_parameter (se, arg_expr, ss, 1, NULL, NULL);
+ 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,
void
gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{
- gfc_intrinsic_sym *isym;
const char *name;
int lib, kind;
tree fndecl;
- isym = expr->value.function.isym;
-
name = &expr->value.function.name[2];
if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
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;
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_CHMOD:
case GFC_ISYM_DTIME:
case GFC_ISYM_ETIME:
+ case GFC_ISYM_EXTENDS_TYPE_OF:
case GFC_ISYM_FGET:
case GFC_ISYM_FGETC:
case GFC_ISYM_FNUM:
}
}
+
+tree
+gfc_conv_intrinsic_move_alloc (gfc_code *code)
+{
+ if (code->ext.actual->expr->rank == 0)
+ {
+ /* Scalar arguments: Generate pointer assignments. */
+ gfc_expr *from, *to;
+ stmtblock_t block;
+ tree tmp;
+
+ from = code->ext.actual->expr;
+ to = code->ext.actual->next->expr;
+
+ gfc_start_block (&block);
+
+ 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);
+}
+
+
#include "gt-fortran-trans-intrinsic.h"