#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "rtl.h"
#include "ggc.h"
#include "flags.h"
#include "output.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "stringt.h"
#include "uintp.h"
#include "fe.h"
#include "elists.h"
#include "nlists.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
static tree find_common_type (tree, tree);
static bool contains_save_expr_p (tree);
static tree contains_null_expr (tree);
static tree compare_arrays (tree, tree, tree);
static tree nonbinary_modular_operation (enum tree_code, tree, tree, tree);
static tree build_simple_component_ref (tree, tree, tree, bool);
tree
gnat_truthvalue_conversion (tree expr)
{
tree type = TREE_TYPE (expr);
switch (TREE_CODE (expr))
{
case EQ_EXPR: case NE_EXPR: case LE_EXPR: case GE_EXPR:
case LT_EXPR: case GT_EXPR:
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
case ERROR_MARK:
return expr;
case INTEGER_CST:
return (integer_zerop (expr) ? convert (type, integer_zero_node)
: convert (type, integer_one_node));
case REAL_CST:
return (real_zerop (expr) ? convert (type, integer_zero_node)
: convert (type, integer_one_node));
case COND_EXPR:
return fold
(build3 (COND_EXPR, type, TREE_OPERAND (expr, 0),
gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
default:
return build_binary_op (NE_EXPR, type, expr,
convert (type, integer_zero_node));
}
}
tree
get_base_type (tree type)
{
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (type))
type = TREE_TYPE (TYPE_FIELDS (type));
while (TREE_TYPE (type)
&& (TREE_CODE (type) == INTEGER_TYPE
|| TREE_CODE (type) == REAL_TYPE))
type = TREE_TYPE (type);
return type;
}
tree
get_ada_base_type (tree type)
{
while (TREE_TYPE (type)
&& (TREE_CODE (type) == INTEGER_TYPE
|| TREE_CODE (type) == REAL_TYPE)
&& !TYPE_EXTRA_SUBTYPE_P (type))
type = TREE_TYPE (type);
return type;
}
unsigned int
known_alignment (tree exp)
{
unsigned int this_alignment;
unsigned int lhs, rhs;
unsigned int type_alignment;
type_alignment
= ((POINTER_TYPE_P (TREE_TYPE (exp))
&& !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
? TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp))) : 0);
switch (TREE_CODE (exp))
{
case CONVERT_EXPR:
case NOP_EXPR:
case NON_LVALUE_EXPR:
this_alignment = known_alignment (TREE_OPERAND (exp, 0));
break;
case PLUS_EXPR:
case MINUS_EXPR:
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
this_alignment = MIN (lhs, rhs);
break;
case INTEGER_CST:
this_alignment
= MIN (BITS_PER_UNIT
* (TREE_INT_CST_LOW (exp) & - TREE_INT_CST_LOW (exp)),
BIGGEST_ALIGNMENT);
break;
case MULT_EXPR:
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
if (lhs == 0 || rhs == 0)
this_alignment = MIN (BIGGEST_ALIGNMENT, MAX (lhs, rhs));
else
this_alignment = MIN (BIGGEST_ALIGNMENT, lhs * rhs);
break;
case ADDR_EXPR:
this_alignment = expr_align (TREE_OPERAND (exp, 0));
break;
default:
this_alignment = 0;
break;
}
return MAX (type_alignment, this_alignment);
}
static tree
find_common_type (tree t1, tree t2)
{
if (TYPE_MODE (t1) != BLKmode)
return t1;
else if (TYPE_MODE (t2) != BLKmode)
return t2;
if (TREE_CONSTANT (TYPE_SIZE (t1)))
return t1;
else if (TREE_CONSTANT (TYPE_SIZE (t2)))
return t2;
return 0;
}
static bool
contains_save_expr_p (tree exp)
{
switch (TREE_CODE (exp))
{
case SAVE_EXPR:
return true;
case ADDR_EXPR: case INDIRECT_REF:
case COMPONENT_REF:
case NOP_EXPR: case CONVERT_EXPR: case VIEW_CONVERT_EXPR:
return contains_save_expr_p (TREE_OPERAND (exp, 0));
case CONSTRUCTOR:
return (CONSTRUCTOR_ELTS (exp)
&& contains_save_expr_p (CONSTRUCTOR_ELTS (exp)));
case TREE_LIST:
return (contains_save_expr_p (TREE_VALUE (exp))
|| (TREE_CHAIN (exp)
&& contains_save_expr_p (TREE_CHAIN (exp))));
default:
return false;
}
}
static tree
contains_null_expr (tree exp)
{
tree tem;
if (TREE_CODE (exp) == NULL_EXPR)
return exp;
switch (TREE_CODE_CLASS (TREE_CODE (exp)))
{
case tcc_unary:
return contains_null_expr (TREE_OPERAND (exp, 0));
case tcc_comparison:
case tcc_binary:
tem = contains_null_expr (TREE_OPERAND (exp, 0));
if (tem)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 1));
case tcc_expression:
switch (TREE_CODE (exp))
{
case SAVE_EXPR:
return contains_null_expr (TREE_OPERAND (exp, 0));
case COND_EXPR:
tem = contains_null_expr (TREE_OPERAND (exp, 0));
if (tem)
return tem;
tem = contains_null_expr (TREE_OPERAND (exp, 1));
if (tem)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 2));
default:
return 0;
}
default:
return 0;
}
}
static tree
compare_arrays (tree result_type, tree a1, tree a2)
{
tree t1 = TREE_TYPE (a1);
tree t2 = TREE_TYPE (a2);
tree result = convert (result_type, integer_one_node);
tree a1_is_null = convert (result_type, integer_zero_node);
tree a2_is_null = convert (result_type, integer_zero_node);
bool length_zero_p = false;
while (TREE_CODE (t1) == ARRAY_TYPE && TREE_CODE (t2) == ARRAY_TYPE)
{
tree lb1 = TYPE_MIN_VALUE (TYPE_DOMAIN (t1));
tree ub1 = TYPE_MAX_VALUE (TYPE_DOMAIN (t1));
tree lb2 = TYPE_MIN_VALUE (TYPE_DOMAIN (t2));
tree ub2 = TYPE_MAX_VALUE (TYPE_DOMAIN (t2));
tree bt = get_base_type (TREE_TYPE (lb1));
tree length1 = fold (build2 (MINUS_EXPR, bt, ub1, lb1));
tree length2 = fold (build2 (MINUS_EXPR, bt, ub2, lb2));
tree nbt;
tree tem;
tree comparison, this_a1_is_null, this_a2_is_null;
if (TREE_CODE (length1) == INTEGER_CST
&& !integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
convert (bt, integer_one_node)))))
{
tem = a1, a1 = a2, a2 = tem;
tem = t1, t1 = t2, t2 = tem;
tem = lb1, lb1 = lb2, lb2 = tem;
tem = ub1, ub1 = ub2, ub2 = tem;
tem = length1, length1 = length2, length2 = tem;
tem = a1_is_null, a1_is_null = a2_is_null, a2_is_null = tem;
}
if (integer_zerop (fold (build2 (PLUS_EXPR, bt, length2,
convert (bt, integer_one_node)))))
{
tree ub = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
comparison = build_binary_op (LT_EXPR, result_type, ub, lb);
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
length_zero_p = true;
this_a1_is_null = comparison;
this_a2_is_null = convert (result_type, integer_one_node);
}
else if (TREE_CODE (length2) == INTEGER_CST)
{
ub1 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
lb1 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t1)));
ub2 = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
lb2 = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (t2)));
nbt = get_base_type (TREE_TYPE (ub1));
comparison
= build_binary_op (EQ_EXPR, result_type,
build_binary_op (MINUS_EXPR, nbt, ub1, lb1),
build_binary_op (MINUS_EXPR, nbt, ub2, lb2));
comparison = SUBSTITUTE_PLACEHOLDER_IN_EXPR (comparison, a1);
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
this_a1_is_null = build_binary_op (LT_EXPR, result_type, ub1, lb1);
this_a2_is_null = convert (result_type, integer_zero_node);
}
else
{
length1 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length1, a1);
length2 = SUBSTITUTE_PLACEHOLDER_IN_EXPR (length2, a2);
comparison
= build_binary_op (EQ_EXPR, result_type, length1, length2);
this_a1_is_null
= build_binary_op (LT_EXPR, result_type, length1,
convert (bt, integer_zero_node));
this_a2_is_null
= build_binary_op (LT_EXPR, result_type, length2,
convert (bt, integer_zero_node));
}
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type,
result, comparison);
a1_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
this_a1_is_null, a1_is_null);
a2_is_null = build_binary_op (TRUTH_ORIF_EXPR, result_type,
this_a2_is_null, a2_is_null);
t1 = TREE_TYPE (t1);
t2 = TREE_TYPE (t2);
}
if (!length_zero_p)
{
tree type = find_common_type (TREE_TYPE (a1), TREE_TYPE (a2));
if (type)
a1 = convert (type, a1), a2 = convert (type, a2);
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
fold (build2 (EQ_EXPR, result_type, a1, a2)));
}
result = build_binary_op (TRUTH_ORIF_EXPR, result_type,
build_binary_op (TRUTH_ANDIF_EXPR, result_type,
a1_is_null, a2_is_null),
result);
if (contains_save_expr_p (a1))
result = build2 (COMPOUND_EXPR, result_type, a1, result);
if (contains_save_expr_p (a2))
result = build2 (COMPOUND_EXPR, result_type, a2, result);
return result;
}
static tree
nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
tree rhs)
{
tree modulus = TYPE_MODULUS (type);
unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
unsigned int precision;
bool unsignedp = true;
tree op_type = type;
tree result;
if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
rhs = fold (build2 (MINUS_EXPR, type, modulus, rhs)), op_code = MINUS_EXPR;
if (op_code == PLUS_EXPR || op_code == MINUS_EXPR)
needed_precision += 1;
else if (op_code == MULT_EXPR)
needed_precision *= 2;
precision = MAX (needed_precision, TYPE_PRECISION (op_type));
if (op_code == MINUS_EXPR)
unsignedp = false;
if (TYPE_PRECISION (op_type) < precision
|| TYPE_UNSIGNED (op_type) != unsignedp)
{
op_type = copy_node (gnat_type_for_size (precision, unsignedp));
modulus = convert (op_type, modulus);
SET_TYPE_MODULUS (op_type, modulus);
TYPE_MODULAR_P (op_type) = 1;
lhs = convert (op_type, lhs);
rhs = convert (op_type, rhs);
}
result = fold (build2 (op_code, op_type, lhs, rhs));
if (op_code == MULT_EXPR)
{
tree div_type = copy_node (gnat_type_for_size (needed_precision, 1));
modulus = convert (div_type, modulus);
SET_TYPE_MODULUS (div_type, modulus);
TYPE_MODULAR_P (div_type) = 1;
result = convert (op_type,
fold (build2 (TRUNC_MOD_EXPR, div_type,
convert (div_type, result), modulus)));
}
else if (op_code == MINUS_EXPR)
{
result = save_expr (result);
result = fold (build3 (COND_EXPR, op_type,
build2 (LT_EXPR, integer_type_node, result,
convert (op_type, integer_zero_node)),
fold (build2 (PLUS_EXPR, op_type,
result, modulus)),
result));
}
else
{
result = save_expr (result);
result = fold (build3 (COND_EXPR, op_type,
build2 (GE_EXPR, integer_type_node,
result, modulus),
fold (build2 (MINUS_EXPR, op_type,
result, modulus)),
result));
}
return convert (type, result);
}
tree
build_binary_op (enum tree_code op_code, tree result_type,
tree left_operand, tree right_operand)
{
tree left_type = TREE_TYPE (left_operand);
tree right_type = TREE_TYPE (right_operand);
tree left_base_type = get_base_type (left_type);
tree right_base_type = get_base_type (right_type);
tree operation_type = result_type;
tree best_type = NULL_TREE;
tree modulus;
tree result;
bool has_side_effects = false;
if (operation_type
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type
&& !AGGREGATE_TYPE_P (operation_type)
&& TYPE_EXTRA_SUBTYPE_P (operation_type))
operation_type = get_base_type (operation_type);
modulus = (operation_type && TREE_CODE (operation_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (operation_type)
? TYPE_MODULUS (operation_type) : 0);
switch (op_code)
{
case MODIFY_EXPR:
while ((TREE_CODE (left_operand) == CONVERT_EXPR
|| TREE_CODE (left_operand) == NOP_EXPR
|| TREE_CODE (left_operand) == VIEW_CONVERT_EXPR)
&& (((INTEGRAL_TYPE_P (left_type)
|| POINTER_TYPE_P (left_type))
&& (INTEGRAL_TYPE_P (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
|| POINTER_TYPE_P (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))))
|| (((TREE_CODE (left_type) == RECORD_TYPE
&& !TYPE_JUSTIFIED_MODULAR_P (left_type))
|| TREE_CODE (left_type) == ARRAY_TYPE)
&& ((TREE_CODE (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
== RECORD_TYPE)
|| (TREE_CODE (TREE_TYPE
(TREE_OPERAND (left_operand, 0)))
== ARRAY_TYPE))
&& (TYPE_MODE (right_type) == BLKmode
|| (TYPE_MODE (left_type)
== TYPE_MODE (TREE_TYPE
(TREE_OPERAND
(left_operand, 0))))))))
{
left_operand = TREE_OPERAND (left_operand, 0);
left_type = TREE_TYPE (left_operand);
}
if (!operation_type)
operation_type = left_type;
while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR
&& (((TREE_CODE (right_type) == RECORD_TYPE
|| TREE_CODE (right_type) == UNION_TYPE)
&& !TYPE_JUSTIFIED_MODULAR_P (right_type)
&& !TYPE_ALIGN_OK (right_type)
&& !TYPE_IS_FAT_POINTER_P (right_type))
|| TREE_CODE (right_type) == ARRAY_TYPE)
&& ((((TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== RECORD_TYPE)
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== UNION_TYPE))
&& !(TYPE_JUSTIFIED_MODULAR_P
(TREE_TYPE (TREE_OPERAND (right_operand, 0))))
&& !(TYPE_ALIGN_OK
(TREE_TYPE (TREE_OPERAND (right_operand, 0))))
&& !(TYPE_IS_FAT_POINTER_P
(TREE_TYPE (TREE_OPERAND (right_operand, 0)))))
|| (TREE_CODE (TREE_TYPE (TREE_OPERAND (right_operand, 0)))
== ARRAY_TYPE))
&& (0 == (best_type
= find_common_type (right_type,
TREE_TYPE (TREE_OPERAND
(right_operand, 0))))
|| right_type != best_type))
{
right_operand = TREE_OPERAND (right_operand, 0);
right_type = TREE_TYPE (right_operand);
}
if (((TREE_CODE (left_type) == ARRAY_TYPE
&& TREE_CODE (right_type) == ARRAY_TYPE)
|| (TREE_CODE (left_type) == RECORD_TYPE
&& TREE_CODE (right_type) == RECORD_TYPE))
&& (best_type = find_common_type (left_type, right_type)))
operation_type = best_type;
if ((TREE_CODE (right_type) == RECORD_TYPE
|| TREE_CODE (right_type) == UNION_TYPE)
&& TYPE_ALIGN_OK (right_type))
operation_type = right_type;
result = left_operand;
while (1)
{
tree restype = TREE_TYPE (result);
if (TREE_CODE (result) == COMPONENT_REF
|| TREE_CODE (result) == ARRAY_REF
|| TREE_CODE (result) == ARRAY_RANGE_REF)
while (handled_component_p (result))
result = TREE_OPERAND (result, 0);
else if (TREE_CODE (result) == REALPART_EXPR
|| TREE_CODE (result) == IMAGPART_EXPR
|| ((TREE_CODE (result) == NOP_EXPR
|| TREE_CODE (result) == CONVERT_EXPR)
&& (((TREE_CODE (restype)
== TREE_CODE (TREE_TYPE
(TREE_OPERAND (result, 0))))
&& (TYPE_MODE (TREE_TYPE
(TREE_OPERAND (result, 0)))
== TYPE_MODE (restype)))
|| TYPE_ALIGN_OK (restype))))
result = TREE_OPERAND (result, 0);
else if (TREE_CODE (result) == VIEW_CONVERT_EXPR)
{
TREE_ADDRESSABLE (result) = 1;
result = TREE_OPERAND (result, 0);
}
else
break;
}
gcc_assert (TREE_CODE (result) == INDIRECT_REF
|| TREE_CODE (result) == NULL_EXPR || DECL_P (result));
if (operation_type != right_type
&& (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (operation_type))))
{
right_operand = convert (operation_type, right_operand);
right_type = operation_type;
}
if (left_type != operation_type)
left_operand = unchecked_convert (operation_type, left_operand, false);
has_side_effects = true;
modulus = NULL_TREE;
break;
case ARRAY_REF:
if (!operation_type)
operation_type = TREE_TYPE (left_type);
case ARRAY_RANGE_REF:
right_operand = convert (right_base_type, right_operand);
right_operand = convert (TYPE_DOMAIN (left_type), right_operand);
if (!TREE_CONSTANT (right_operand)
|| !TREE_CONSTANT (TYPE_MIN_VALUE (right_type)))
gnat_mark_addressable (left_operand);
modulus = NULL_TREE;
break;
case GE_EXPR:
case LE_EXPR:
case GT_EXPR:
case LT_EXPR:
gcc_assert (!POINTER_TYPE_P (left_type));
case EQ_EXPR:
case NE_EXPR:
if (TREE_CODE (left_operand) == NULL_EXPR)
return build2 (op_code, result_type,
build1 (NULL_EXPR, integer_type_node,
TREE_OPERAND (left_operand, 0)),
integer_zero_node);
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build2 (op_code, result_type,
build1 (NULL_EXPR, integer_type_node,
TREE_OPERAND (right_operand, 0)),
integer_zero_node);
if (TREE_CODE (left_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (left_type))
{
left_operand = convert (TREE_TYPE (TYPE_FIELDS (left_type)),
left_operand);
left_type = TREE_TYPE (left_operand);
left_base_type = get_base_type (left_type);
}
if (TREE_CODE (right_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (right_type))
{
right_operand = convert (TREE_TYPE (TYPE_FIELDS (right_type)),
right_operand);
right_type = TREE_TYPE (right_operand);
right_base_type = get_base_type (right_type);
}
if ((TREE_CODE (left_type) == ARRAY_TYPE
|| (TREE_CODE (left_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (left_type)))
&& (TREE_CODE (right_type) == ARRAY_TYPE
|| (TREE_CODE (right_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (right_type))))
{
result = compare_arrays (result_type, left_operand, right_operand);
if (op_code == NE_EXPR)
result = invert_truthvalue (result);
else
gcc_assert (op_code == EQ_EXPR);
return result;
}
if (left_base_type != right_base_type)
{
if (TREE_CODE (left_base_type) == RECORD_TYPE
&& TREE_CODE (right_base_type) == RECORD_TYPE)
{
best_type = NULL_TREE;
gcc_assert (TYPE_NAME (left_base_type)
&& (TYPE_NAME (left_base_type)
== TYPE_NAME (right_base_type)));
if (TREE_CONSTANT (TYPE_SIZE (left_base_type)))
best_type = left_base_type;
else if (TREE_CONSTANT (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (left_base_type)))
best_type = left_base_type;
else if (!CONTAINS_PLACEHOLDER_P (TYPE_SIZE (right_base_type)))
best_type = right_base_type;
else
gcc_unreachable ();
left_operand = convert (best_type, left_operand);
right_operand = convert (best_type, right_operand);
}
else
gcc_unreachable ();
}
else if (TYPE_FAT_POINTER_P (left_base_type)
&& TREE_CODE (right_operand) == CONSTRUCTOR
&& integer_zerop (TREE_VALUE
(CONSTRUCTOR_ELTS (right_operand))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
TYPE_FIELDS (left_base_type),
false);
left_operand = convert (TREE_TYPE (right_operand),
integer_zero_node);
}
else
{
left_operand = convert (left_base_type, left_operand);
right_operand = convert (right_base_type, right_operand);
}
modulus = NULL_TREE;
break;
case PREINCREMENT_EXPR:
case PREDECREMENT_EXPR:
case POSTINCREMENT_EXPR:
case POSTDECREMENT_EXPR:
gcc_assert (left_type == result_type);
operation_type = get_base_type (result_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
has_side_effects = true;
modulus = NULL_TREE;
break;
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case LROTATE_EXPR:
case RROTATE_EXPR:
gcc_assert (operation_type == left_base_type);
modulus = NULL_TREE;
left_operand = convert (operation_type, left_operand);
break;
case TRUTH_ANDIF_EXPR:
case TRUTH_ORIF_EXPR:
case TRUTH_AND_EXPR:
case TRUTH_OR_EXPR:
case TRUTH_XOR_EXPR:
left_operand = gnat_truthvalue_conversion (left_operand);
right_operand = gnat_truthvalue_conversion (right_operand);
goto common;
case BIT_AND_EXPR:
case BIT_IOR_EXPR:
case BIT_XOR_EXPR:
if (modulus && integer_pow2p (modulus))
modulus = NULL_TREE;
goto common;
case COMPLEX_EXPR:
gcc_assert (TREE_TYPE (result_type) == left_base_type
&& TREE_TYPE (result_type) == right_base_type);
left_operand = convert (left_base_type, left_operand);
right_operand = convert (right_base_type, right_operand);
break;
case TRUNC_DIV_EXPR: case TRUNC_MOD_EXPR:
case CEIL_DIV_EXPR: case CEIL_MOD_EXPR:
case FLOOR_DIV_EXPR: case FLOOR_MOD_EXPR:
case ROUND_DIV_EXPR: case ROUND_MOD_EXPR:
modulus = NULL_TREE;
goto common;
default:
common:
gcc_assert (operation_type == left_base_type
&& left_base_type == right_base_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
}
if (modulus && !integer_pow2p (modulus))
{
result = nonbinary_modular_operation (op_code, operation_type,
left_operand, right_operand);
modulus = NULL_TREE;
}
else if (TREE_CODE (left_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (left_operand, 0));
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
result = fold (build4 (op_code, operation_type, left_operand,
right_operand, NULL_TREE, NULL_TREE));
else
result
= fold (build2 (op_code, operation_type, left_operand, right_operand));
TREE_SIDE_EFFECTS (result) |= has_side_effects;
TREE_CONSTANT (result)
|= (TREE_CONSTANT (left_operand) & TREE_CONSTANT (right_operand)
&& op_code != ARRAY_REF && op_code != ARRAY_RANGE_REF);
if ((op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
&& TYPE_VOLATILE (operation_type))
TREE_THIS_VOLATILE (result) = 1;
if (modulus)
result = fold (build2 (FLOOR_MOD_EXPR, operation_type, result,
convert (operation_type, modulus)));
if (result_type && result_type != operation_type)
result = convert (result_type, result);
return result;
}
tree
build_unary_op (enum tree_code op_code, tree result_type, tree operand)
{
tree type = TREE_TYPE (operand);
tree base_type = get_base_type (type);
tree operation_type = result_type;
tree result;
bool side_effects = false;
if (operation_type
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type
&& !AGGREGATE_TYPE_P (operation_type)
&& TYPE_EXTRA_SUBTYPE_P (operation_type))
operation_type = get_base_type (operation_type);
switch (op_code)
{
case REALPART_EXPR:
case IMAGPART_EXPR:
if (!operation_type)
result_type = operation_type = TREE_TYPE (type);
else
gcc_assert (result_type == TREE_TYPE (type));
result = fold (build1 (op_code, operation_type, operand));
break;
case TRUTH_NOT_EXPR:
gcc_assert (result_type == base_type);
result = invert_truthvalue (gnat_truthvalue_conversion (operand));
break;
case ATTR_ADDR_EXPR:
case ADDR_EXPR:
switch (TREE_CODE (operand))
{
case INDIRECT_REF:
case UNCONSTRAINED_ARRAY_REF:
result = TREE_OPERAND (operand, 0);
if (!result_type)
result_type = build_pointer_type (type);
break;
case NULL_EXPR:
result = operand;
TREE_TYPE (result) = type = build_pointer_type (type);
break;
case ARRAY_REF:
case ARRAY_RANGE_REF:
case COMPONENT_REF:
case BIT_FIELD_REF:
if (op_code == ATTR_ADDR_EXPR)
{
HOST_WIDE_INT bitsize;
HOST_WIDE_INT bitpos;
tree offset, inner;
enum machine_mode mode;
int unsignedp, volatilep;
inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
&mode, &unsignedp, &volatilep,
false);
if (TREE_CODE (TREE_TYPE (inner)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (inner))
&& (CONTAINS_PLACEHOLDER_P
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (inner)))))))
inner = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (inner))),
inner);
if (!offset)
offset = size_zero_node;
if (bitpos % BITS_PER_UNIT != 0)
post_error
("taking address of object not aligned on storage unit?",
error_gnat_node);
offset = size_binop (PLUS_EXPR, offset,
size_int (bitpos / BITS_PER_UNIT));
inner = build_unary_op (ADDR_EXPR, NULL_TREE, inner);
inner = convert (ptr_void_type_node, inner);
offset = convert (ptr_void_type_node, offset);
result = build_binary_op (PLUS_EXPR, ptr_void_type_node,
inner, offset);
result = convert (build_pointer_type (TREE_TYPE (operand)),
result);
break;
}
goto common;
case CONSTRUCTOR:
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
result
= build_unary_op (ADDR_EXPR, NULL_TREE,
TREE_VALUE (CONSTRUCTOR_ELTS (operand)));
result = convert (build_pointer_type (TREE_TYPE (operand)),
result);
break;
}
goto common;
case NOP_EXPR:
if (AGGREGATE_TYPE_P (type)
&& AGGREGATE_TYPE_P (TREE_TYPE (TREE_OPERAND (operand, 0))))
return build_unary_op (ADDR_EXPR, result_type,
TREE_OPERAND (operand, 0));
if (TYPE_MODE (type) != BLKmode
&& (TYPE_MODE (type)
== TYPE_MODE (TREE_TYPE (TREE_OPERAND (operand, 0)))))
return build_unary_op (ADDR_EXPR,
(result_type ? result_type
: build_pointer_type (type)),
TREE_OPERAND (operand, 0));
goto common;
case CONST_DECL:
operand = DECL_CONST_CORRESPONDING_VAR (operand);
default:
common:
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (type)
&& TREE_CODE (TREE_TYPE (TYPE_FIELDS (type))) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (TYPE_FIELDS (type))))
{
type = TREE_TYPE (TYPE_FIELDS (type));
operand = convert (type, operand);
}
if (type != error_mark_node)
operation_type = build_pointer_type (type);
gnat_mark_addressable (operand);
result = fold (build1 (ADDR_EXPR, operation_type, operand));
}
TREE_CONSTANT (result) = staticp (operand) || TREE_CONSTANT (operand);
break;
case INDIRECT_REF:
if (TYPE_THIN_POINTER_P (type)
&& TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
{
operand
= convert (TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))),
operand);
type = TREE_TYPE (operand);
}
if (TYPE_FAT_POINTER_P (type))
{
result = build1 (UNCONSTRAINED_ARRAY_REF,
TYPE_UNCONSTRAINED_ARRAY (type), operand);
TREE_READONLY (result) = TREE_STATIC (result)
= TYPE_READONLY (TYPE_UNCONSTRAINED_ARRAY (type));
}
else if (TREE_CODE (operand) == ADDR_EXPR)
result = TREE_OPERAND (operand, 0);
else
{
result = fold (build1 (op_code, TREE_TYPE (type), operand));
TREE_READONLY (result) = TYPE_READONLY (TREE_TYPE (type));
}
side_effects
= (!TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
break;
case NEGATE_EXPR:
case BIT_NOT_EXPR:
{
tree modulus = ((operation_type
&& TREE_CODE (operation_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (operation_type))
? TYPE_MODULUS (operation_type) : 0);
int mod_pow2 = modulus && integer_pow2p (modulus);
if (modulus)
{
gcc_assert (operation_type == base_type);
operand = convert (operation_type, operand);
if (op_code == NEGATE_EXPR && mod_pow2)
result = fold (build2 (TRUNC_MOD_EXPR, operation_type,
fold (build1 (NEGATE_EXPR, operation_type,
operand)),
modulus));
else if (op_code == NEGATE_EXPR && !mod_pow2)
{
if (integer_pow2p (fold (build2 (PLUS_EXPR, operation_type,
modulus,
convert (operation_type,
integer_one_node)))))
result = fold (build2 (BIT_XOR_EXPR, operation_type,
operand, modulus));
else
result = fold (build2 (MINUS_EXPR, operation_type,
modulus, operand));
result = fold (build3 (COND_EXPR, operation_type,
fold (build2 (NE_EXPR,
integer_type_node,
operand,
convert
(operation_type,
integer_zero_node))),
result, operand));
}
else
{
tree cnst = fold (build2 (MINUS_EXPR, operation_type, modulus,
convert (operation_type,
integer_one_node)));
if (mod_pow2)
result = fold (build2 (BIT_XOR_EXPR, operation_type,
operand, cnst));
else
result = fold (build2 (MINUS_EXPR, operation_type,
cnst, operand));
}
break;
}
}
default:
gcc_assert (operation_type == base_type);
result = fold (build1 (op_code, operation_type, convert (operation_type,
operand)));
}
if (side_effects)
{
TREE_SIDE_EFFECTS (result) = 1;
if (TREE_CODE (result) == INDIRECT_REF)
TREE_THIS_VOLATILE (result) = TYPE_VOLATILE (TREE_TYPE (result));
}
if (result_type && TREE_TYPE (result) != result_type)
result = convert (result_type, result);
return result;
}
tree
build_cond_expr (tree result_type, tree condition_operand,
tree true_operand, tree false_operand)
{
tree result;
bool addr_p = false;
true_operand = convert (result_type, true_operand);
false_operand = convert (result_type, false_operand);
if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
|| CONTAINS_PLACEHOLDER_P (TYPE_SIZE (result_type)))
{
addr_p = true;
result_type = build_pointer_type (result_type);
true_operand = build_unary_op (ADDR_EXPR, result_type, true_operand);
false_operand = build_unary_op (ADDR_EXPR, result_type, false_operand);
}
result = fold (build3 (COND_EXPR, result_type, condition_operand,
true_operand, false_operand));
true_operand = skip_simple_arithmetic (true_operand);
false_operand = skip_simple_arithmetic (false_operand);
if (TREE_CODE (true_operand) == SAVE_EXPR)
result = build2 (COMPOUND_EXPR, result_type, true_operand, result);
if (TREE_CODE (false_operand) == SAVE_EXPR)
result = build2 (COMPOUND_EXPR, result_type, false_operand, result);
if (addr_p)
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
return result;
}
tree
build_call_1_expr (tree fundecl, tree arg)
{
tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
chainon (NULL_TREE, build_tree_list (NULL_TREE, arg)),
NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
return call;
}
tree
build_call_2_expr (tree fundecl, tree arg1, tree arg2)
{
tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
chainon (chainon (NULL_TREE,
build_tree_list (NULL_TREE, arg1)),
build_tree_list (NULL_TREE, arg2)),
NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
return call;
}
tree
build_call_0_expr (tree fundecl)
{
tree call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (fundecl)),
build_unary_op (ADDR_EXPR, NULL_TREE, fundecl),
NULL_TREE, NULL_TREE);
TREE_SIDE_EFFECTS (call) = 1;
return call;
}
tree
build_call_raise (int msg)
{
tree fndecl = gnat_raise_decls[msg];
const char *str = Debug_Flag_NN ? "" : ref_filename;
int len = strlen (str) + 1;
tree filename = build_string (len, str);
TREE_TYPE (filename)
= build_array_type (char_type_node,
build_index_type (build_int_cst (NULL_TREE, len)));
return
build_call_2_expr (fndecl,
build1 (ADDR_EXPR, build_pointer_type (char_type_node),
filename),
build_int_cst (NULL_TREE, input_line));
}
tree
gnat_build_constructor (tree type, tree list)
{
tree elmt;
bool allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
bool side_effects = false;
tree result;
for (elmt = list; elmt; elmt = TREE_CHAIN (elmt))
{
if (!TREE_CONSTANT (TREE_VALUE (elmt))
|| (TREE_CODE (type) == RECORD_TYPE
&& DECL_BIT_FIELD (TREE_PURPOSE (elmt))
&& TREE_CODE (TREE_VALUE (elmt)) != INTEGER_CST)
|| !initializer_constant_valid_p (TREE_VALUE (elmt),
TREE_TYPE (TREE_VALUE (elmt))))
allconstant = false;
if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
side_effects = true;
if (TREE_CODE (type) == RECORD_TYPE
&& (0 != (result
= contains_null_expr (DECL_SIZE (TREE_PURPOSE (elmt))))))
return build1 (NULL_EXPR, type, TREE_OPERAND (result, 0));
}
if (allconstant && TREE_CODE (type) == RECORD_TYPE)
{
tree last_pos = bitsize_zero_node;
tree field;
for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
{
tree this_pos = bit_position (field);
if (TREE_CODE (this_pos) != INTEGER_CST
|| tree_int_cst_lt (this_pos, last_pos))
{
allconstant = false;
break;
}
last_pos = this_pos;
}
}
result = build_constructor (type, list);
TREE_CONSTANT (result) = TREE_INVARIANT (result)
= TREE_STATIC (result) = allconstant;
TREE_SIDE_EFFECTS (result) = side_effects;
TREE_READONLY (result) = TYPE_READONLY (type) || allconstant;
return result;
}
static tree
build_simple_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p)
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
gcc_assert ((TREE_CODE (record_type) == RECORD_TYPE
|| TREE_CODE (record_type) == UNION_TYPE
|| TREE_CODE (record_type) == QUAL_UNION_TYPE)
&& TYPE_SIZE (record_type)
&& (component != 0) != (field != 0));
if (!field)
for (field = TYPE_FIELDS (record_type); field;
field = TREE_CHAIN (field))
if (DECL_NAME (field) == component)
break;
if (!field)
return NULL_TREE;
if (DECL_CONTEXT (field) != record_type)
{
tree new_field;
for (new_field = TYPE_FIELDS (record_type); new_field;
new_field = TREE_CHAIN (new_field))
if (DECL_ORIGINAL_FIELD (new_field) == field
|| new_field == DECL_ORIGINAL_FIELD (field)
|| (DECL_ORIGINAL_FIELD (field)
&& (DECL_ORIGINAL_FIELD (field)
== DECL_ORIGINAL_FIELD (new_field))))
break;
if (!new_field)
for (new_field = TYPE_FIELDS (record_type); new_field;
new_field = TREE_CHAIN (new_field))
if (DECL_INTERNAL_P (new_field))
{
tree field_ref
= build_simple_component_ref (record_variable,
NULL_TREE, new_field, no_fold_p);
ref = build_simple_component_ref (field_ref, NULL_TREE, field,
no_fold_p);
if (ref)
return ref;
}
field = new_field;
}
if (!field)
return NULL_TREE;
ref = build3 (COMPONENT_REF, TREE_TYPE (field), record_variable, field,
NULL_TREE);
if (TREE_READONLY (record_variable) || TREE_READONLY (field))
TREE_READONLY (ref) = 1;
if (TREE_THIS_VOLATILE (record_variable) || TREE_THIS_VOLATILE (field)
|| TYPE_VOLATILE (record_type))
TREE_THIS_VOLATILE (ref) = 1;
return no_fold_p ? ref : fold (ref);
}
tree
build_component_ref (tree record_variable, tree component,
tree field, bool no_fold_p)
{
tree ref = build_simple_component_ref (record_variable, component, field,
no_fold_p);
if (ref)
return ref;
gcc_assert (field);
return build1 (NULL_EXPR, TREE_TYPE (field),
build_call_raise (CE_Discriminant_Check_Failed));
}
tree
build_call_alloc_dealloc (tree gnu_obj, tree gnu_size, unsigned align,
Entity_Id gnat_proc, Entity_Id gnat_pool,
Node_Id gnat_node)
{
tree gnu_align = size_int (align / BITS_PER_UNIT);
gnu_size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (gnu_size, gnu_obj);
if (Present (gnat_proc))
{
if (Is_Tagged_Type (Etype (gnat_pool)))
{
Entity_Id gnat_size_type
= Etype (Next_Formal (Next_Formal (First_Formal (gnat_proc))));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_pool = gnat_to_gnu (gnat_pool);
tree gnu_pool_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_pool);
tree gnu_args = NULL_TREE;
tree gnu_call;
gnu_args
= chainon (gnu_args, build_tree_list (NULL_TREE, gnu_pool_addr));
if (gnu_obj)
gnu_args
= chainon (gnu_args, build_tree_list (NULL_TREE, gnu_obj));
gnu_args
= chainon (gnu_args,
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_size)));
gnu_args
= chainon (gnu_args,
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_align)));
gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
else
{
Entity_Id gnat_size_type
= Etype (Next_Formal (First_Formal (gnat_proc)));
tree gnu_size_type = gnat_to_gnu_type (gnat_size_type);
tree gnu_proc = gnat_to_gnu (gnat_proc);
tree gnu_proc_addr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_proc);
tree gnu_args = NULL_TREE;
tree gnu_call;
if (gnu_obj)
gnu_args
= chainon (gnu_args, build_tree_list (NULL_TREE, gnu_obj));
gnu_args
= chainon (gnu_args,
build_tree_list (NULL_TREE,
convert (gnu_size_type, gnu_size)));
gnu_call = build3 (CALL_EXPR, TREE_TYPE (TREE_TYPE (gnu_proc)),
gnu_proc_addr, gnu_args, NULL_TREE);
TREE_SIDE_EFFECTS (gnu_call) = 1;
return gnu_call;
}
}
else if (gnu_obj)
return build_call_1_expr (free_decl, gnu_obj);
else if (gnat_pool == -1
&& TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
{
if (TREE_CODE (gnu_size) == INTEGER_CST && !flag_stack_check)
{
tree gnu_range
= build_range_type (NULL_TREE, size_one_node, gnu_size);
tree gnu_array_type = build_array_type (char_type_node, gnu_range);
tree gnu_decl
= create_var_decl (get_identifier ("RETVAL"), NULL_TREE,
gnu_array_type, NULL_TREE, false, false, false,
false, NULL, gnat_node);
return convert (ptr_void_type_node,
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
}
else
gcc_unreachable ();
#if 0
return build2 (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
#endif
}
else
{
if (Nkind (gnat_node) != N_Allocator || !Comes_From_Source (gnat_node))
Check_No_Implicit_Heap_Alloc (gnat_node);
return build_call_1_expr (malloc_decl, gnu_size);
}
}
tree
build_allocator (tree type, tree init, tree result_type, Entity_Id gnat_proc,
Entity_Id gnat_pool, Node_Id gnat_node)
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
if (init && TREE_CODE (init) == NULL_EXPR)
return build1 (NULL_EXPR, result_type, TREE_OPERAND (init, 0));
else if (TYPE_FAT_OR_THIN_POINTER_P (result_type))
{
tree template_type
= (TYPE_FAT_POINTER_P (result_type)
? TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (result_type))))
: TREE_TYPE (TYPE_FIELDS (TREE_TYPE (result_type))));
tree storage_type
= build_unc_object_type (template_type, type,
get_identifier ("ALLOC"));
tree storage_ptr_type = build_pointer_type (storage_type);
tree storage;
tree template_cons = NULL_TREE;
size = SUBSTITUTE_PLACEHOLDER_IN_EXPR (TYPE_SIZE_UNIT (storage_type),
init);
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
storage = build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (storage_type),
gnat_proc, gnat_pool, gnat_node);
storage = convert (storage_ptr_type, protect_multiple_eval (storage));
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
type = TREE_TYPE (TYPE_FIELDS (type));
if (init)
init = convert (type, init);
}
if (init)
{
template_cons = tree_cons (TREE_CHAIN (TYPE_FIELDS (storage_type)),
init, NULL_TREE);
template_cons = tree_cons (TYPE_FIELDS (storage_type),
build_template (template_type, type,
init),
template_cons);
return convert
(result_type,
build2 (COMPOUND_EXPR, storage_ptr_type,
build_binary_op
(MODIFY_EXPR, storage_type,
build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
gnat_build_constructor (storage_type, template_cons)),
convert (storage_ptr_type, storage)));
}
else
return build2
(COMPOUND_EXPR, result_type,
build_binary_op
(MODIFY_EXPR, template_type,
build_component_ref
(build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
NULL_TREE, TYPE_FIELDS (storage_type), 0),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
if (init && TYPE_SIZE_UNIT (TREE_TYPE (init))
&& (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
|| CONTAINS_PLACEHOLDER_P (size)))
size = TYPE_SIZE_UNIT (TREE_TYPE (init));
if (CONTAINS_PLACEHOLDER_P (size))
{
if (init)
size = substitute_placeholder_in_expr (size, init);
else
size = max_size (size, true);
}
if (TREE_CODE (size) == INTEGER_CST && TREE_OVERFLOW (size))
size = ssize_int (-1);
if (TYPE_ALIGN (type) > BIGGEST_ALIGNMENT
&& No (gnat_proc))
{
tree new_type = make_aligning_type (type, TYPE_ALIGN (type), size);
result = build_call_alloc_dealloc (NULL_TREE, TYPE_SIZE_UNIT (new_type),
BIGGEST_ALIGNMENT, Empty,
Empty, gnat_node);
result = save_expr (result);
result = convert (build_pointer_type (new_type), result);
result = build_unary_op (INDIRECT_REF, NULL_TREE, result);
result = build_component_ref (result, NULL_TREE,
TYPE_FIELDS (new_type), 0);
result = convert (result_type,
build_unary_op (ADDR_EXPR, NULL_TREE, result));
}
else
result = convert (result_type,
build_call_alloc_dealloc (NULL_TREE, size,
TYPE_ALIGN (type),
gnat_proc,
gnat_pool,
gnat_node));
if (init)
{
result = save_expr (result);
result
= build2 (COMPOUND_EXPR, TREE_TYPE (result),
build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF,
TREE_TYPE (TREE_TYPE (result)), result),
init),
result);
}
return convert (result_type, result);
}
tree
fill_vms_descriptor (tree expr, Entity_Id gnat_formal)
{
tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
tree field;
tree const_list = NULL_TREE;
expr = maybe_unconstrained_array (expr);
gnat_mark_addressable (expr);
for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
const_list
= tree_cons (field,
convert (TREE_TYPE (field),
SUBSTITUTE_PLACEHOLDER_IN_EXPR
(DECL_INITIAL (field), expr)),
const_list);
return gnat_build_constructor (record_type, nreverse (const_list));
}
bool
gnat_mark_addressable (tree expr_node)
{
while (1)
switch (TREE_CODE (expr_node))
{
case ADDR_EXPR:
case COMPONENT_REF:
case ARRAY_REF:
case ARRAY_RANGE_REF:
case REALPART_EXPR:
case IMAGPART_EXPR:
case VIEW_CONVERT_EXPR:
case CONVERT_EXPR:
case NON_LVALUE_EXPR:
case NOP_EXPR:
expr_node = TREE_OPERAND (expr_node, 0);
break;
case CONSTRUCTOR:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case VAR_DECL:
case PARM_DECL:
case RESULT_DECL:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case FUNCTION_DECL:
TREE_ADDRESSABLE (expr_node) = 1;
return true;
case CONST_DECL:
return (DECL_CONST_CORRESPONDING_VAR (expr_node)
&& (gnat_mark_addressable
(DECL_CONST_CORRESPONDING_VAR (expr_node))));
default:
return true;
}
}