tree
gfc_build_inf_or_huge (tree type, int kind)
{
if (HONOR_INFINITIES (TYPE_MODE (type)))
{
REAL_VALUE_TYPE real;
real_inf (&real);
return build_real (type, real);
}
else
{
int k = gfc_validate_kind (BT_REAL, kind, false);
return gfc_conv_mpfr_to_tree (gfc_real_kinds[k].huge, kind, 0);
}
}
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));
}
}
static int
encode_float (int kind, mpfr_t real, unsigned char *buffer, size_t buffer_size)
{
return native_encode_expr (gfc_conv_mpfr_to_tree (real, kind, 0), buffer,
buffer_size);
}
