static int
encode_logical (int kind, int logical, unsigned char *buffer, size_t buffer_size)
{
return native_encode_expr (build_int_cst (gfc_get_logical_type (kind),
logical),
buffer, buffer_size);
}
int
gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
int *logical)
{
tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
buffer_size);
*logical = double_int_zero_p (tree_to_double_int (t))
? 0 : 1;
return size_logical (kind);
}
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 size_t
size_logical (int kind)
{
return GET_MODE_SIZE (TYPE_MODE (gfc_get_logical_type (kind)));;
}
/* The maximum array element size that can be handled is determined
by the number of bits available to store this field in the array
descriptor. */
n = TYPE_PRECISION (gfc_array_index_type) - GFC_DTYPE_SIZE_SHIFT;
lo = ~ (unsigned HOST_WIDE_INT) 0;
if (n > HOST_BITS_PER_WIDE_INT)
hi = lo >> (2*HOST_BITS_PER_WIDE_INT - n);
else
hi = 0, lo >>= HOST_BITS_PER_WIDE_INT - n;
gfc_max_array_element_size
= build_int_cst_wide (long_unsigned_type_node, lo, hi);
size_type_node = gfc_array_index_type;
boolean_type_node = gfc_get_logical_type (gfc_default_logical_kind);
boolean_true_node = build_int_cst (boolean_type_node, 1);
boolean_false_node = build_int_cst (boolean_type_node, 0);
/* ??? Shouldn't this be based on gfc_index_integer_kind or so? */
gfc_charlen_type_node = gfc_get_int_type (4);
}
/* Get the type node for the given type and kind. */
tree
gfc_get_int_type (int kind)
{
int index = gfc_validate_kind (BT_INTEGER, kind, false);
return gfc_integer_types[index];
}
