#include "config.h"
#include "system.h"
#include "tree.h"
#include "flags.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 PARAMS ((tree, tree));
static int contains_save_expr_p PARAMS ((tree));
static tree contains_null_expr PARAMS ((tree));
static tree compare_arrays PARAMS ((tree, tree, tree));
static tree nonbinary_modular_operation PARAMS ((enum tree_code, tree,
tree, tree));
static tree build_simple_component_ref PARAMS ((tree, tree, tree));
tree
gnat_truthvalue_conversion (expr)
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 COND_EXPR:
return fold
(build (COND_EXPR, type, TREE_OPERAND (expr, 0),
gnat_truthvalue_conversion (TREE_OPERAND (expr, 1)),
gnat_truthvalue_conversion (TREE_OPERAND (expr, 2))));
case WITH_RECORD_EXPR:
return build (WITH_RECORD_EXPR, type,
gnat_truthvalue_conversion (TREE_OPERAND (expr, 0)),
TREE_OPERAND (expr, 1));
default:
return build_binary_op (NE_EXPR, type, expr,
convert (type, integer_zero_node));
}
}
tree
get_base_type (type)
tree type;
{
if (TREE_CODE (type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (type))
type = TREE_TYPE (TYPE_FIELDS (type));
while (TREE_TYPE (type) != 0
&& (TREE_CODE (type) == INTEGER_TYPE
|| TREE_CODE (type) == REAL_TYPE))
type = TREE_TYPE (type);
return type;
}
tree
get_ada_base_type (type)
tree type;
{
while (TREE_TYPE (type) != 0
&& (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 (exp)
tree exp;
{
unsigned int lhs, rhs;
switch (TREE_CODE (exp))
{
case CONVERT_EXPR:
case NOP_EXPR:
case NON_LVALUE_EXPR:
return known_alignment (TREE_OPERAND (exp, 0));
case PLUS_EXPR:
case MINUS_EXPR:
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
return MIN (lhs, rhs);
case INTEGER_CST:
return MIN (BITS_PER_UNIT
* (TREE_INT_CST_LOW (exp) & - TREE_INT_CST_LOW (exp)),
BIGGEST_ALIGNMENT);
case MULT_EXPR:
lhs = known_alignment (TREE_OPERAND (exp, 0));
rhs = known_alignment (TREE_OPERAND (exp, 1));
if (lhs == 0 || rhs == 0)
return MIN (BIGGEST_ALIGNMENT, MAX (lhs, rhs));
return MIN (BIGGEST_ALIGNMENT, lhs * rhs);
case ADDR_EXPR:
return expr_align (TREE_OPERAND (exp, 0));
default:
return 0;
}
}
static tree
find_common_type (t1, t2)
tree t1, 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 int
contains_save_expr_p (exp)
tree exp;
{
switch (TREE_CODE (exp))
{
case SAVE_EXPR:
return 1;
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) != 0
&& contains_save_expr_p (CONSTRUCTOR_ELTS (exp)));
case TREE_LIST:
return (contains_save_expr_p (TREE_VALUE (exp))
|| (TREE_CHAIN (exp) != 0
&& contains_save_expr_p (TREE_CHAIN (exp))));
default:
return 0;
}
}
static tree
contains_null_expr (exp)
tree exp;
{
tree tem;
if (TREE_CODE (exp) == NULL_EXPR)
return exp;
switch (TREE_CODE_CLASS (TREE_CODE (exp)))
{
case '1':
return contains_null_expr (TREE_OPERAND (exp, 0));
case '<': case '2':
tem = contains_null_expr (TREE_OPERAND (exp, 0));
if (tem != 0)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 1));
case 'e':
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 != 0)
return tem;
tem = contains_null_expr (TREE_OPERAND (exp, 1));
if (tem != 0)
return tem;
return contains_null_expr (TREE_OPERAND (exp, 2));
default:
return 0;
}
default:
return 0;
}
}
static tree
compare_arrays (result_type, a1, a2)
tree a1, a2;
tree result_type;
{
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);
int length_zero_p = 0;
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 (build (MINUS_EXPR, bt, ub1, lb1));
tree length2 = fold (build (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 (build (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 (build (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);
if (contains_placeholder_p (comparison))
comparison = build (WITH_RECORD_EXPR, result_type,
comparison, a1);
if (contains_placeholder_p (length1))
length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
length_zero_p = 1;
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));
if (contains_placeholder_p (comparison))
comparison = build (WITH_RECORD_EXPR, result_type, comparison, a1);
if (contains_placeholder_p (length1))
length1 = build (WITH_RECORD_EXPR, bt, 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
{
if (contains_placeholder_p (length1))
length1 = build (WITH_RECORD_EXPR, bt, length1, a1);
if (contains_placeholder_p (length2))
length2 = build (WITH_RECORD_EXPR, bt, 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 != 0)
a1 = convert (type, a1), a2 = convert (type, a2);
result = build_binary_op (TRUTH_ANDIF_EXPR, result_type, result,
fold (build (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 = build (COMPOUND_EXPR, result_type, a1, result);
if (contains_save_expr_p (a2))
result = build (COMPOUND_EXPR, result_type, a2, result);
return result;
}
static tree
nonbinary_modular_operation (op_code, type, lhs, rhs)
enum tree_code op_code;
tree type;
tree lhs, rhs;
{
tree modulus = TYPE_MODULUS (type);
unsigned int needed_precision = tree_floor_log2 (modulus) + 1;
unsigned int precision;
int unsignedp = 1;
tree op_type = type;
tree result;
if (op_code == PLUS_EXPR && TREE_CODE (rhs) == INTEGER_CST)
rhs = fold (build (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 = 0;
if (TYPE_PRECISION (op_type) < precision
|| TREE_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 (build (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 (build (TRUNC_MOD_EXPR, div_type,
convert (div_type, result), modulus)));
}
else if (op_code == MINUS_EXPR)
{
result = save_expr (result);
result = fold (build (COND_EXPR, op_type,
build (LT_EXPR, integer_type_node, result,
convert (op_type, integer_zero_node)),
fold (build (PLUS_EXPR, op_type,
result, modulus)),
result));
}
else
{
result = save_expr (result);
result = fold (build (COND_EXPR, op_type,
build (GE_EXPR, integer_type_node,
result, modulus),
fold (build (MINUS_EXPR, op_type,
result, modulus)),
result));
}
return convert (type, result);
}
tree
build_binary_op (op_code, result_type, left_operand, right_operand)
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 = 0;
tree modulus;
tree result;
int has_side_effects = 0;
if (op_code != MODIFY_EXPR && op_code != ARRAY_REF
&& op_code != ARRAY_RANGE_REF
&& TREE_CODE (left_operand) == WITH_RECORD_EXPR
&& (TREE_CODE (right_operand) != WITH_RECORD_EXPR
|| operand_equal_p (TREE_OPERAND (left_operand, 1),
TREE_OPERAND (right_operand, 1), 0)))
{
tree right = right_operand;
if (TREE_CODE (right) == WITH_RECORD_EXPR)
right = TREE_OPERAND (right, 0);
result = build_binary_op (op_code, result_type,
TREE_OPERAND (left_operand, 0), right);
return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
TREE_OPERAND (left_operand, 1));
}
else if (op_code != MODIFY_EXPR && op_code != ARRAY_REF
&& op_code != ARRAY_RANGE_REF
&& TREE_CODE (left_operand) != WITH_RECORD_EXPR
&& TREE_CODE (right_operand) == WITH_RECORD_EXPR)
{
result = build_binary_op (op_code, result_type, left_operand,
TREE_OPERAND (right_operand, 0));
return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
TREE_OPERAND (right_operand, 1));
}
if (operation_type != 0
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type != 0
&& ! AGGREGATE_TYPE_P (operation_type)
&& TYPE_EXTRA_SUBTYPE_P (operation_type))
operation_type = get_base_type (operation_type);
modulus = (operation_type != 0 && 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_LEFT_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 == 0)
operation_type = left_type;
while (TREE_CODE (right_operand) == VIEW_CONVERT_EXPR
&& ((TREE_CODE (right_type) == RECORD_TYPE
&& ! TYPE_LEFT_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)
&& ! (TYPE_LEFT_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)) != 0)
operation_type = best_type;
if (TREE_CODE (right_type) == RECORD_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) == WITH_RECORD_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;
}
if (TREE_CODE (result) != INDIRECT_REF && TREE_CODE (result) != NULL_EXPR
&& ! DECL_P (result))
gigi_abort (516);
if (operation_type != right_type
&& (! (TREE_CODE (TYPE_SIZE (operation_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (operation_type)))))
{
if (TREE_CODE (TYPE_SIZE (operation_type)) != INTEGER_CST
&& TYPE_MODE (TREE_TYPE (right_operand)) == BLKmode
&& TREE_CODE (right_operand) != UNCONSTRAINED_ARRAY_REF)
right_operand = build1 (CONVERT_EXPR, operation_type,
right_operand);
else
right_operand = convert (operation_type, right_operand);
right_type = operation_type;
}
if (TYPE_MODE (left_type) != TYPE_MODE (right_type))
{
tree new_type = copy_node (left_type);
TYPE_SIZE (new_type) = TYPE_SIZE (right_type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (right_type);
TYPE_MAIN_VARIANT (new_type) = new_type;
right_operand = convert (new_type, right_operand);
}
has_side_effects = 1;
modulus = 0;
break;
case ARRAY_REF:
if (operation_type == 0)
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))
|| op_code == ARRAY_RANGE_REF)
gnat_mark_addressable (left_operand);
modulus = 0;
break;
case GE_EXPR:
case LE_EXPR:
case GT_EXPR:
case LT_EXPR:
if (POINTER_TYPE_P (left_type))
gigi_abort (501);
case EQ_EXPR:
case NE_EXPR:
if (TREE_CODE (left_operand) == NULL_EXPR)
return build (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 build (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_LEFT_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_LEFT_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 == EQ_EXPR)
;
else if (op_code == NE_EXPR)
result = invert_truthvalue (result);
else
gigi_abort (502);
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 = 0;
if (TYPE_NAME (left_base_type) == 0
|| TYPE_NAME (left_base_type) != TYPE_NAME (right_base_type))
gigi_abort (503);
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
gigi_abort (504);
left_operand = convert (best_type, left_operand);
right_operand = convert (best_type, right_operand);
}
else
gigi_abort (505);
}
else if (TYPE_FAT_POINTER_P (left_base_type)
&& TREE_CODE (right_operand) == CONSTRUCTOR
&& integer_zerop (TREE_VALUE (TREE_OPERAND (right_operand, 1))))
{
right_operand = build_component_ref (left_operand, NULL_TREE,
TYPE_FIELDS (left_base_type));
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 = 0;
break;
case PREINCREMENT_EXPR:
case PREDECREMENT_EXPR:
case POSTINCREMENT_EXPR:
case POSTDECREMENT_EXPR:
if (left_type != result_type)
gigi_abort (506);
operation_type = get_base_type (result_type);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
has_side_effects = 1;
modulus = 0;
break;
case LSHIFT_EXPR:
case RSHIFT_EXPR:
case LROTATE_EXPR:
case RROTATE_EXPR:
if (operation_type != left_base_type)
gigi_abort (514);
modulus = 0;
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 != 0 && integer_pow2p (modulus))
modulus = 0;
goto common;
case COMPLEX_EXPR:
if (TREE_TYPE (result_type) != left_base_type
|| TREE_TYPE (result_type) != right_base_type)
gigi_abort (515);
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 = 0;
goto common;
default:
common:
if (operation_type != left_base_type
|| left_base_type != right_base_type)
gigi_abort (507);
left_operand = convert (operation_type, left_operand);
right_operand = convert (operation_type, right_operand);
}
if (modulus != 0 && ! integer_pow2p (modulus))
{
result = nonbinary_modular_operation (op_code, operation_type,
left_operand, right_operand);
modulus = 0;
}
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
result = fold (build (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 != 0)
result = fold (build (FLOOR_MOD_EXPR, operation_type, result,
convert (operation_type, modulus)));
if (result_type != 0 && result_type != operation_type)
result = convert (result_type, result);
return result;
}
tree
build_unary_op (op_code, result_type, operand)
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;
int side_effects = 0;
if (TREE_CODE (operand) == WITH_RECORD_EXPR)
{
result = build_unary_op (op_code, result_type,
TREE_OPERAND (operand, 0));
return build (WITH_RECORD_EXPR, TREE_TYPE (result), result,
TREE_OPERAND (operand, 1));
}
if (operation_type != 0
&& TREE_CODE (operation_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (operation_type))
operation_type = TREE_TYPE (TYPE_FIELDS (operation_type));
if (operation_type != 0
&& ! 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 == 0)
result_type = operation_type = TREE_TYPE (type);
else if (result_type != TREE_TYPE (type))
gigi_abort (513);
result = fold (build1 (op_code, operation_type, operand));
break;
case TRUTH_NOT_EXPR:
if (result_type != base_type)
gigi_abort (508);
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 == 0)
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);
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 == 0)
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 == 0
? build_pointer_type (type)
: result_type),
TREE_OPERAND (operand, 0));
goto common;
case CONST_DECL:
operand = DECL_CONST_CORRESPONDING_VAR (operand);
default:
common:
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)) != 0)
{
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);
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) = TREE_READONLY (TREE_TYPE (type));
}
side_effects = flag_volatile
|| (! TYPE_FAT_POINTER_P (type) && TYPE_VOLATILE (TREE_TYPE (type)));
break;
case NEGATE_EXPR:
case BIT_NOT_EXPR:
{
tree modulus = ((operation_type != 0
&& TREE_CODE (operation_type) == INTEGER_TYPE
&& TYPE_MODULAR_P (operation_type))
? TYPE_MODULUS (operation_type) : 0);
int mod_pow2 = modulus != 0 && integer_pow2p (modulus);
if (modulus != 0)
{
if (operation_type != base_type)
gigi_abort (509);
operand = convert (operation_type, operand);
if (op_code == NEGATE_EXPR && mod_pow2)
result = fold (build (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 (build (PLUS_EXPR, operation_type,
modulus,
convert (operation_type,
integer_one_node)))))
result = fold (build (BIT_XOR_EXPR, operation_type,
operand, modulus));
else
result = fold (build (MINUS_EXPR, operation_type,
modulus, operand));
result = fold (build (COND_EXPR, operation_type,
fold (build (NE_EXPR, integer_type_node,
operand,
convert (operation_type,
integer_zero_node))),
result, operand));
}
else
{
tree cnst = fold (build (MINUS_EXPR, operation_type, modulus,
convert (operation_type,
integer_one_node)));
if (mod_pow2)
result = fold (build (BIT_XOR_EXPR, operation_type,
operand, cnst));
else
result = fold (build (MINUS_EXPR, operation_type,
cnst, operand));
}
break;
}
}
default:
if (operation_type != base_type)
gigi_abort (509);
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 != 0 && TREE_TYPE (result) != result_type)
result = convert (result_type, result);
return result;
}
tree
build_cond_expr (result_type, condition_operand, true_operand, false_operand)
tree result_type;
tree condition_operand;
tree true_operand;
tree false_operand;
{
tree result;
int addr_p = 0;
true_operand = convert (result_type, true_operand);
false_operand = convert (result_type, false_operand);
if (TREE_CODE (result_type) == UNCONSTRAINED_ARRAY_TYPE
|| (TREE_CODE (TYPE_SIZE (result_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (result_type))))
{
addr_p = 1;
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 (build (COND_EXPR, result_type, condition_operand,
true_operand, false_operand));
while (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '1'
|| (TREE_CODE_CLASS (TREE_CODE (true_operand)) == '2'
&& TREE_CONSTANT (TREE_OPERAND (true_operand, 1))))
true_operand = TREE_OPERAND (true_operand, 0);
while (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '1'
|| (TREE_CODE_CLASS (TREE_CODE (false_operand)) == '2'
&& TREE_CONSTANT (TREE_OPERAND (false_operand, 1))))
false_operand = TREE_OPERAND (false_operand, 0);
if (TREE_CODE (true_operand) == SAVE_EXPR)
result = build (COMPOUND_EXPR, result_type, true_operand, result);
if (TREE_CODE (false_operand) == SAVE_EXPR)
result = build (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 (fundecl, arg)
tree fundecl;
tree arg;
{
tree call = build (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 (fundecl, arg1, arg2)
tree fundecl;
tree arg1, arg2;
{
tree call = build (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 (fundecl)
tree fundecl;
{
tree call = build (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 (msg)
int msg;
{
tree fndecl = gnat_raise_decls[msg];
const char *str = discard_file_names ? "" : 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_2 (len, 0)));
return
build_call_2_expr (fndecl,
build1 (ADDR_EXPR, build_pointer_type (char_type_node),
filename),
build_int_2 (lineno, 0));
}
tree
build_constructor (type, list)
tree type;
tree list;
{
tree elmt;
int allconstant = (TREE_CODE (TYPE_SIZE (type)) == INTEGER_CST);
int side_effects = 0;
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))
allconstant = 0;
if (TREE_SIDE_EFFECTS (TREE_VALUE (elmt)))
side_effects = 1;
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 = 0;
break;
}
last_pos = this_pos;
}
}
result = build (CONSTRUCTOR, type, NULL_TREE, list);
TREE_CONSTANT (result) = allconstant;
TREE_STATIC (result) = allconstant;
TREE_SIDE_EFFECTS (result) = side_effects;
TREE_READONLY (result) = TREE_READONLY (type);
return result;
}
static tree
build_simple_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
tree record_type = TYPE_MAIN_VARIANT (TREE_TYPE (record_variable));
tree ref;
if ((TREE_CODE (record_type) != RECORD_TYPE
&& TREE_CODE (record_type) != UNION_TYPE
&& TREE_CODE (record_type) != QUAL_UNION_TYPE)
|| TYPE_SIZE (record_type) == 0)
gigi_abort (510);
if ((component != 0) == (field != 0))
gigi_abort (511);
if (field == 0)
for (field = TYPE_FIELDS (record_type); field;
field = TREE_CHAIN (field))
if (DECL_NAME (field) == component)
break;
if (field == 0)
return 0;
if (DECL_CONTEXT (field) != record_type)
{
tree new_field;
for (new_field = TYPE_FIELDS (record_type); new_field != 0;
new_field = TREE_CHAIN (new_field))
if (DECL_ORIGINAL_FIELD (new_field) == field
|| new_field == DECL_ORIGINAL_FIELD (field)
|| (DECL_ORIGINAL_FIELD (field) != 0
&& (DECL_ORIGINAL_FIELD (field)
== DECL_ORIGINAL_FIELD (new_field))))
break;
if (new_field == 0)
for (new_field = TYPE_FIELDS (record_type); new_field != 0;
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);
ref = build_simple_component_ref (field_ref, NULL_TREE, field);
if (ref != 0)
return ref;
}
field = new_field;
}
if (field == 0)
return 0;
ref = build (COMPONENT_REF, TREE_TYPE (field), record_variable, field);
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 ref;
}
tree
build_component_ref (record_variable, component, field)
tree record_variable;
tree component;
tree field;
{
tree ref = build_simple_component_ref (record_variable, component, field);
if (ref != 0)
return ref;
else if (field != 0)
return build1 (NULL_EXPR, TREE_TYPE (field),
build_call_raise (CE_Discriminant_Check_Failed));
else
gigi_abort (512);
}
tree
build_call_alloc_dealloc (gnu_obj, gnu_size, align, gnat_proc, gnat_pool)
tree gnu_obj;
tree gnu_size;
int align;
Entity_Id gnat_proc;
Entity_Id gnat_pool;
{
tree gnu_align = size_int (align / BITS_PER_UNIT);
if (TREE_CODE (gnu_size) != INTEGER_CST && contains_placeholder_p (gnu_size))
gnu_size = build (WITH_RECORD_EXPR, sizetype, gnu_size,
build_unary_op (INDIRECT_REF, NULL_TREE, 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 = build (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 = build (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)
{
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, 0, 0, 0, 0, 0);
return convert (ptr_void_type_node,
build_unary_op (ADDR_EXPR, NULL_TREE, gnu_decl));
}
else
return build (ALLOCATE_EXPR, ptr_void_type_node, gnu_size, gnu_align);
}
else
return build_call_1_expr (malloc_decl, gnu_size);
}
tree
build_allocator (type, init, result_type, gnat_proc, gnat_pool)
tree type;
tree init;
tree result_type;
Entity_Id gnat_proc;
Entity_Id gnat_pool;
{
tree size = TYPE_SIZE_UNIT (type);
tree result;
if (init != 0 && 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 = TYPE_SIZE_UNIT (storage_type);
if (TREE_CODE (size) != INTEGER_CST
&& contains_placeholder_p (size))
size = build (WITH_RECORD_EXPR, sizetype, size, 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);
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 != 0)
init = convert (type, init);
}
if (init != 0)
{
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,
build (COMPOUND_EXPR, storage_ptr_type,
build_binary_op
(MODIFY_EXPR, storage_type,
build_unary_op (INDIRECT_REF, NULL_TREE,
convert (storage_ptr_type, storage)),
build_constructor (storage_type, template_cons)),
convert (storage_ptr_type, storage)));
}
else
return build
(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)),
build_template (template_type, type, NULL_TREE)),
convert (result_type, convert (storage_ptr_type, storage)));
}
if (init != 0 && TYPE_SIZE_UNIT (TREE_TYPE (init)) != 0
&& (TREE_CODE (TYPE_SIZE_UNIT (TREE_TYPE (init))) == INTEGER_CST
|| (TREE_CODE (size) != INTEGER_CST
&& contains_placeholder_p (size))))
size = TYPE_SIZE_UNIT (TREE_TYPE (init));
if (TREE_CODE (size) != INTEGER_CST && contains_placeholder_p (size))
{
if (init == 0)
size = max_size (size, 1);
else
size = build (WITH_RECORD_EXPR, sizetype, size, init);
}
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 (new_type),
BIGGEST_ALIGNMENT, Empty, Empty);
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));
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));
if (init)
{
result = save_expr (result);
result
= build (COMPOUND_EXPR, TREE_TYPE (result),
build_binary_op
(MODIFY_EXPR, TREE_TYPE (TREE_TYPE (result)),
build_unary_op (INDIRECT_REF, TREE_TYPE (TREE_TYPE (result)),
result),
init),
result);
}
return convert (result_type, result);
}
tree
fill_vms_descriptor (expr, gnat_formal)
tree expr;
Entity_Id gnat_formal;
{
tree record_type = TREE_TYPE (TREE_TYPE (get_gnu_tree (gnat_formal)));
tree field;
tree const_list = 0;
expr = maybe_unconstrained_array (expr);
gnat_mark_addressable (expr);
for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
{
tree init = DECL_INITIAL (field);
if (TREE_CODE (init) != INTEGER_CST
&& contains_placeholder_p (init))
init = build (WITH_RECORD_EXPR, TREE_TYPE (init), init, expr);
const_list = tree_cons (field, convert (TREE_TYPE (field), init),
const_list);
}
return build_constructor (record_type, nreverse (const_list));
}
bool
gnat_mark_addressable (expr_node)
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 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:
put_var_into_stack (expr_node);
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) != 0
&& (gnat_mark_addressable
(DECL_CONST_CORRESPONDING_VAR (expr_node))));
default:
return true;
}
}