/* Intrinsic translation
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
Contributed by Paul Brook <paul@nowt.org>
and Steven Bosscher <s.bosscher@student.tudelft.nl>
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2, or (at your option)
-any later version.
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 2, or (at your option) any later
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+along with GCC; see the file COPYING. If not, write to the Free
+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"
-#include "tree-simple.h"
+#include "tree-gimple.h"
#include "flags.h"
-#include <gmp.h>
-#include <assert.h>
#include "gfortran.h"
+#include "arith.h"
#include "intrinsic.h"
#include "trans.h"
#include "trans-const.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 DEFINE_MATH_BUILTIN(ID, NAME, NARGS) \
- { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
- NARGS == 1, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
+#define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
+ { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
+ BUILT_IN_ ## ID ## L, 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[] =
{
LIBF_FUNCTION (NONE, NULL, false)
};
#undef DEFINE_MATH_BUILTIN
+#undef DEFINE_MATH_BUILTIN_C
#undef LIBM_FUNCTION
#undef LIBF_FUNCTION
elemental functions to manipulate reals. */
typedef struct
{
- tree arg; /* Variable tree to view convert to integer. */
+ 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 bit numbers of exponent. */
- tree fdigits; /* Constant tree of bit numbers of fraction. */
+ 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. */
args = NULL_TREE;
for (actual = expr->value.function.actual; actual; actual = actual->next)
{
- /* Skip ommitted optional arguments. */
+ /* Skip omitted optional arguments. */
if (!actual->expr)
continue;
/* Evaluate the parameter. This will substitute scalarized
- references automatically. */
+ references automatically. */
gfc_init_se (&argse, se);
if (actual->expr->ts.type == BT_CHARACTER)
/* Evaluate the argument. */
type = gfc_typenode_for_spec (&expr->ts);
- assert (expr->value.function.actual->expr);
+ gcc_assert (expr->value.function.actual->expr);
arg = gfc_conv_intrinsic_function_args (se, expr);
arg = TREE_VALUE (arg);
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
intval = gfc_evaluate_now (intval, pblock);
tmp = convert (argtype, intval);
- cond = build (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
+ cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
- tmp = build (up ? PLUS_EXPR : MINUS_EXPR, type, intval, integer_one_node);
- tmp = build (COND_EXPR, type, cond, intval, tmp);
+ tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
+ 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 (build (GT_EXPR, boolean_type_node, arg, tmp));
+ cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
- tmp = fold (build (COND_EXPR, argtype, cond, pos, neg));
- tmp = fold (build (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 tree_code op)
{
switch (op)
{
/* 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 thay 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 tree_code op)
{
tree type;
tree itype;
tree arg;
tree tmp;
tree cond;
- mpf_t huge;
+ mpfr_t huge;
int n;
int kind;
case 8:
n = BUILT_IN_ROUND;
break;
+
+ case 10:
+ case 16:
+ n = BUILT_IN_ROUNDL;
+ break;
}
break;
- case FIX_FLOOR_EXPR:
+ case FIX_TRUNC_EXPR:
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. */
- assert (expr->value.function.actual->expr);
+ gcc_assert (expr->value.function.actual->expr);
arg = gfc_conv_intrinsic_function_args (se, expr);
/* Use a builtin function if one exists. */
arg = gfc_evaluate_now (arg, &se->pre);
/* Test if the value is too large to handle sensibly. */
- mpf_init (huge);
- n = gfc_validate_kind (BT_INTEGER, kind);
- mpf_set_z (huge, gfc_integer_kinds[n].huge);
- tmp = gfc_conv_mpf_to_tree (huge, kind);
- cond = build (LT_EXPR, boolean_type_node, arg, tmp);
-
- mpf_neg (huge, huge);
- tmp = gfc_conv_mpf_to_tree (huge, kind);
- tmp = build (GT_EXPR, boolean_type_node, arg, tmp);
- cond = build (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
+ gfc_set_model_kind (kind);
+ mpfr_init (huge);
+ n = gfc_validate_kind (BT_INTEGER, kind, false);
+ mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind);
+ cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
+
+ mpfr_neg (huge, huge, GFC_RND_MODE);
+ tmp = gfc_conv_mpfr_to_tree (huge, kind);
+ tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
+ cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
itype = gfc_get_int_type (kind);
tmp = build_fix_expr (&se->pre, arg, itype, op);
tmp = convert (type, tmp);
- se->expr = build (COND_EXPR, type, cond, tmp, arg);
+ se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
+ mpfr_clear (huge);
}
/* Evaluate the argument. */
type = gfc_typenode_for_spec (&expr->ts);
- assert (expr->value.function.actual->expr);
+ gcc_assert (expr->value.function.actual->expr);
arg = gfc_conv_intrinsic_function_args (se, expr);
arg = TREE_VALUE (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:
- abort ();
+ gcc_unreachable ();
}
}
else if (ts->type == BT_COMPLEX)
{
- if (!m->complex_available)
- abort ();
+ gcc_assert (m->complex_available);
switch (ts->kind)
{
case 8:
pdecl = &m->complex8_decl;
break;
+ case 10:
+ pdecl = &m->complex10_decl;
+ break;
+ case 16:
+ pdecl = &m->complex16_decl;
+ break;
default:
- abort ();
+ gcc_unreachable ();
}
}
else
- abort ();
+ gcc_unreachable ();
if (*pdecl)
return *pdecl;
if (m->libm_name)
{
- if (ts->kind != 4 && ts->kind != 8)
- abort ();
- snprintf (name, sizeof (name), "%s%s%s",
+ gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10
+ || ts->kind == 16);
+ snprintf (name, sizeof (name), "%s%s%s",
ts->type == BT_COMPLEX ? "c" : "",
m->name,
ts->kind == 4 ? "f" : "");
/* Mark it __attribute__((const)), if possible. */
TREE_READONLY (fndecl) = m->is_constant;
- rest_of_decl_compilation (fndecl, NULL, 1, 0);
+ rest_of_decl_compilation (fndecl, 1, 0);
(*pdecl) = fndecl;
return fndecl;
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:
- abort ();
+ gcc_unreachable ();
}
se->expr = gfc_build_function_call (fndecl, args);
}
/* Evaluate a single upper or lower bound. */
-/* TODO: bound intrinsic generates way too much unneccessary code. */
+/* TODO: bound intrinsic generates way too much unnecessary code. */
static void
gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
gfc_ss *ss;
int i;
- gfc_init_se (&argse, NULL);
arg = expr->value.function.actual;
arg2 = arg->next;
if (se->ss)
{
/* Create an implicit second parameter from the loop variable. */
- assert (!arg2->expr);
- assert (se->loop->dimen == 1);
- assert (se->ss->expr == expr);
+ gcc_assert (!arg2->expr);
+ gcc_assert (se->loop->dimen == 1);
+ gcc_assert (se->ss->expr == expr);
gfc_advance_se_ss_chain (se);
bound = se->loop->loopvar[0];
- bound = fold (build (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
{
/* use the passed argument. */
- assert (arg->next->expr);
+ gcc_assert (arg->next->expr);
gfc_init_se (&argse, NULL);
gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
gfc_add_block_to_block (&se->pre, &argse.pre);
bound = argse.expr;
/* Convert from one based to zero based. */
- bound = fold (build (MINUS_EXPR, gfc_array_index_type, bound,
- integer_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);
- assert (ss != gfc_ss_terminator);
- argse.want_pointer = 0;
+ gcc_assert (ss != gfc_ss_terminator);
+ gfc_init_se (&argse, NULL);
gfc_conv_expr_descriptor (&argse, arg->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
if (INTEGER_CST_P (bound))
{
- assert (TREE_INT_CST_HIGH (bound) == 0);
+ gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
i = TREE_INT_CST_LOW (bound);
- assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+ gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
}
else
{
if (flag_bounds_check)
{
bound = gfc_evaluate_now (bound, &se->pre);
- cond = fold (build (LT_EXPR, boolean_type_node, 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 (build (GE_EXPR, boolean_type_node, bound, tmp));
- cond = fold(build (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
+ 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);
}
}
{
tree args;
tree val;
- tree fndecl;
+ int n;
args = gfc_conv_intrinsic_function_args (se, expr);
- assert (args && TREE_CHAIN (args) == NULL_TREE);
+ gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
val = TREE_VALUE (args);
switch (expr->value.function.actual->expr->ts.type)
switch (expr->ts.kind)
{
case 4:
- fndecl = gfor_fndecl_math_cabsf;
+ n = BUILT_IN_CABSF;
break;
case 8:
- fndecl = gfor_fndecl_math_cabs;
+ n = BUILT_IN_CABS;
+ break;
+ case 10:
+ case 16:
+ n = BUILT_IN_CABSL;
break;
default:
- abort ();
+ gcc_unreachable ();
}
- se->expr = gfc_build_function_call (fndecl, args);
+ se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
break;
default:
- abort ();
+ gcc_unreachable ();
}
}
else
imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
- se->expr = fold (build (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;
- mpf_t huge;
+ mpfr_t huge;
int n;
arg = gfc_conv_intrinsic_function_args (se, expr);
{
case BT_INTEGER:
/* Integer case is easy, we've got a builtin op. */
- se->expr = build (TRUNC_MOD_EXPR, type, arg, arg2);
+ 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:
arg = gfc_evaluate_now (arg, &se->pre);
arg2 = gfc_evaluate_now (arg2, &se->pre);
- tmp = build (RDIV_EXPR, type, arg, arg2);
+ tmp = build2 (RDIV_EXPR, type, arg, arg2);
/* Test if the value is too large to handle sensibly. */
- mpf_init (huge);
- n = gfc_validate_kind (BT_INTEGER, expr->ts.kind);
- mpf_set_z (huge, gfc_integer_kinds[n].huge);
- test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
- test2 = build (LT_EXPR, boolean_type_node, tmp, test);
-
- mpf_neg (huge, huge);
- test = gfc_conv_mpf_to_tree (huge, expr->ts.kind);
- test = build (GT_EXPR, boolean_type_node, tmp, test);
- test2 = build (TRUTH_AND_EXPR, boolean_type_node, test, test2);
+ gfc_set_model_kind (expr->ts.kind);
+ mpfr_init (huge);
+ n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
+ 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);
+
+ mpfr_neg (huge, huge, GFC_RND_MODE);
+ test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
+ test = build2 (GT_EXPR, boolean_type_node, tmp, test);
+ test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
itype = gfc_get_int_type (expr->ts.kind);
- tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
+ if (modulo)
+ tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
+ else
+ tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
tmp = convert (type, tmp);
- tmp = build (COND_EXPR, type, test2, tmp, arg);
- tmp = build (MULT_EXPR, type, tmp, arg2);
- se->expr = build (MINUS_EXPR, type, arg, tmp);
+ tmp = build3 (COND_EXPR, type, test2, tmp, arg);
+ tmp = build2 (MULT_EXPR, type, tmp, arg2);
+ se->expr = build2 (MINUS_EXPR, type, arg, tmp);
+ mpfr_clear (huge);
break;
default:
- abort ();
- }
-
- if (modulo)
- {
- zero = gfc_build_const (type, integer_zero_node);
- /* Build !(A > 0 .xor. P > 0). */
- test = build (GT_EXPR, boolean_type_node, arg, zero);
- test2 = build (GT_EXPR, boolean_type_node, arg2, zero);
- test = build (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 = build (EQ_EXPR, boolean_type_node, arg, zero);
- test = build (TRUTH_OR_EXPR, boolean_type_node, test, test2);
-
- se->expr = build (COND_EXPR, type, test, se->expr,
- build (PLUS_EXPR, type, se->expr, arg2));
+ gcc_unreachable ();
}
}
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- val = build (MINUS_EXPR, type, arg, arg2);
+ val = build2 (MINUS_EXPR, type, arg, arg2);
val = gfc_evaluate_now (val, &se->pre);
zero = gfc_build_const (type, integer_zero_node);
- tmp = build (LE_EXPR, boolean_type_node, val, zero);
- se->expr = build (COND_EXPR, type, tmp, zero, val);
+ tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
+ se->expr = build3 (COND_EXPR, type, tmp, zero, val);
}
switch (expr->ts.kind)
{
case 4:
- tmp = gfor_fndecl_math_sign4;
+ tmp = built_in_decls[BUILT_IN_COPYSIGNF];
break;
case 8:
- tmp = gfor_fndecl_math_sign8;
+ tmp = built_in_decls[BUILT_IN_COPYSIGN];
+ break;
+ case 10:
+ case 16:
+ tmp = built_in_decls[BUILT_IN_COPYSIGNL];
break;
default:
- abort ();
+ gcc_unreachable ();
}
- se->expr = gfc_build_function_call (tmp, arg);
+ se->expr = fold (gfc_build_function_call (tmp, arg));
return;
}
type = TREE_TYPE (arg);
zero = gfc_build_const (type, integer_zero_node);
- testa = fold (build (GE_EXPR, boolean_type_node, arg, zero));
- testb = fold (build (GE_EXPR, boolean_type_node, arg2, zero));
- tmp = fold (build (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
- se->expr = fold (build (COND_EXPR, type, tmp,
- build1 (NEGATE_EXPR, type, arg), arg));
+ 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);
}
gfc_expr *arg;
arg = expr->value.function.actual->expr;
- assert (arg->expr_type == EXPR_VARIABLE);
+ gcc_assert (arg->expr_type == EXPR_VARIABLE);
se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
}
type = gfc_typenode_for_spec (&expr->ts);
arg = convert (type, arg);
arg2 = convert (type, arg2);
- se->expr = build (MULT_EXPR, type, arg, arg2);
+ se->expr = build2 (MULT_EXPR, type, arg, arg2);
}
arg = TREE_VALUE (arg);
/* We currently don't support character types != 1. */
- assert (expr->ts.kind == 1);
+ gcc_assert (expr->ts.kind == 1);
type = gfc_character1_type_node;
var = gfc_create_var (type, "char");
}
+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, gfc_build_addr_expr (NULL, var));
+ arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = gfc_build_function_call (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));
+ arglist = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ 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, gfc_build_addr_expr (NULL, var));
+ arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = gfc_build_function_call (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));
+ arglist = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ 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, gfc_build_addr_expr (NULL, var));
+ arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = gfc_build_function_call (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));
+ arglist = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ 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 = gfc_evaluate_now(limit, &se->pre);
mvar = gfc_create_var (type, "M");
- elsecase = build_v (MODIFY_EXPR, mvar, limit);
+ elsecase = build2_v (MODIFY_EXPR, mvar, limit);
for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
{
val = TREE_VALUE (arg);
if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
val = gfc_evaluate_now(val, &se->pre);
- thencase = build_v (MODIFY_EXPR, mvar, convert (type, val));
+ thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
- tmp = build (op, boolean_type_node, val, limit);
- tmp = build_v (COND_EXPR, tmp, thencase, elsecase);
+ tmp = build2 (op, boolean_type_node, val, limit);
+ tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
gfc_add_expr_to_block (&se->pre, tmp);
elsecase = build_empty_stmt ();
limit = mvar;
}
-/* 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_symbol *sym;
/* TODO: Add symbols for intrinsic function to the global namespace. */
- assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
+ gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
sym = gfc_new_symbol (expr->value.function.name, NULL);
sym->ts = expr->ts;
{
gfc_symbol *sym;
- assert (!se->ss || se->ss->expr == expr);
+ gcc_assert (!se->ss || se->ss->expr == expr);
if (se->ss)
- assert (expr->rank > 0);
+ gcc_assert (expr->rank > 0);
else
- assert (expr->rank == 0);
+ gcc_assert (expr->rank == 0);
sym = gfc_get_symbol_for_expr (expr);
gfc_conv_function_call (se, sym, expr->value.function.actual);
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
- assert (arrayss != gfc_ss_terminator);
+ gcc_assert (arrayss != gfc_ss_terminator);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
gfc_conv_expr_val (&arrayse, actual->expr);
gfc_add_block_to_block (&body, &arrayse.pre);
- tmp = build (op, boolean_type_node, arrayse.expr, integer_zero_node);
- tmp = build_v (COND_EXPR, tmp, found, build_empty_stmt ());
+ tmp = 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, integer_zero_node);
+ gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
/* Walk the arguments. */
arrayss = gfc_walk_expr (actual->expr);
- assert (arrayss != gfc_ss_terminator);
+ gcc_assert (arrayss != gfc_ss_terminator);
/* Initialize the scalarizer. */
gfc_init_loopinfo (&loop);
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
- tmp = build (PLUS_EXPR, TREE_TYPE (resvar), resvar, integer_one_node);
- tmp = build_v (MODIFY_EXPR, resvar, tmp);
+ tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
+ build_int_cst (TREE_TYPE (resvar), 1));
+ tmp = build2_v (MODIFY_EXPR, resvar, tmp);
gfc_init_se (&arrayse, NULL);
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, actual->expr);
- tmp = build_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
gfc_add_block_to_block (&body, &arrayse.pre);
gfc_add_expr_to_block (&body, tmp);
actual = expr->value.function.actual;
arrayexpr = actual->expr;
arrayss = gfc_walk_expr (arrayexpr);
- assert (arrayss != gfc_ss_terminator);
+ gcc_assert (arrayss != gfc_ss_terminator);
actual = actual->next->next;
- assert (actual);
+ gcc_assert (actual);
maskexpr = actual->expr;
if (maskexpr)
{
maskss = gfc_walk_expr (maskexpr);
- assert (maskss != gfc_ss_terminator);
+ gcc_assert (maskss != gfc_ss_terminator);
}
else
maskss = NULL;
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
- tmp = build (op, type, resvar, arrayse.expr);
+ tmp = build2 (op, type, resvar, arrayse.expr);
gfc_add_modify_expr (&block, resvar, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
/* We enclose the above in if (mask) {...} . */
tmp = gfc_finish_block (&block);
- tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
}
else
tmp = gfc_finish_block (&block);
actual = expr->value.function.actual;
arrayexpr = actual->expr;
arrayss = gfc_walk_expr (arrayexpr);
- assert (arrayss != gfc_ss_terminator);
+ gcc_assert (arrayss != gfc_ss_terminator);
actual = actual->next->next;
- assert (actual);
+ gcc_assert (actual);
maskexpr = actual->expr;
if (maskexpr)
{
maskss = gfc_walk_expr (maskexpr);
- assert (maskss != gfc_ss_terminator);
+ gcc_assert (maskss != gfc_ss_terminator);
}
else
maskss = NULL;
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
- n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind);
+ n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
+ tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
break;
case BT_INTEGER:
break;
default:
- abort ();
+ gcc_unreachable ();
}
/* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
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);
/* Initialize the scalarizer. */
gfc_conv_ss_startstride (&loop);
gfc_conv_loop_setup (&loop);
- assert (loop.dimen == 1);
+ 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.
- ie. pos = (ubound >= lbound) ? lbound, lbound - 1; */
- tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
- loop.from[0], integer_one_node));
- cond = fold (build (GE_EXPR, boolean_type_node,
- loop.to[0], loop.from[0]));
- tmp = fold (build (COND_EXPR, gfc_array_index_type, cond,
- loop.from[0], tmp));
+ i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ loop.from[0], gfc_index_one_node);
+ cond = fold_build2 (GE_EXPR, boolean_type_node,
+ loop.to[0], loop.from[0]);
+ tmp = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ loop.from[0], tmp);
gfc_add_modify_expr (&loop.pre, pos, tmp);
-
+
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
ifbody = gfc_finish_block (&ifblock);
/* If it is a more extreme value. */
- tmp = build (op, boolean_type_node, arrayse.expr, limit);
- tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
+ tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+ tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
if (maskss)
/* We enclose the above in if (mask) {...}. */
tmp = gfc_finish_block (&block);
- tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
}
else
tmp = gfc_finish_block (&block);
gfc_cleanup_loop (&loop);
/* Return a value in the range 1..SIZE(array). */
- tmp = fold (build (MINUS_EXPR, gfc_array_index_type, loop.from[0],
- integer_one_node));
- tmp = fold (build (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);
}
type = gfc_typenode_for_spec (&expr->ts);
/* Initialize the result. */
limit = gfc_create_var (type, "limit");
- n = gfc_validate_kind (expr->ts.type, expr->ts.kind);
+ n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
switch (expr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpf_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
+ tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
break;
case BT_INTEGER:
break;
default:
- abort ();
+ gcc_unreachable ();
}
/* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
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);
/* Walk the arguments. */
actual = expr->value.function.actual;
arrayexpr = actual->expr;
arrayss = gfc_walk_expr (arrayexpr);
- assert (arrayss != gfc_ss_terminator);
+ gcc_assert (arrayss != gfc_ss_terminator);
actual = actual->next->next;
- assert (actual);
+ gcc_assert (actual);
maskexpr = actual->expr;
if (maskexpr)
{
maskss = gfc_walk_expr (maskexpr);
- assert (maskss != gfc_ss_terminator);
+ gcc_assert (maskss != gfc_ss_terminator);
}
else
maskss = NULL;
gfc_add_block_to_block (&block, &arrayse.pre);
/* Assign the value to the limit... */
- ifbody = build_v (MODIFY_EXPR, limit, arrayse.expr);
+ ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
/* If it is a more extreme value. */
- tmp = build (op, boolean_type_node, arrayse.expr, limit);
- tmp = build_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
+ tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+ tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &arrayse.post);
tmp = gfc_finish_block (&block);
if (maskss)
- {
- /* We enclose the above in if (mask) {...}. */
- tmp = build_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
- }
+ /* We enclose the above in if (mask) {...}. */
+ tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&body, tmp);
gfc_trans_scalarizing_loops (&loop, &body);
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- tmp = build (LSHIFT_EXPR, type, integer_one_node, arg2);
- tmp = build (BIT_AND_EXPR, type, arg, tmp);
- tmp = fold (build (NE_EXPR, boolean_type_node, tmp, integer_zero_node));
+ 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,
+ 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 (build (op, type, arg, arg2));
+ se->expr = fold_build2 (op, type, arg, arg2);
}
/* Bitwise not. */
arg = TREE_VALUE (arg);
type = TREE_TYPE (arg);
- tmp = fold (build (LSHIFT_EXPR, 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 (build (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_2 (-1, ~(unsigned HOST_WIDE_INT) 0);
- mask = build (LSHIFT_EXPR, type, mask, arg3);
+ mask = build_int_cst (NULL_TREE, -1);
+ mask = build2 (LSHIFT_EXPR, type, mask, arg3);
mask = build1 (BIT_NOT_EXPR, type, mask);
- tmp = build (RSHIFT_EXPR, type, arg, arg2);
+ tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
- se->expr = fold (build (BIT_AND_EXPR, type, tmp, mask));
+ se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
}
-/* 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 = gfc_unsigned_type (type);
+
+ width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2);
/* Left shift if positive. */
- lshift = build (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 = build (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 = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
- rshift = build (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 = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
- se->expr = build (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:
- abort ();
+ gcc_unreachable ();
}
se->expr = gfc_build_function_call (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 = build (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 = build (RROTATE_EXPR, type, arg, tmp);
+ tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2);
+ rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp);
- tmp = build (GT_EXPR, boolean_type_node, arg2, integer_zero_node);
- rrot = build (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 = build (EQ_EXPR, boolean_type_node, arg2, integer_zero_node);
- se->expr = build (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_se argse;
gfc_expr *arg;
- assert (!se->ss);
+ gcc_assert (!se->ss);
arg = expr->value.function.actual->expr;
switch (arg->expr_type)
{
case EXPR_CONSTANT:
- len = build_int_2 (arg->value.character.length, 0);
+ len = build_int_cst (NULL_TREE, arg->value.character.length);
break;
default:
- if (arg->expr_type == EXPR_VARIABLE && arg->ref == NULL)
+ 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
decl = gfc_get_fake_result_decl (sym);
len = sym->ts.cl->backend_decl;
- assert (len);
+ gcc_assert (len);
}
else
{
static void
gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
{
+ 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);
arg = gfc_conv_intrinsic_function_args (se, expr);
arg = TREE_VALUE (TREE_CHAIN (arg));
- assert (POINTER_TYPE_P (TREE_TYPE (arg)));
+ gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
arg = build1 (NOP_EXPR, pchar_type_node, arg);
type = gfc_typenode_for_spec (&expr->ts);
tree fsource;
tree mask;
tree type;
+ tree len;
arg = gfc_conv_intrinsic_function_args (se, expr);
- tsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- fsource = TREE_VALUE (arg);
- arg = TREE_CHAIN (arg);
- mask = TREE_VALUE (arg);
+ if (expr->ts.type != BT_CHARACTER)
+ {
+ tsource = TREE_VALUE (arg);
+ arg = TREE_CHAIN (arg);
+ fsource = TREE_VALUE (arg);
+ mask = TREE_VALUE (TREE_CHAIN (arg));
+ }
+ else
+ {
+ /* We do the same as in the non-character case, but the argument
+ list is different because of the string length arguments. We
+ also have to set the string length for the result. */
+ len = TREE_VALUE (arg);
+ arg = TREE_CHAIN (arg);
+ tsource = TREE_VALUE (arg);
+ arg = TREE_CHAIN (TREE_CHAIN (arg));
+ fsource = TREE_VALUE (arg);
+ mask = TREE_VALUE (TREE_CHAIN (arg));
+ se->string_length = len;
+ }
type = TREE_TYPE (tsource);
- se->expr = fold (build (COND_EXPR, type, mask, tsource, fsource));
+ se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
}
actual = expr->value.function.actual;
ss = gfc_walk_expr (actual->expr);
- assert (ss != gfc_ss_terminator);
+ gcc_assert (ss != gfc_ss_terminator);
argse.want_pointer = 1;
gfc_conv_expr_descriptor (&argse, actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
type = gfc_typenode_for_spec (&expr->ts);
- se->expr = build (op, type, se->expr, integer_zero_node);
+ se->expr = build2 (op, type, se->expr,
+ build_int_cst (TREE_TYPE (se->expr), 0));
}
/* Generate a call to the adjustl/adjustr library function. */
/* Scalar transfer statement.
- TRANSFER (source, mold) = *(typeof<mould> *)&source */
+ TRANSFER (source, mold) = *(typeof<mold> *)&source. */
static void
gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
tree ptr;
gfc_ss *ss;
- assert (!se->ss);
+ gcc_assert (!se->ss);
/* Get a pointer to the source. */
arg = expr->value.function.actual;
arg1se.descriptor_only = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
- tmp = gfc_conv_descriptor_data (arg1se.expr);
- tmp = build (NE_EXPR, boolean_type_node, tmp, null_pointer_node);
+ 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);
}
/* A pointer to an array. */
arg1se.descriptor_only = 1;
gfc_conv_expr_lhs (&arg1se, arg1->expr);
- tmp2 = gfc_conv_descriptor_data (arg1se.expr);
+ tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
}
- tmp = build (NE_EXPR, boolean_type_node, tmp2, null_pointer_node);
+ tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
+ fold_convert (TREE_TYPE (tmp2), null_pointer_node));
se->expr = tmp;
}
else
if (ss1 == gfc_ss_terminator)
{
/* A pointer to a scalar. */
- assert (ss2 == gfc_ss_terminator);
+ gcc_assert (ss2 == gfc_ss_terminator);
arg1se.want_pointer = 1;
gfc_conv_expr (&arg1se, arg1->expr);
arg2se.want_pointer = 1;
gfc_conv_expr (&arg2se, arg2->expr);
- tmp = build (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
+ tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
se->expr = tmp;
}
else
{
/* A pointer to an array, call library function _gfor_associated. */
- assert (ss2 != gfc_ss_terminator);
+ gcc_assert (ss2 != gfc_ss_terminator);
args = NULL_TREE;
arg1se.want_pointer = 1;
gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
}
-/* Scan a string for any one of the characters in a set of characters. */
+/* Scan a string for any one of the characters in a set of characters. */
static void
gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
{
+ tree 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);
/* Verify that a set of characters contains all the characters in a string
- by indentifying the position of the first character in a string of
+ by identifying the position of the first character in a string of
characters that does not appear in a given set of characters. */
static void
gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
{
+ 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);
/* 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)
+static void
+prepare_arg_info (gfc_se * se, gfc_expr * expr,
+ real_compnt_info * rcs, int all)
{
tree arg;
tree masktype;
if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
gfc_todo_error ("Non-IEEE floating format");
-
- assert (expr->expr_type == EXPR_FUNCTION);
+
+ gcc_assert (expr->expr_type == EXPR_FUNCTION);
arg = gfc_conv_intrinsic_function_args (se, expr);
arg = TREE_VALUE (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);
- tmp = build_int_2 (gfc_real_kinds[n].digits - 1, 0);
+ /* Calculate 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_2 (TYPE_PRECISION (rcs->type) - 1, 0);
+ wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
wbits = convert (masktype, wbits);
- rcs->edigits = fold (build (MINUS_EXPR, masktype, wbits, tmp));
+ 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 (build (LSHIFT_EXPR, masktype, one, wbits));
- rcs->f1 = fold (build (LSHIFT_EXPR, masktype, one, rcs->fdigits));
- rcs->emask = fold (build (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
- rcs->fmask = fold (build (MINUS_EXPR, masktype, rcs->f1, one));
+ 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 (build (MINUS_EXPR, masktype, rcs->edigits, one));
- tmp = fold (build (LSHIFT_EXPR, masktype, one, tmp));
- rcs->bias = fold (build (MINUS_EXPR, masktype, tmp ,one));
+ 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 = build (BIT_AND_EXPR, masktype, arg, rcs->emask);
- tmp = build (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
- exponent = gfc_create_var (masktype, "exponent");
- gfc_add_modify_expr(&se->pre, exponent, tmp);
- rcs->expn = exponent;
-
- tmp = build (BIT_AND_EXPR, masktype, arg, rcs->fmask);
- fraction = gfc_create_var (masktype, "fraction");
- gfc_add_modify_expr(&se->pre, fraction, tmp);
- rcs->frac = fraction;
- }
+ {
+ /* 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. */
else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
fn = built_in_decls[BUILT_IN_CLZLL];
else
- abort ();
+ 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. We generate:
-
- t = expn - (BITS_OF_FRACTION)
- res = t << (BITS_OF_FRACTION)
- if (t < 0)
+
+/* 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)
fdigits = rcs.fdigits;
tiny = rcs.f1;
zero = gfc_build_const (masktype, integer_zero_node);
- tmp = build (BIT_AND_EXPR, masktype, rcs.emask, arg);
- tmp = build (RSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build (MINUS_EXPR, masktype, tmp, fdigits);
- cond = build (LE_EXPR, boolean_type_node, tmp, zero);
- t1 = build (LSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build (COND_EXPR, masktype, cond, tiny, t1);
+ 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. We generate:
- sedigits = edigits + 1;
- if (expn == 0)
+/* 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
{
- t1 = leadzero (frac);
- frac = frac << (t1 + sedigits);
- frac = frac >> (sedigits);
+ // 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;
}
- t = bias + BITS_OF_FRACTION_OF;
- res = (t << BITS_OF_FRACTION_OF) | frac;
*/
static void
gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
{
tree masktype;
- tree tmp, t1, t2, cond;
+ tree tmp, t1, t2, cond, cond2;
tree one, zero;
tree fdigits, fraction;
real_compnt_info rcs;
fraction = rcs.frac;
one = gfc_build_const (masktype, integer_one_node);
zero = gfc_build_const (masktype, integer_zero_node);
- t2 = build (PLUS_EXPR, masktype, rcs.edigits, one);
+ t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one);
t1 = call_builtin_clz (masktype, fraction);
- tmp = build (PLUS_EXPR, masktype, t1, one);
- tmp = build (LSHIFT_EXPR, masktype, fraction, tmp);
- tmp = build (RSHIFT_EXPR, masktype, tmp, t2);
- cond = build (EQ_EXPR, boolean_type_node, rcs.expn, zero);
- fraction = build (COND_EXPR, masktype, cond, tmp, 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 = build (PLUS_EXPR, masktype, rcs.bias, fdigits);
- tmp = build (LSHIFT_EXPR, masktype, tmp, fdigits);
- tmp = build (BIT_IOR_EXPR, masktype, 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,
+ build_int_cst (masktype, 0), tmp);
tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
se->expr = tmp;
static void
gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
{
+ tree gfc_int4_type_node = gfc_get_int_type (4);
tree var;
tree len;
tree addr;
arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
arglist = gfc_chainon_list (arglist, addr);
arglist = chainon (arglist, tmp);
-
+
tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
gfc_add_expr_to_block (&se->pre, tmp);
/* Free the temporary afterwards, if necessary. */
- cond = build (GT_EXPR, boolean_type_node, len, integer_zero_node);
+ cond = build2 (GT_EXPR, boolean_type_node, len,
+ build_int_cst (TREE_TYPE (len), 0));
arglist = gfc_chainon_list (NULL_TREE, var);
tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
- tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
gfc_add_expr_to_block (&se->post, tmp);
se->expr = var;
static void
gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
{
+ tree gfc_int4_type_node = gfc_get_int_type (4);
tree tmp;
tree len;
tree args;
len = TREE_VALUE (args);
tmp = gfc_advance_chain (args, 2);
ncopies = TREE_VALUE (tmp);
- len = fold (build (MULT_EXPR, gfc_int4_type_node, len, ncopies));
+ len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies);
type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
}
+/* Generate code for the IARGC intrinsic. */
+
+static void
+gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
+{
+ tree tmp;
+ tree fndecl;
+ tree type;
+
+ /* Call the library function. This always returns an INTEGER(4). */
+ fndecl = gfor_fndecl_iargc;
+ tmp = gfc_build_function_call (fndecl, NULL_TREE);
+
+ /* Convert it to the required type. */
+ type = gfc_typenode_for_spec (&expr->ts);
+ tmp = fold_convert (type, tmp);
+
+ se->expr = tmp;
+}
+
+
+/* The loc intrinsic returns the address of its argument as
+ gfc_index_integer_kind integer. */
+
+static void
+gfc_conv_intrinsic_loc(gfc_se * se, gfc_expr * expr)
+{
+ tree temp_var;
+ gfc_expr *arg_expr;
+ gfc_ss *ss;
+
+ gcc_assert (!se->ss);
+
+ arg_expr = expr->value.function.actual->expr;
+ ss = gfc_walk_expr (arg_expr);
+ if (ss == gfc_ss_terminator)
+ gfc_conv_expr_reference (se, arg_expr);
+ else
+ gfc_conv_array_parameter (se, arg_expr, ss, 1);
+ se->expr= convert (gfc_unsigned_type (long_integer_type_node),
+ 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_unsigned_type (long_integer_type_node),
+ 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;
switch (expr->value.function.isym->generic_id)
{
case GFC_ISYM_NONE:
- abort ();
+ gcc_unreachable ();
case GFC_ISYM_REPEAT:
gfc_conv_intrinsic_repeat (se, expr);
gfc_conv_intrinsic_conversion (se, expr);
break;
- /* Integer conversions are handled seperately to make sure we get the
+ /* Integer conversions are handled separately to make sure we get the
correct rounding mode. */
case GFC_ISYM_INT:
gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
break;
+ case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
+ gfc_conv_intrinsic_iargc (se, expr);
+ break;
+
case GFC_ISYM_CONJG:
gfc_conv_intrinsic_conjg (se, expr);
break;
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;
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;
gfc_conv_intrinsic_ichar (se, expr);
break;
+ case GFC_ISYM_IARGC:
+ gfc_conv_intrinsic_iargc (se, expr);
+ break;
+
case GFC_ISYM_IEOR:
gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
break;
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_LOC:
+ gfc_conv_intrinsic_loc (se, expr);
+ break;
+
+ case GFC_ISYM_CHDIR:
case GFC_ISYM_DOT_PRODUCT:
+ case GFC_ISYM_ETIME:
+ case GFC_ISYM_FNUM:
+ case GFC_ISYM_FSTAT:
+ 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_MALLOC:
case GFC_ISYM_MATMUL:
+ 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;
break;
default:
- abort ();
- break;
+ gcc_unreachable ();
}
}
{
gfc_ss *newss;
- assert (expr->rank > 0);
+ gcc_assert (expr->rank > 0);
newss = gfc_get_ss ();
newss->type = GFC_SS_FUNCTION;
int
gfc_is_intrinsic_libcall (gfc_expr * expr)
{
- assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
- assert (expr->rank > 0);
+ gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
+ gcc_assert (expr->rank > 0);
switch (expr->value.function.isym->generic_id)
{
gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
gfc_intrinsic_sym * isym)
{
- assert (isym);
+ gcc_assert (isym);
if (isym->elemental)
return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
OSDN Git Service
