tree
gfc_build_const (tree type, tree intval)
{
tree val;
tree zero;
switch (TREE_CODE (type))
{
case INTEGER_TYPE:
val = convert (type, intval);
break;
case REAL_TYPE:
val = build_real_from_int_cst (type, intval);
break;
case COMPLEX_TYPE:
val = build_real_from_int_cst (TREE_TYPE (type), intval);
zero = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
val = build_complex (type, val, zero);
break;
default:
gcc_unreachable ();
}
return val;
}
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
gcc_assert (expr->expr_type == EXPR_CONSTANT);
switch (expr->ts.type)
{
case BT_INTEGER:
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
case BT_LOGICAL:
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
{
tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
expr->ts.kind);
tree imag = gfc_conv_mpfr_to_tree (expr->value.complex.i,
expr->ts.kind);
return build_complex (NULL_TREE, real, imag);
}
case BT_CHARACTER:
return gfc_build_string_const (expr->value.character.length,
expr->value.character.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
tree
gfc_conv_constant_to_tree (gfc_expr * expr)
{
tree res;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is has a prescribed memory representation, we build a string
constant and VIEW_CONVERT to its type. */
switch (expr->ts.type)
{
case BT_INTEGER:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_real_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind, expr->is_snan);
case BT_LOGICAL:
if (expr->representation.string)
{
tree tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
if (!integer_zerop (tmp) && !integer_onep (tmp))
gfc_warning ("Assigning value other than 0 or 1 to LOGICAL"
" has undefined result at %L", &expr->where);
return fold_convert (gfc_get_logical_type (expr->ts.kind), tmp);
}
else
return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical);
case BT_COMPLEX:
if (expr->representation.string)
return fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
gfc_get_complex_type (expr->ts.kind),
gfc_build_string_const (expr->representation.length,
expr->representation.string));
else
{
tree real = gfc_conv_mpfr_to_tree (mpc_realref (expr->value.complex),
expr->ts.kind, expr->is_snan);
tree imag = gfc_conv_mpfr_to_tree (mpc_imagref (expr->value.complex),
expr->ts.kind, expr->is_snan);
return build_complex (gfc_typenode_for_spec (&expr->ts),
real, imag);
}
case BT_CHARACTER:
res = gfc_build_wide_string_const (expr->ts.kind,
expr->value.character.length,
expr->value.character.string);
return res;
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,
expr->representation.string);
default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts));
}
}
/* Interpret TOKEN, a floating point number with FLAGS as classified
by cpplib. */
static tree
interpret_float (const cpp_token *token, unsigned int flags)
{
tree type;
tree value;
REAL_VALUE_TYPE real;
char *copy;
size_t copylen;
const char *type_name;
/* FIXME: make %T work in error/warning, then we don't need type_name. */
if ((flags & CPP_N_WIDTH) == CPP_N_LARGE)
{
type = long_double_type_node;
type_name = "long double";
}
else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL
|| flag_single_precision_constant)
{
type = float_type_node;
type_name = "float";
}
else
{
type = double_type_node;
type_name = "double";
}
/* Copy the constant to a nul-terminated buffer. If the constant
has any suffixes, cut them off; REAL_VALUE_ATOF/ REAL_VALUE_HTOF
can't handle them. */
copylen = token->val.str.len;
if ((flags & CPP_N_WIDTH) != CPP_N_MEDIUM)
/* Must be an F or L suffix. */
copylen--;
if (flags & CPP_N_IMAGINARY)
/* I or J suffix. */
copylen--;
copy = (char *) alloca (copylen + 1);
memcpy (copy, token->val.str.text, copylen);
copy[copylen] = '\0';
real_from_string (&real, copy);
real_convert (&real, TYPE_MODE (type), &real);
/* Both C and C++ require a diagnostic for a floating constant
outside the range of representable values of its type. Since we
have __builtin_inf* to produce an infinity, it might now be
appropriate for this to be a mandatory pedwarn rather than
conditioned on -pedantic. */
if (REAL_VALUE_ISINF (real) && pedantic)
pedwarn ("floating constant exceeds range of %<%s%>", type_name);
/* Create a node with determined type and value. */
value = build_real (type, real);
if (flags & CPP_N_IMAGINARY)
value = build_complex (NULL_TREE, convert (type, integer_zero_node), value);
return value;
}
/* Interpret TOKEN, an integer with FLAGS as classified by cpplib. */
static tree
interpret_integer (const cpp_token *token, unsigned int flags)
{
tree value, type;
enum integer_type_kind itk;
cpp_num integer;
cpp_options *options = cpp_get_options (parse_in);
integer = cpp_interpret_integer (parse_in, token, flags);
integer = cpp_num_sign_extend (integer, options->precision);
/* The type of a constant with a U suffix is straightforward. */
if (flags & CPP_N_UNSIGNED)
itk = narrowest_unsigned_type (integer.low, integer.high, flags);
else
{
/* The type of a potentially-signed integer constant varies
depending on the base it's in, the standard in use, and the
length suffixes. */
enum integer_type_kind itk_u
= narrowest_unsigned_type (integer.low, integer.high, flags);
enum integer_type_kind itk_s
= narrowest_signed_type (integer.low, integer.high, flags);
/* In both C89 and C99, octal and hex constants may be signed or
unsigned, whichever fits tighter. We do not warn about this
choice differing from the traditional choice, as the constant
is probably a bit pattern and either way will work. */
if ((flags & CPP_N_RADIX) != CPP_N_DECIMAL)
itk = MIN (itk_u, itk_s);
else
{
/* In C99, decimal constants are always signed.
In C89, decimal constants that don't fit in long have
undefined behavior; we try to make them unsigned long.
In GCC's extended C89, that last is true of decimal
constants that don't fit in long long, too. */
itk = itk_s;
if (itk_s > itk_u && itk_s > itk_long)
{
if (!flag_isoc99)
{
if (itk_u < itk_unsigned_long)
itk_u = itk_unsigned_long;
itk = itk_u;
warning (0, "this decimal constant is unsigned only in ISO C90");
}
else
warning (OPT_Wtraditional,
"this decimal constant would be unsigned in ISO C90");
}
}
}
if (itk == itk_none)
/* cpplib has already issued a warning for overflow. */
type = ((flags & CPP_N_UNSIGNED)
? widest_unsigned_literal_type_node
: widest_integer_literal_type_node);
else
type = integer_types[itk];
if (itk > itk_unsigned_long
&& (flags & CPP_N_WIDTH) != CPP_N_LARGE
&& !in_system_header && !flag_isoc99)
pedwarn ("integer constant is too large for %qs type",
(flags & CPP_N_UNSIGNED) ? "unsigned long" : "long");
value = build_int_cst_wide (type, integer.low, integer.high);
/* Convert imaginary to a complex type. */
if (flags & CPP_N_IMAGINARY)
value = build_complex (NULL_TREE, build_int_cst (type, 0), value);
return value;
}
static tree
fold_const_call_1 (built_in_function fn, tree type, tree arg0, tree arg1)
{
machine_mode mode = TYPE_MODE (type);
machine_mode arg0_mode = TYPE_MODE (TREE_TYPE (arg0));
machine_mode arg1_mode = TYPE_MODE (TREE_TYPE (arg1));
if (arg0_mode == arg1_mode
&& real_cst_p (arg0)
&& real_cst_p (arg1))
{
gcc_checking_assert (SCALAR_FLOAT_MODE_P (arg0_mode));
if (mode == arg0_mode)
{
/* real, real -> real. */
REAL_VALUE_TYPE result;
if (fold_const_call_sss (&result, fn, TREE_REAL_CST_PTR (arg0),
TREE_REAL_CST_PTR (arg1),
REAL_MODE_FORMAT (mode)))
return build_real (type, result);
}
return NULL_TREE;
}
if (real_cst_p (arg0)
&& integer_cst_p (arg1))
{
gcc_checking_assert (SCALAR_FLOAT_MODE_P (arg0_mode));
if (mode == arg0_mode)
{
/* real, int -> real. */
REAL_VALUE_TYPE result;
if (fold_const_call_sss (&result, fn, TREE_REAL_CST_PTR (arg0),
arg1, REAL_MODE_FORMAT (mode)))
return build_real (type, result);
}
return NULL_TREE;
}
if (integer_cst_p (arg0)
&& real_cst_p (arg1))
{
gcc_checking_assert (SCALAR_FLOAT_MODE_P (arg1_mode));
if (mode == arg1_mode)
{
/* int, real -> real. */
REAL_VALUE_TYPE result;
if (fold_const_call_sss (&result, fn, arg0,
TREE_REAL_CST_PTR (arg1),
REAL_MODE_FORMAT (mode)))
return build_real (type, result);
}
return NULL_TREE;
}
if (arg0_mode == arg1_mode
&& complex_cst_p (arg0)
&& complex_cst_p (arg1))
{
gcc_checking_assert (COMPLEX_MODE_P (arg0_mode));
machine_mode inner_mode = GET_MODE_INNER (arg0_mode);
tree arg0r = TREE_REALPART (arg0);
tree arg0i = TREE_IMAGPART (arg0);
tree arg1r = TREE_REALPART (arg1);
tree arg1i = TREE_IMAGPART (arg1);
if (mode == arg0_mode
&& real_cst_p (arg0r)
&& real_cst_p (arg0i)
&& real_cst_p (arg1r)
&& real_cst_p (arg1i))
{
/* complex real, complex real -> complex real. */
REAL_VALUE_TYPE result_real, result_imag;
if (fold_const_call_ccc (&result_real, &result_imag, fn,
TREE_REAL_CST_PTR (arg0r),
TREE_REAL_CST_PTR (arg0i),
TREE_REAL_CST_PTR (arg1r),
TREE_REAL_CST_PTR (arg1i),
REAL_MODE_FORMAT (inner_mode)))
return build_complex (type,
build_real (TREE_TYPE (type), result_real),
build_real (TREE_TYPE (type), result_imag));
}
return NULL_TREE;
}
return NULL_TREE;
}
static tree
fold_const_call_1 (built_in_function fn, tree type, tree arg)
{
machine_mode mode = TYPE_MODE (type);
machine_mode arg_mode = TYPE_MODE (TREE_TYPE (arg));
if (integer_cst_p (arg))
{
if (SCALAR_INT_MODE_P (mode))
{
wide_int result;
if (fold_const_call_ss (&result, fn, arg, TYPE_PRECISION (type),
TREE_TYPE (arg)))
return wide_int_to_tree (type, result);
}
return NULL_TREE;
}
if (real_cst_p (arg))
{
gcc_checking_assert (SCALAR_FLOAT_MODE_P (arg_mode));
if (mode == arg_mode)
{
/* real -> real. */
REAL_VALUE_TYPE result;
if (fold_const_call_ss (&result, fn, TREE_REAL_CST_PTR (arg),
REAL_MODE_FORMAT (mode)))
return build_real (type, result);
}
else if (COMPLEX_MODE_P (mode)
&& GET_MODE_INNER (mode) == arg_mode)
{
/* real -> complex real. */
REAL_VALUE_TYPE result_real, result_imag;
if (fold_const_call_cs (&result_real, &result_imag, fn,
TREE_REAL_CST_PTR (arg),
REAL_MODE_FORMAT (arg_mode)))
return build_complex (type,
build_real (TREE_TYPE (type), result_real),
build_real (TREE_TYPE (type), result_imag));
}
else if (INTEGRAL_TYPE_P (type))
{
/* real -> int. */
wide_int result;
if (fold_const_call_ss (&result, fn,
TREE_REAL_CST_PTR (arg),
TYPE_PRECISION (type),
REAL_MODE_FORMAT (arg_mode)))
return wide_int_to_tree (type, result);
}
return NULL_TREE;
}
if (complex_cst_p (arg))
{
gcc_checking_assert (COMPLEX_MODE_P (arg_mode));
machine_mode inner_mode = GET_MODE_INNER (arg_mode);
tree argr = TREE_REALPART (arg);
tree argi = TREE_IMAGPART (arg);
if (mode == arg_mode
&& real_cst_p (argr)
&& real_cst_p (argi))
{
/* complex real -> complex real. */
REAL_VALUE_TYPE result_real, result_imag;
if (fold_const_call_cc (&result_real, &result_imag, fn,
TREE_REAL_CST_PTR (argr),
TREE_REAL_CST_PTR (argi),
REAL_MODE_FORMAT (inner_mode)))
return build_complex (type,
build_real (TREE_TYPE (type), result_real),
build_real (TREE_TYPE (type), result_imag));
}
if (mode == inner_mode
&& real_cst_p (argr)
&& real_cst_p (argi))
{
/* complex real -> real. */
REAL_VALUE_TYPE result;
if (fold_const_call_sc (&result, fn,
TREE_REAL_CST_PTR (argr),
TREE_REAL_CST_PTR (argi),
REAL_MODE_FORMAT (inner_mode)))
return build_real (type, result);
}
return NULL_TREE;
}
return NULL_TREE;
}
/* Interpret TOKEN, a floating point number with FLAGS as classified
by cpplib. */
static tree
interpret_float (const cpp_token *token, unsigned int flags)
{
tree type;
tree value;
REAL_VALUE_TYPE real;
char *copy;
size_t copylen;
/* Default (no suffix) is double. */
if (flags & CPP_N_DEFAULT)
{
flags ^= CPP_N_DEFAULT;
flags |= CPP_N_MEDIUM;
}
/* Decode type based on width and properties. */
if (flags & CPP_N_DFLOAT)
if ((flags & CPP_N_WIDTH) == CPP_N_LARGE)
type = dfloat128_type_node;
else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL)
type = dfloat32_type_node;
else
type = dfloat64_type_node;
else
if ((flags & CPP_N_WIDTH) == CPP_N_LARGE)
type = long_double_type_node;
else if ((flags & CPP_N_WIDTH) == CPP_N_SMALL
|| flag_single_precision_constant)
type = float_type_node;
else
type = double_type_node;
/* Copy the constant to a nul-terminated buffer. If the constant
has any suffixes, cut them off; REAL_VALUE_ATOF/ REAL_VALUE_HTOF
can't handle them. */
copylen = token->val.str.len;
if (flags & CPP_N_DFLOAT)
copylen -= 2;
else
{
if ((flags & CPP_N_WIDTH) != CPP_N_MEDIUM)
/* Must be an F or L suffix. */
copylen--;
if (flags & CPP_N_IMAGINARY)
/* I or J suffix. */
copylen--;
}
copy = (char *) alloca (copylen + 1);
memcpy (copy, token->val.str.text, copylen);
copy[copylen] = '\0';
real_from_string3 (&real, copy, TYPE_MODE (type));
/* Both C and C++ require a diagnostic for a floating constant
outside the range of representable values of its type. Since we
have __builtin_inf* to produce an infinity, it might now be
appropriate for this to be a mandatory pedwarn rather than
conditioned on -pedantic. */
if (REAL_VALUE_ISINF (real) && pedantic)
pedwarn ("floating constant exceeds range of %qT", type);
/* Create a node with determined type and value. */
value = build_real (type, real);
if (flags & CPP_N_IMAGINARY)
value = build_complex (NULL_TREE, convert (type, integer_zero_node), value);
return value;
}
