/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
+ Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
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. */
+Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
+02110-1301, USA. */
/* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
#include "system.h"
#include "coretypes.h"
#include "tree.h"
-#include <stdio.h>
-#include <string.h>
#include "ggc.h"
#include "toplev.h"
#include "real.h"
/* 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 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;
/* 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 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, \
+ 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},
#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 }
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
+ true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
+ NULL_TREE, 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 }
+ { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, 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 }
static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
{
/* Functions in libgfortran. */
LIBF_FUNCTION (FRACTION, "fraction", false),
LIBF_FUNCTION (NEAREST, "nearest", false),
+ LIBF_FUNCTION (RRSPACING, "rrspacing", false),
LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
+ LIBF_FUNCTION (SPACING, "spacing", false),
/* End the list. */
LIBF_FUNCTION (NONE, NULL, false)
};
#undef DEFINE_MATH_BUILTIN
#undef DEFINE_MATH_BUILTIN_C
-#undef BUILT_IN_FUNCTION
#undef LIBM_FUNCTION
#undef LIBF_FUNCTION
}
real_compnt_info;
+enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
/* Evaluate the arguments to an intrinsic function. */
+/* FIXME: This function and its callers should be rewritten so that it's
+ not necessary to cons up a list to hold the arguments. */
static tree
gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
{
gfc_actual_arglist *actual;
- tree args;
+ gfc_expr *e;
+ gfc_intrinsic_arg *formal;
gfc_se argse;
+ tree args;
args = NULL_TREE;
- for (actual = expr->value.function.actual; actual; actual = actual->next)
+ formal = expr->value.function.isym->formal;
+
+ for (actual = expr->value.function.actual; actual; actual = actual->next,
+ formal = formal ? formal->next : NULL)
{
- /* Skip ommitted optional arguments. */
- if (!actual->expr)
+ e = actual->expr;
+ /* Skip omitted optional arguments. */
+ if (!e)
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);
}
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);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
se->expr = convert (type, arg);
}
-
-/* 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
cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
- convert (type, integer_one_node));
+ build_int_cst (type, 1));
tmp = build3 (COND_EXPR, type, cond, intval, tmp);
return tmp;
}
neg = build_real (argtype, r);
tmp = gfc_build_const (argtype, integer_zero_node);
- cond = fold (build2 (GT_EXPR, boolean_type_node, arg, tmp));
+ cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
- 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));
+ 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);
}
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:
+ case RND_ROUND:
return build_round_expr (pblock, arg, type);
default:
- return build1 (op, type, arg);
+ gcc_assert (op == RND_TRUNC);
+ return build1 (FIX_TRUNC_EXPR, type, arg);
}
}
/* 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;
/* We have builtin functions for some cases. */
switch (op)
{
- case FIX_ROUND_EXPR:
+ case RND_ROUND:
switch (kind)
{
case 4:
case 8:
n = BUILT_IN_ROUND;
break;
+
+ case 10:
+ case 16:
+ n = BUILT_IN_ROUNDL;
+ break;
}
break;
- case FIX_FLOOR_EXPR:
+ case RND_TRUNC:
switch (kind)
{
case 4:
- n = BUILT_IN_FLOORF;
+ n = BUILT_IN_TRUNCF;
break;
case 8:
- n = BUILT_IN_FLOOR;
+ n = BUILT_IN_TRUNC;
+ break;
+
+ case 10:
+ case 16:
+ n = BUILT_IN_TRUNCL;
break;
}
+ break;
+
+ default:
+ gcc_unreachable ();
}
/* Evaluate the argument. */
if (n != END_BUILTINS)
{
tmp = built_in_decls[n];
- se->expr = gfc_build_function_call (tmp, arg);
+ se->expr = build_function_call_expr (tmp, arg);
return;
}
/* 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;
/* Add GCC builtin functions. */
for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; 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->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];
}
}
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" : "");
+ if (ts->kind == 4)
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
+ else if (ts->kind == 8)
+ snprintf (name, sizeof (name), "%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name);
+ else
+ {
+ gcc_assert (ts->kind == 10 || ts->kind == 16);
+ snprintf (name, sizeof (name), "%s%s%s",
+ ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
+ }
}
else
{
/* Get the decl and generate the call. */
args = gfc_conv_intrinsic_function_args (se, expr);
fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
- se->expr = gfc_build_function_call (fndecl, args);
+ se->expr = build_function_call_expr (fndecl, args);
}
/* Generate code for EXPONENT(X) intrinsic function. */
case 8:
fndecl = gfor_fndecl_math_exponent8;
break;
+ case 10:
+ fndecl = gfor_fndecl_math_exponent10;
+ break;
+ case 16:
+ fndecl = gfor_fndecl_math_exponent16;
+ break;
default:
gcc_unreachable ();
}
- se->expr = gfc_build_function_call (fndecl, args);
+ se->expr = build_function_call_expr (fndecl, args);
}
/* Evaluate a single upper or lower bound. */
tree type;
tree bound;
tree tmp;
- tree cond;
+ tree cond, cond1, cond2, cond3, cond4, size;
+ tree ubound;
+ tree lbound;
gfc_se argse;
gfc_ss *ss;
- int i;
+ gfc_array_spec * as;
+ gfc_ref *ref;
- gfc_init_se (&argse, NULL);
arg = expr->value.function.actual;
arg2 = arg->next;
gcc_assert (se->ss->expr == expr);
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]));
+ bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
+ se->loop->from[0]);
}
else
{
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));
+ bound = fold_build2 (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);
- argse.want_pointer = 0;
+ 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);
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)));
+ 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 (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)));
+ cond = fold_build2 (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 (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);
+ 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_msg_fault, &se->pre, &expr->where);
}
}
- if (upper)
- se->expr = gfc_conv_descriptor_ubound(desc, bound);
+ ubound = gfc_conv_descriptor_ubound (desc, bound);
+ lbound = gfc_conv_descriptor_lbound (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;
+ }
+ }
+ }
+ }
+ }
+ else
+ as = NULL;
+
+ /* 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 (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);
+ cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
+
+ cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
+ gfc_index_zero_node);
+ cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
+
+ if (upper)
+ {
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ ubound, gfc_index_zero_node);
+ }
+ else
+ {
+ if (as->type == AS_ASSUMED_SIZE)
+ cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
+ build_int_cst (TREE_TYPE (bound),
+ arg->expr->rank - 1));
+ else
+ cond = boolean_false_node;
+
+ cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
+ cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
+
+ se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ lbound, gfc_index_one_node);
+ }
+ }
else
- se->expr = gfc_conv_descriptor_lbound(desc, bound);
+ {
+ if (upper)
+ {
+ size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
+ se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
+ gfc_index_one_node);
+ }
+ else
+ se->expr = gfc_index_one_node;
+ }
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
case 8:
n = BUILT_IN_CABS;
break;
+ case 10:
+ case 16:
+ n = BUILT_IN_CABSL;
+ break;
default:
gcc_unreachable ();
}
- se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
+ se->expr = build_function_call_expr (built_in_decls[n], args);
break;
default:
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 (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
tree type;
tree itype;
tree tmp;
- tree zero;
tree test;
tree test2;
mpfr_t huge;
- int n;
+ int n, ikind;
arg = gfc_conv_intrinsic_function_args (se, expr);
- arg2 = TREE_VALUE (TREE_CHAIN (arg));
- arg = TREE_VALUE (arg);
- type = TREE_TYPE (arg);
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);
+ arg2 = TREE_VALUE (TREE_CHAIN (arg));
+ arg = TREE_VALUE (arg);
+ type = TREE_TYPE (arg);
+
+ if (modulo)
+ se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
+ else
+ se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
break;
case BT_REAL:
- /* Real values we have to do the hard way. */
+ n = END_BUILTINS;
+ /* 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;
+ }
+
+ /* Use it if it exists. */
+ if (n != END_BUILTINS)
+ {
+ tmp = built_in_decls[n];
+ se->expr = build_function_call_expr (tmp, arg);
+ if (modulo == 0)
+ return;
+ }
+
+ arg2 = TREE_VALUE (TREE_CHAIN (arg));
+ arg = TREE_VALUE (arg);
+ type = TREE_TYPE (arg);
+
arg = gfc_evaluate_now (arg, &se->pre);
arg2 = gfc_evaluate_now (arg2, &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 (n != END_BUILTINS && modulo)
+ {
+ tree zero = gfc_build_const (type, integer_zero_node);
+ tmp = gfc_evaluate_now (se->expr, &se->pre);
+ test = build2 (LT_EXPR, boolean_type_node, arg, zero);
+ test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero);
+ test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
+ test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
+ test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+ test = gfc_evaluate_now (test, &se->pre);
+ se->expr = build3 (COND_EXPR, type, test,
+ build2 (PLUS_EXPR, type, tmp, arg2), tmp);
+ return;
+ }
+
+ /* If we do not have a built_in fmod, the calculation is going to
+ have to be done longhand. */
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 = 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);
+ 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);
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);
-
- se->expr = build3 (COND_EXPR, type, test, se->expr,
- build2 (PLUS_EXPR, type, se->expr, arg2));
- }
}
/* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
/* 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
tree arg;
tree arg2;
tree type;
- tree zero;
- tree testa;
- tree testb;
-
arg = gfc_conv_intrinsic_function_args (se, expr);
if (expr->ts.type == BT_REAL)
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 ();
}
- se->expr = fold (gfc_build_function_call (tmp, arg));
+ se->expr = build_function_call_expr (tmp, arg);
return;
}
+ /* Having excluded floating point types, we know we are now dealing
+ with signed integer types. */
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));
+ /* Arg is used multiple times below. */
+ arg = gfc_evaluate_now (arg, &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 (BIT_XOR_EXPR, type, arg, arg2);
+ tmp = fold_build2 (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 (BIT_XOR_EXPR, type,
+ fold_build2 (PLUS_EXPR, type, arg, tmp),
+ tmp);
}
}
+static void
+gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
+{
+ tree var;
+ tree len;
+ tree tmp;
+ tree arglist;
+ tree type;
+ tree cond;
+ tree gfc_int8_type_node = gfc_get_int_type (8);
+
+ type = build_pointer_type (gfc_character1_type_node);
+ var = gfc_create_var (type, "pstr");
+ len = gfc_create_var (gfc_int8_type_node, "len");
+
+ tmp = gfc_conv_intrinsic_function_args (se, expr);
+ arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+ arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = build_function_call_expr (gfor_fndecl_ctime, arglist);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = 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 ());
+ 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 arglist;
+ tree type;
+ tree cond;
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+
+ type = build_pointer_type (gfc_character1_type_node);
+ var = gfc_create_var (type, "pstr");
+ len = gfc_create_var (gfc_int4_type_node, "len");
+
+ tmp = gfc_conv_intrinsic_function_args (se, expr);
+ arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+ arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = build_function_call_expr (gfor_fndecl_fdate, arglist);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = 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 ());
+ 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 arglist;
+ tree type;
+ tree cond;
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+
+ type = build_pointer_type (gfc_character1_type_node);
+ var = gfc_create_var (type, "pstr");
+ len = gfc_create_var (gfc_int4_type_node, "len");
+
+ tmp = gfc_conv_intrinsic_function_args (se, expr);
+ arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var));
+ arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = 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 ());
+ 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, ...)
{
limit = convert (type, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
- limit = gfc_evaluate_now(limit, &se->pre);
+ limit = gfc_evaluate_now (limit, &se->pre);
mvar = gfc_create_var (type, "M");
elsecase = build2_v (MODIFY_EXPR, mvar, limit);
/* Only evaluate the argument once. */
if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
- val = gfc_evaluate_now(val, &se->pre);
+ val = gfc_evaluate_now (val, &se->pre);
thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
}
-/* Create a symbol node for this intrinsic. The symbol form the frontend
- is for the generic name. */
+/* 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)
gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
{
gfc_symbol *sym;
+ tree 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);
+
+ /* 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;
+ if (expr->value.function.isym->generic_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 = 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));
+ }
+ 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);
+ }
+ }
+
+ gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
gfc_free (sym);
}
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 = 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 ());
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_expr (&se->pre, resvar, build_int_cst (type, 0));
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
gfc_start_scalarized_body (&loop, &body);
tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
- convert (TREE_TYPE (resvar), integer_one_node));
+ build_int_cst (TREE_TYPE (resvar), 1));
tmp = build2_v (MODIFY_EXPR, resvar, tmp);
gfc_init_se (&arrayse, NULL);
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
- if (maskexpr)
+ if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
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);
+
+ /* 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 ());
+ 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 = 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_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
+gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
{
+ tree resvar;
+ tree type;
stmtblock_t body;
stmtblock_t block;
- stmtblock_t ifblock;
- tree limit;
- tree type;
tree tmp;
- tree ifbody;
- tree cond;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
- gfc_ss *arrayss;
- gfc_ss *maskss;
- gfc_se arrayse;
- gfc_se maskse;
- gfc_expr *arrayexpr;
- gfc_expr *maskexpr;
- tree pos;
- int n;
+ gfc_ss *arrayss1, *arrayss2;
+ gfc_se arrayse1, arrayse2;
+ gfc_expr *arrayexpr1, *arrayexpr2;
- if (se->ss)
- {
- gfc_conv_intrinsic_funcall (se, expr);
- return;
- }
+ type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
- pos = gfc_create_var (gfc_array_index_type, "pos");
- type = gfc_typenode_for_spec (&expr->ts);
+ 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);
- /* Walk the arguments. */
+ gfc_add_modify_expr (&se->pre, resvar, tmp);
+
+ /* Walk argument #1. */
actual = expr->value.function.actual;
- arrayexpr = actual->expr;
- arrayss = gfc_walk_expr (arrayexpr);
- gcc_assert (arrayss != gfc_ss_terminator);
+ arrayexpr1 = actual->expr;
+ arrayss1 = gfc_walk_expr (arrayexpr1);
+ gcc_assert (arrayss1 != gfc_ss_terminator);
- actual = actual->next->next;
- gcc_assert (actual);
- maskexpr = actual->expr;
- if (maskexpr)
- {
- maskss = gfc_walk_expr (maskexpr);
+ /* 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);
+
+ 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 = build1 (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 = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
+ tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
+ }
+ else
+ {
+ tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
+ tmp = build2 (PLUS_EXPR, type, resvar, tmp);
+ }
+ gfc_add_modify_expr (&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;
+}
+
+
+static void
+gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
+{
+ stmtblock_t body;
+ stmtblock_t block;
+ stmtblock_t ifblock;
+ stmtblock_t elseblock;
+ tree limit;
+ tree type;
+ tree tmp;
+ tree elsetmp;
+ tree ifbody;
+ gfc_loopinfo loop;
+ gfc_actual_arglist *actual;
+ gfc_ss *arrayss;
+ gfc_ss *maskss;
+ gfc_se arrayse;
+ gfc_se maskse;
+ gfc_expr *arrayexpr;
+ gfc_expr *maskexpr;
+ tree pos;
+ int n;
+
+ if (se->ss)
+ {
+ gfc_conv_intrinsic_funcall (se, expr);
+ return;
+ }
+
+ /* Initialize the result. */
+ pos = gfc_create_var (gfc_array_index_type, "pos");
+ type = gfc_typenode_for_spec (&expr->ts);
+
+ /* Walk the arguments. */
+ actual = expr->value.function.actual;
+ arrayexpr = actual->expr;
+ arrayss = gfc_walk_expr (arrayexpr);
+ gcc_assert (arrayss != gfc_ss_terminator);
+
+ 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);
}
else
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));
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
gfc_add_modify_expr (&se->pre, limit, tmp);
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
+
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_add_ss_to_loop (&loop, arrayss);
gcc_assert (loop.dimen == 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);
-
+ /* 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_expr (&loop.pre, pos, gfc_index_zero_node);
+
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value. */
- tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+ /* If it is a more extreme value or pos is still zero. */
+ tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
+ build2 (op, boolean_type_node, arrayse.expr, limit),
+ build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node));
tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
gfc_add_expr_to_block (&block, 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);
+ /* 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_expr (&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));
+ 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);
}
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));
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
+
+ if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
+ tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
+ build_int_cst (type, 1));
+
gfc_add_modify_expr (&se->pre, limit, tmp);
/* Walk the arguments. */
actual = actual->next->next;
gcc_assert (actual);
maskexpr = actual->expr;
- if (maskexpr)
+ if (maskexpr && maskexpr->rank != 0)
{
maskss = gfc_walk_expr (maskexpr);
gcc_assert (maskss != gfc_ss_terminator);
gfc_trans_scalarizing_loops (&loop, &body);
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ /* 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 ());
+ 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;
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- tmp = build2 (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
+ tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), 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 (NE_EXPR, boolean_type_node, tmp,
+ build_int_cst (type, 0));
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, tmp);
}
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- se->expr = fold (build2 (op, type, arg, arg2));
+ se->expr = fold_build2 (op, type, arg, arg2);
}
/* Bitwise not. */
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- tmp = fold (build2 (LSHIFT_EXPR, type,
- convert (type, integer_one_node), arg2));
+ tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2);
if (set)
op = BIT_IOR_EXPR;
else
{
op = BIT_AND_EXPR;
- tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
+ tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
}
- se->expr = fold (build2 (op, type, arg, tmp));
+ se->expr = fold_build2 (op, type, arg, tmp);
}
/* Extract a sequence of bits.
arg2 = TREE_VALUE (arg2);
type = TREE_TYPE (arg);
- mask = build_int_cst (NULL_TREE, -1);
+ mask = build_int_cst (type, -1);
mask = build2 (LSHIFT_EXPR, type, mask, arg3);
mask = build1 (BIT_NOT_EXPR, type, mask);
tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
- se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
+ se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
+}
+
+/* RSHIFT (I, SHIFT) = I >> SHIFT
+ LSHIFT (I, SHIFT) = I << SHIFT */
+static void
+gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
+{
+ tree arg;
+ tree arg2;
+
+ arg = gfc_conv_intrinsic_function_args (se, expr);
+ arg2 = TREE_VALUE (TREE_CHAIN (arg));
+ arg = TREE_VALUE (arg);
+
+ se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
+ TREE_TYPE (arg), arg, arg2);
}
-/* 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 type;
+ tree utype;
tree tmp;
+ tree width;
+ tree num_bits;
+ tree cond;
tree lshift;
tree rshift;
arg2 = TREE_VALUE (TREE_CHAIN (arg));
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
+ utype = unsigned_type_for (type);
+
+ width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
/* Left shift if positive. */
- lshift = build2 (LSHIFT_EXPR, type, arg, arg2);
+ lshift = fold_build2 (LSHIFT_EXPR, type, arg, width);
- /* 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);
+ /* 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, build2 (RSHIFT_EXPR, utype,
+ convert (utype, arg), width));
- tmp = build2 (GT_EXPR, boolean_type_node, arg2,
- convert (TREE_TYPE (arg2), integer_zero_node));
- rshift = build3 (COND_EXPR, type, tmp, lshift, rshift);
+ tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2,
+ build_int_cst (TREE_TYPE (arg2), 0));
+ tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
- /* 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);
+ /* 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 (arg2), TYPE_PRECISION (type));
+ cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
+
+ se->expr = fold_build3 (COND_EXPR, type, cond,
+ build_int_cst (type, 0), tmp);
}
/* Circular shift. AKA rotate or barrel shift. */
tree tmp;
tree lrot;
tree rrot;
+ tree zero;
arg = gfc_conv_intrinsic_function_args (se, expr);
arg2 = TREE_CHAIN (arg);
if (arg3)
{
/* Use a library function for the 3 parameter version. */
+ tree int4type = gfc_get_int_type (4);
+
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;
+ /* 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)
+ {
+ tmp = convert (int4type, TREE_VALUE (arg));
+ TREE_VALUE (arg) = tmp;
+ }
+ /* 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. */
+ TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
+ TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
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_function_call_expr (tmp, arg);
+ /* 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);
type = TREE_TYPE (arg);
/* Rotate left if positive. */
- lrot = build2 (LROTATE_EXPR, type, arg, arg2);
+ lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2);
/* Rotate right if negative. */
- tmp = build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
- rrot = build2 (RROTATE_EXPR, type, arg, tmp);
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
+ rrot = fold_build2 (RROTATE_EXPR, type, arg, 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 (arg2), 0);
+ tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero);
+ rrot = fold_build3 (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 (EQ_EXPR, boolean_type_node, arg2, zero);
+ se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot);
}
/* The length of a character string. */
gfc_symbol *sym;
gfc_se argse;
gfc_expr *arg;
+ gfc_ss *ss;
gcc_assert (!se->ss);
len = build_int_cst (NULL_TREE, 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 (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);
-
- 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;
+ decl = gfc_get_fake_result_decl (sym, 0);
+
+ len = sym->ts.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);
args = gfc_conv_intrinsic_function_args (se, expr);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
+ se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args);
se->expr = convert (type, se->expr);
}
static void
gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
+ tree logical4_type_node = gfc_get_logical_type (4);
tree args;
tree back;
tree type;
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);
+ back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
+ NULL_TREE);
TREE_CHAIN (tmp) = back;
}
else
{
back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
+ TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
}
- se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
+ se->expr = build_function_call_expr (gfor_fndecl_string_index, args);
se->expr = convert (type, se->expr);
}
arg = build1 (NOP_EXPR, pchar_type_node, arg);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = gfc_build_indirect_ref (arg);
+ se->expr = build_fold_indirect_ref (arg);
se->expr = convert (type, se->expr);
}
se->string_length = len;
}
type = TREE_TYPE (tsource);
- se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
+ se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
}
gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
{
gfc_actual_arglist *actual;
- tree args;
+ tree arg1;
tree type;
- tree fndecl;
+ tree fncall0;
+ tree fncall1;
gfc_se argse;
gfc_ss *ss;
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);
- args = gfc_chainon_list (NULL_TREE, argse.expr);
+ arg1 = gfc_evaluate_now (argse.expr, &se->pre);
+
+ /* Build the call to size0. */
+ fncall0 = build_call_expr (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_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;
+
+ /* Build the call to size1. */
+ fncall1 = build_call_expr (gfor_fndecl_size1, 2,
+ arg1, argse.expr);
+
+ /* 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;
+ 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 = build2 (NE_EXPR, boolean_type_node, argse.expr,
+ null_pointer_node);
+ tmp = gfc_evaluate_now (tmp, &se->pre);
+ se->expr = build3 (COND_EXPR, pvoid_type_node,
+ tmp, fncall1, fncall0);
+ }
+ else
+ se->expr = fncall1;
}
else
- fndecl = gfor_fndecl_size0;
+ se->expr = fncall0;
- se->expr = gfc_build_function_call (fndecl, args);
type = gfc_typenode_for_spec (&expr->ts);
se->expr = convert (type, se->expr);
}
{
tree type;
tree args;
+ tree arg2;
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);
+ arg2 = TREE_CHAIN (TREE_CHAIN (args));
+
+ se->expr = gfc_build_compare_string (TREE_VALUE (args),
+ TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2),
+ TREE_VALUE (TREE_CHAIN (arg2)));
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build2 (op, type, se->expr,
- convert (TREE_TYPE (se->expr), integer_zero_node));
+ se->expr = fold_build2 (op, type, se->expr,
+ build_int_cst (TREE_TYPE (se->expr), 0));
}
/* Generate a call to the adjustl/adjustr library function. */
var = gfc_conv_string_tmp (se, type, len);
args = tree_cons (NULL_TREE, var, args);
- tmp = gfc_build_function_call (fndecl, args);
+ tmp = build_function_call_expr (fndecl, args);
gfc_add_expr_to_block (&se->pre, tmp);
se->expr = var;
se->string_length = len;
}
+/* Array transfer statement.
+ 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_array_transfer (gfc_se * se, gfc_expr * expr)
+{
+ tree tmp;
+ 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 stride;
+ tree stmt;
+ gfc_actual_arglist *arg;
+ gfc_se argse;
+ gfc_ss *ss;
+ gfc_ss_info *info;
+ stmtblock_t block;
+ int n;
+
+ gcc_assert (se->loop);
+ info = &se->ss->data.info;
+
+ /* 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;
+ 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 (argse.expr));
+
+ /* Obtain the source word length. */
+ if (arg->expr->ts.type == BT_CHARACTER)
+ tmp = fold_convert (gfc_array_index_type, argse.string_length);
+ else
+ tmp = fold_convert (gfc_array_index_type,
+ size_in_bytes (source_type));
+ }
+ else
+ {
+ gfc_init_se (&argse, NULL);
+ 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 = build_fold_addr_expr (argse.expr);
+ source = build_call_expr (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 = build2 (NE_EXPR, boolean_type_node, source, tmp);
+ tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ 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 = fold_convert (gfc_array_index_type, 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_expr (&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);
+ tmp = build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, lower);
+ gfc_add_modify_expr (&argse.pre, extent, tmp);
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ extent, gfc_index_one_node);
+ tmp = build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, source_bytes);
+ }
+ }
+
+ gfc_add_modify_expr (&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);
+
+ if (ss == gfc_ss_terminator)
+ {
+ gfc_conv_expr_reference (&argse, arg->expr);
+ mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
+ }
+ else
+ {
+ 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));
+ }
+
+ if (arg->expr->ts.type == BT_CHARACTER)
+ {
+ tmp = fold_convert (gfc_array_index_type, 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_expr (&se->pre, dest_word_len, tmp);
+
+ /* Finally convert SIZE, if it is present. */
+ arg = arg->next;
+ size_words = gfc_create_var (gfc_array_index_type, NULL);
+
+ if (arg->expr)
+ {
+ gfc_init_se (&argse, NULL);
+ gfc_conv_expr_reference (&argse, arg->expr);
+ tmp = convert (gfc_array_index_type,
+ build_fold_indirect_ref (argse.expr));
+ gfc_add_block_to_block (&se->pre, &argse.pre);
+ gfc_add_block_to_block (&se->post, &argse.post);
+ }
+ else
+ tmp = NULL_TREE;
+
+ size_bytes = gfc_create_var (gfc_array_index_type, NULL);
+ if (tmp != NULL_TREE)
+ {
+ tmp = build2 (MULT_EXPR, gfc_array_index_type,
+ tmp, dest_word_len);
+ tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes);
+ }
+ else
+ tmp = source_bytes;
+
+ gfc_add_modify_expr (&se->pre, size_bytes, tmp);
+ gfc_add_modify_expr (&se->pre, size_words,
+ build2 (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 (MINUS_EXPR, gfc_array_index_type,
+ se->loop->to[n], se->loop->from[n]);
+ tmp = build2 (PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ tmp = build2 (MIN_EXPR, gfc_array_index_type,
+ tmp, size_words);
+ gfc_add_modify_expr (&se->pre, size_words, tmp);
+ gfc_add_modify_expr (&se->pre, size_bytes,
+ build2 (MULT_EXPR, gfc_array_index_type,
+ size_words, dest_word_len));
+ upper = build2 (PLUS_EXPR, gfc_array_index_type,
+ size_words, se->loop->from[n]);
+ upper = build2 (MINUS_EXPR, gfc_array_index_type,
+ upper, gfc_index_one_node);
+ }
+ else
+ {
+ upper = build2 (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. This is already allocated so set callee_alloc.
+ FIXME callee_alloc is not set! */
+
+ gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
+ info, mold_type, false, true, false);
+
+ /* 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 (built_in_decls[BUILT_IN_MEMCPY],
+ 3,
+ tmp,
+ fold_convert (pvoid_type_node, source),
+ size_bytes);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = info->descriptor;
+ if (expr->ts.type == BT_CHARACTER)
+ se->string_length = dest_word_len;
+}
+
+
/* Scalar transfer statement.
- TRANSFER (source, mold) = *(typeof<mould> *)&source */
+ TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
static void
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
tree type;
tree ptr;
gfc_ss *ss;
-
- gcc_assert (!se->ss);
+ tree tmpdecl, tmp;
/* Get a pointer to the source. */
arg = expr->value.function.actual;
arg = arg->next;
type = gfc_typenode_for_spec (&expr->ts);
- ptr = convert (build_pointer_type (type), ptr);
+
if (expr->ts.type == BT_CHARACTER)
{
+ ptr = convert (build_pointer_type (type), ptr);
gfc_init_se (&argse, NULL);
gfc_conv_expr (&argse, arg->expr);
gfc_add_block_to_block (&se->pre, &argse.pre);
}
else
{
- se->expr = gfc_build_indirect_ref (ptr);
+ tree moldsize;
+ tmpdecl = gfc_create_var (type, "transfer");
+ moldsize = size_in_bytes (type);
+
+ /* Use memcpy to do the transfer. */
+ tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
+ fold_convert (pvoid_type_node, tmp),
+ fold_convert (pvoid_type_node, ptr),
+ moldsize);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ se->expr = tmpdecl;
}
}
arg1se.descriptor_only = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- tmp = gfc_conv_descriptor_data (arg1se.expr);
+ tmp = gfc_conv_descriptor_data_get (arg1se.expr);
tmp = 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_se arg2se;
tree tmp2;
tree tmp;
- tree args, fndecl;
+ tree fndecl;
+ tree nonzero_charlen;
+ tree nonzero_arraylen;
gfc_ss *ss1, *ss2;
gfc_init_se (&arg1se, NULL);
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);
}
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
{
/* An optional target. */
ss2 = gfc_walk_expr (arg2->expr);
+
+ nonzero_charlen = NULL_TREE;
+ if (arg1->expr->ts.type == BT_CHARACTER)
+ nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
+ arg1->expr->ts.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);
+ gfc_add_block_to_block (&se->pre, &arg1se.pre);
+ gfc_add_block_to_block (&se->post, &arg1se.post);
tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
- se->expr = tmp;
+ tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
+ null_pointer_node);
+ se->expr = build2 (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 (arg1se.expr,
+ gfc_rank_cst[arg1->expr->rank - 1]);
+ nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
+ tmp, integer_zero_node);
+
/* 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 (fndecl, 2, arg1se.expr, arg2se.expr);
+ se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ se->expr, nonzero_arraylen);
+
}
- }
+
+ /* If target is present zero character length pointers cannot
+ be associated. */
+ if (nonzero_charlen != NULL_TREE)
+ se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
+ se->expr, nonzero_charlen);
+ }
+
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
static void
gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
+ tree logical4_type_node = gfc_get_logical_type (4);
tree args;
tree back;
tree type;
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);
+ back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
+ NULL_TREE);
TREE_CHAIN (tmp) = back;
}
else
{
back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
+ TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
}
- se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
+ se->expr = build_function_call_expr (gfor_fndecl_string_scan, args);
se->expr = convert (type, se->expr);
}
static void
gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
{
- tree gfc_logical4_type_node = gfc_get_logical_type (4);
+ tree logical4_type_node = gfc_get_logical_type (4);
tree args;
tree back;
tree type;
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);
+ back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0),
+ NULL_TREE);
TREE_CHAIN (tmp) = back;
}
else
{
back = TREE_CHAIN (tmp);
- TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
+ TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back));
}
- se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
+ se->expr = build_function_call_expr (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);
-
- return convert (result_type, call);
-}
-
-
-/* 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)
- */
-
-static void
-gfc_conv_intrinsic_spacing (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;
-
- if (expn == 0) // Denormalized case.
- {
- t1 = leadzero (frac);
- frac = frac << (t1 + 1); //Remove the first '1'.
- frac = frac >> (sedigits); //Form the fraction.
- }
-
- //fdigits is the number of fraction bits. Form the exponent.
- t = bias + fdigits;
-
- res = (t << fdigits) | frac;
- }
-*/
-
-static void
-gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
-{
- tree masktype;
- tree tmp, t1, t2, cond, cond2;
- tree one, zero;
- tree fdigits, fraction;
- real_compnt_info rcs;
-
- 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));
-
- 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);
-
- 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;
-}
/* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
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);
+ args = build_fold_addr_expr (args);
+ se->expr = build_call_expr (gfor_fndecl_si_kind, 1, args);
}
/* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
gfc_add_block_to_block (&se->post, &argse.post);
args = gfc_chainon_list (args, argse.expr);
}
- se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
+ se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
}
len = gfc_create_var (gfc_int4_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, build_fold_addr_expr (len));
arglist = gfc_chainon_list (arglist, addr);
arglist = chainon (arglist, tmp);
-
- tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
+
+ tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist);
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);
+ build_int_cst (TREE_TYPE (len), 0));
+ tmp = gfc_call_free (var);
tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
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, ncopies, dest, dlen, src, slen, ncopies_type;
+ tree type, cond, tmp, count, exit_label, n, max, largest;
+ stmtblock_t block, body;
+ int i;
+ /* Get the arguments. */
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));
+ slen = fold_convert (size_type_node, gfc_evaluate_now (TREE_VALUE (args),
+ &se->pre));
+ src = TREE_VALUE (TREE_CHAIN (args));
+ ncopies = TREE_VALUE (TREE_CHAIN (TREE_CHAIN (args)));
+ ncopies = gfc_evaluate_now (ncopies, &se->pre);
+ ncopies_type = TREE_TYPE (ncopies);
+
+ /* Check that NCOPIES is not negative. */
+ cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
+ build_int_cst (ncopies_type, 0));
+ gfc_trans_runtime_check (cond,
+ "Argument NCOPIES of REPEAT intrinsic is negative",
+ &se->pre, &expr->where);
+
+ /* 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 (EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
+ build_int_cst (ncopies_type, 0), ncopies);
+ gfc_add_modify_expr (&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 (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 (GT_EXPR, boolean_type_node,
+ fold_convert (largest, ncopies),
+ fold_convert (largest, max));
+ tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
+ build_int_cst (size_type_node, 0));
+ cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
+ cond);
+ gfc_trans_runtime_check (cond,
+ "Argument NCOPIES of REPEAT intrinsic is too large",
+ &se->pre, &expr->where);
+
+ /* Compute the destination length. */
+ dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen, ncopies);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
- var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
+ dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
- arglist = NULL_TREE;
- arglist = gfc_chainon_list (arglist, var);
- arglist = chainon (arglist, args);
- tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
+ /* Generate the code to do the repeat operation:
+ for (i = 0; i < ncopies; i++)
+ memmove (dest + (i * slen), src, slen); */
+ gfc_start_block (&block);
+ count = gfc_create_var (ncopies_type, "count");
+ gfc_add_modify_expr (&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 (GE_EXPR, boolean_type_node, count, ncopies);
+ 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 ());
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Call memmove (dest + (i*slen), src, slen). */
+ tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node, slen,
+ fold_convert (gfc_charlen_type_node, count));
+ tmp = fold_build2 (PLUS_EXPR, pchar_type_node, dest,
+ fold_convert (pchar_type_node, tmp));
+ tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
+ tmp, src, slen);
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Increment count. */
+ tmp = build2 (PLUS_EXPR, ncopies_type, count,
+ build_int_cst (TREE_TYPE (count), 1));
+ gfc_add_modify_expr (&body, count, tmp);
+
+ /* Build the loop. */
+ tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
+ gfc_add_expr_to_block (&block, tmp);
+
+ /* 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 (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;
}
+
+/* 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, 1);
+ 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_expr (&se->pre, temp_var, se->expr);
+ se->expr = temp_var;
+}
+
/* Generate code for an intrinsic function. Some map directly to library
calls, others get special handling. In some cases the name of the function
used depends on the type specifiers. */
gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
{
gfc_intrinsic_sym *isym;
- char *name;
+ const char *name;
int lib;
isym = expr->value.function.isym;
name = &expr->value.function.name[2];
- if (expr->rank > 0)
+ if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
{
lib = gfc_is_intrinsic_libcall (expr);
if (lib != 0)
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);
break;
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_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_FDATE:
+ gfc_conv_intrinsic_fdate (se, expr);
+ break;
+
case GFC_ISYM_IAND:
gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
break;
break;
case GFC_ISYM_IARGC:
- gfc_conv_intrinsic_iargc (se, expr, FALSE);
+ gfc_conv_intrinsic_iargc (se, expr);
break;
case GFC_ISYM_IEOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
break;
+ case GFC_ISYM_LSHIFT:
+ gfc_conv_intrinsic_rlshift (se, expr, 0);
+ break;
+
+ case GFC_ISYM_RSHIFT:
+ gfc_conv_intrinsic_rlshift (se, expr, 1);
+ break;
+
case GFC_ISYM_ISHFT:
gfc_conv_intrinsic_ishft (se, expr);
break;
gfc_conv_intrinsic_bound (se, expr, 0);
break;
+ case GFC_ISYM_TRANSPOSE:
+ if (se->ss && se->ss->useflags)
+ {
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+ }
+ else
+ gfc_conv_array_transpose (se, expr->value.function.actual->expr);
+ break;
+
case GFC_ISYM_LEN:
gfc_conv_intrinsic_len (se, expr);
break;
gfc_conv_intrinsic_not (se, expr);
break;
+ case GFC_ISYM_OR:
+ gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
+ break;
+
case GFC_ISYM_PRESENT:
gfc_conv_intrinsic_present (se, expr);
break;
break;
case GFC_ISYM_TRANSFER:
- gfc_conv_intrinsic_transfer (se, expr);
+ if (se->ss)
+ {
+ if (se->ss->useflags)
+ {
+ /* Access the previously obtained result. */
+ gfc_conv_tmp_array_ref (se);
+ gfc_advance_se_ss_chain (se);
+ break;
+ }
+ else
+ gfc_conv_intrinsic_array_transfer (se, expr);
+ }
+ 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_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_ACCESS:
+ case GFC_ISYM_CHDIR:
+ case GFC_ISYM_CHMOD:
case GFC_ISYM_ETIME:
- case GFC_ISYM_SECOND:
+ 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_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:
gfc_conv_intrinsic_funcall (se, expr);
break;
newss->type = GFC_SS_INTRINSIC;
newss->expr = expr;
newss->next = ss;
+ newss->data.info.dimen = 1;
return newss;
}
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;
case GFC_ISYM_UBOUND:
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.