#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "flags.h"
#include "defaults.h"
#include "toplev.h"
#include "output.h"
#include "ggc.h"
#include "debug.h"
#include "convert.h"
#include "target.h"
#include "function.h"
#include "cgraph.h"
#include "tree-inline.h"
#include "tree-gimple.h"
#include "tree-dump.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "elists.h"
#include "namet.h"
#include "nlists.h"
#include "stringt.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
#ifndef MAX_FIXED_MODE_SIZE
#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
#endif
#ifndef MAX_BITS_PER_WORD
#define MAX_BITS_PER_WORD BITS_PER_WORD
#endif
int force_global;
tree gnat_std_decls[(int) ADT_LAST];
tree gnat_raise_decls[(int) LAST_REASON_CODE + 1];
static GTY((length ("max_gnat_nodes"))) tree *associate_gnat_to_gnu;
static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
static GTY(()) tree float_types[NUM_MACHINE_MODES];
struct gnat_binding_level GTY((chain_next ("%h.chain")))
{
struct gnat_binding_level *chain;
tree block;
tree jmpbuf_decl;
};
static GTY(()) struct gnat_binding_level *current_binding_level;
static GTY((deletable)) struct gnat_binding_level *free_binding_level;
static GTY((deletable)) tree free_block_chain;
struct language_function GTY(())
{
int unused;
};
static void gnat_install_builtins (void);
static tree merge_sizes (tree, tree, tree, bool, bool);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static bool value_zerop (tree);
static void gnat_gimplify_function (tree);
static tree float_type_for_precision (int, enum machine_mode);
static tree convert_to_fat_pointer (tree, tree);
static tree convert_to_thin_pointer (tree, tree);
static tree make_descriptor_field (const char *,tree, tree, tree);
static bool value_factor_p (tree, HOST_WIDE_INT);
static bool potential_alignment_gap (tree, tree, tree);
void
init_gnat_to_gnu (void)
{
associate_gnat_to_gnu
= (tree *) ggc_alloc_cleared (max_gnat_nodes * sizeof (tree));
}
void
save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, bool no_check)
{
gcc_assert (!gnu_decl
|| (!associate_gnat_to_gnu[gnat_entity - First_Node_Id]
&& (no_check || DECL_P (gnu_decl))));
associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl;
}
tree
get_gnu_tree (Entity_Id gnat_entity)
{
gcc_assert (associate_gnat_to_gnu[gnat_entity - First_Node_Id]);
return associate_gnat_to_gnu[gnat_entity - First_Node_Id];
}
bool
present_gnu_tree (Entity_Id gnat_entity)
{
return (associate_gnat_to_gnu[gnat_entity - First_Node_Id]) != 0;
}
int
global_bindings_p (void)
{
return ((force_global || !current_function_decl) ? -1 : 0);
}
void
gnat_pushlevel ()
{
struct gnat_binding_level *newlevel = NULL;
if (free_binding_level)
{
newlevel = free_binding_level;
free_binding_level = free_binding_level->chain;
}
else
newlevel
= (struct gnat_binding_level *)
ggc_alloc (sizeof (struct gnat_binding_level));
if (free_block_chain)
{
newlevel->block = free_block_chain;
free_block_chain = TREE_CHAIN (free_block_chain);
TREE_CHAIN (newlevel->block) = NULL_TREE;
}
else
newlevel->block = make_node (BLOCK);
if (current_binding_level)
BLOCK_SUPERCONTEXT (newlevel->block) = current_binding_level->block;
BLOCK_VARS (newlevel->block) = BLOCK_SUBBLOCKS (newlevel->block) = NULL_TREE;
TREE_USED (newlevel->block) = 1;
newlevel->chain = current_binding_level;
newlevel->jmpbuf_decl = NULL_TREE;
current_binding_level = newlevel;
}
void
set_current_block_context (tree fndecl)
{
BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
DECL_INITIAL (fndecl) = current_binding_level->block;
}
void
set_block_jmpbuf_decl (tree decl)
{
current_binding_level->jmpbuf_decl = decl;
}
tree
get_block_jmpbuf_decl ()
{
return current_binding_level->jmpbuf_decl;
}
void
gnat_poplevel ()
{
struct gnat_binding_level *level = current_binding_level;
tree block = level->block;
BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block));
if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
;
else if (BLOCK_VARS (block) == NULL_TREE)
{
BLOCK_SUBBLOCKS (level->chain->block)
= chainon (BLOCK_SUBBLOCKS (block),
BLOCK_SUBBLOCKS (level->chain->block));
TREE_CHAIN (block) = free_block_chain;
free_block_chain = block;
}
else
{
TREE_CHAIN (block) = BLOCK_SUBBLOCKS (level->chain->block);
BLOCK_SUBBLOCKS (level->chain->block) = block;
TREE_USED (block) = 1;
set_block_for_group (block);
}
current_binding_level = level->chain;
level->chain = free_binding_level;
free_binding_level = level;
}
void
insert_block (tree block)
{
TREE_USED (block) = 1;
TREE_CHAIN (block) = BLOCK_SUBBLOCKS (current_binding_level->block);
BLOCK_SUBBLOCKS (current_binding_level->block) = block;
}
void
gnat_pushdecl (tree decl, Node_Id gnat_node)
{
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
DECL_CONTEXT (decl) = 0;
else
DECL_CONTEXT (decl) = current_function_decl;
TREE_NO_WARNING (decl) = (gnat_node == Empty || Warnings_Off (gnat_node));
if (Present (gnat_node))
Sloc_to_locus (Sloc (gnat_node), &DECL_SOURCE_LOCATION (decl));
add_decl_expr (decl, gnat_node);
if (!global_bindings_p ()
&& (TREE_CODE (decl) != TYPE_DECL
|| TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE))
{
TREE_CHAIN (decl) = BLOCK_VARS (current_binding_level->block);
BLOCK_VARS (current_binding_level->block) = decl;
}
if (TREE_CODE (decl) == TYPE_DECL
&& DECL_NAME (decl)
&& (!TYPE_NAME (TREE_TYPE (decl))
|| TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == IDENTIFIER_NODE
|| (TREE_CODE (TYPE_NAME (TREE_TYPE (decl))) == TYPE_DECL
&& DECL_ARTIFICIAL (TYPE_NAME (TREE_TYPE (decl)))
&& !DECL_ARTIFICIAL (decl))))
TYPE_NAME (TREE_TYPE (decl)) = decl;
if (TREE_CODE (decl) != CONST_DECL)
rest_of_decl_compilation (decl, global_bindings_p (), 0);
}
void
gnat_init_decl_processing (void)
{
input_line = 0;
current_function_decl = 0;
current_binding_level = 0;
free_binding_level = 0;
gnat_pushlevel ();
build_common_tree_nodes (true, true);
size_type_node = gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0);
set_sizetype (size_type_node);
build_common_tree_nodes_2 (0);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype),
Empty);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
integer_type_node),
Empty);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
char_type_node),
Empty);
gnat_pushdecl (build_decl (TYPE_DECL, get_identifier ("long integer"),
long_integer_type_node),
Empty);
ptr_void_type_node = build_pointer_type (void_type_node);
gnat_install_builtins ();
}
static void
gnat_install_builtins ()
{
build_common_builtin_nodes ();
targetm.init_builtins ();
}
void
init_gigi_decls (tree long_long_float_type, tree exception_type)
{
tree endlink, decl;
unsigned int i;
if (TREE_CODE (TREE_TYPE (long_long_float_type)) == INTEGER_TYPE)
{
longest_float_type_node = make_node (REAL_TYPE);
TYPE_PRECISION (longest_float_type_node) = LONG_DOUBLE_TYPE_SIZE;
layout_type (longest_float_type_node);
create_type_decl (get_identifier ("longest float type"),
longest_float_type_node, NULL, false, true, Empty);
}
else
longest_float_type_node = TREE_TYPE (long_long_float_type);
except_type_node = TREE_TYPE (exception_type);
unsigned_type_node = gnat_type_for_size (INT_TYPE_SIZE, 1);
create_type_decl (get_identifier ("unsigned int"), unsigned_type_node,
NULL, false, true, Empty);
void_type_decl_node = create_type_decl (get_identifier ("void"),
void_type_node, NULL, false, true,
Empty);
void_ftype = build_function_type (void_type_node, NULL_TREE);
ptr_void_ftype = build_pointer_type (void_ftype);
endlink = tree_cons (NULL_TREE, void_type_node, NULL_TREE);
malloc_decl = create_subprog_decl (get_identifier ("__gnat_malloc"),
NULL_TREE,
build_function_type (ptr_void_type_node,
tree_cons (NULL_TREE,
sizetype,
endlink)),
NULL_TREE, false, true, true, NULL,
Empty);
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, false, true, true, NULL, Empty);
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
build_index_type (build_int_cst (NULL_TREE, 5)));
create_type_decl (get_identifier ("JMPBUF_T"), jmpbuf_type, NULL,
false, true, Empty);
jmpbuf_ptr_type = build_pointer_type (jmpbuf_type);
get_jmpbuf_decl
= create_subprog_decl
(get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
NULL_TREE, build_function_type (jmpbuf_ptr_type, NULL_TREE),
NULL_TREE, false, true, true, NULL, Empty);
set_jmpbuf_decl
= create_subprog_decl
(get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, false, true, true, NULL, Empty);
get_excptr_decl
= create_subprog_decl
(get_identifier ("system__soft_links__get_gnat_exception"),
NULL_TREE,
build_function_type (build_pointer_type (except_type_node), NULL_TREE),
NULL_TREE, false, true, true, NULL, Empty);
raise_nodefer_decl
= create_subprog_decl
(get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
build_pointer_type (except_type_node),
endlink)),
NULL_TREE, false, true, true, NULL, Empty);
others_decl
= create_var_decl (get_identifier ("OTHERS"),
get_identifier ("__gnat_others_value"),
integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
all_others_decl
= create_var_decl (get_identifier ("ALL_OTHERS"),
get_identifier ("__gnat_all_others_value"),
integer_type_node, 0, 1, 0, 1, 1, 0, Empty);
begin_handler_decl
= create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, false, true, true, NULL, Empty);
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
ptr_void_type_node,
endlink)),
NULL_TREE, false, true, true, NULL, Empty);
if (No_Exception_Handlers_Set ())
{
decl
= create_subprog_decl
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
build_pointer_type (char_type_node),
tree_cons (NULL_TREE,
integer_type_node,
endlink))),
NULL_TREE, false, true, true, NULL, Empty);
for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
gnat_raise_decls[i] = decl;
}
else
for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
{
char name[17];
sprintf (name, "__gnat_rcheck_%.2d", i);
gnat_raise_decls[i]
= create_subprog_decl
(get_identifier (name), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE,
build_pointer_type
(char_type_node),
tree_cons (NULL_TREE,
integer_type_node,
endlink))),
NULL_TREE, false, true, true, NULL, Empty);
}
TREE_THIS_VOLATILE (raise_nodefer_decl) = 1;
TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
TREE_TYPE (raise_nodefer_decl)
= build_qualified_type (TREE_TYPE (raise_nodefer_decl),
TYPE_QUAL_VOLATILE);
for (i = 0; i < ARRAY_SIZE (gnat_raise_decls); i++)
{
TREE_THIS_VOLATILE (gnat_raise_decls[i]) = 1;
TREE_SIDE_EFFECTS (gnat_raise_decls[i]) = 1;
TREE_TYPE (gnat_raise_decls[i])
= build_qualified_type (TREE_TYPE (gnat_raise_decls[i]),
TYPE_QUAL_VOLATILE);
}
setjmp_decl
= create_subprog_decl
(get_identifier ("__builtin_setjmp"), NULL_TREE,
build_function_type (integer_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, false, true, true, NULL, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
update_setjmp_buf_decl
= create_subprog_decl
(get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
build_function_type (void_type_node,
tree_cons (NULL_TREE, jmpbuf_ptr_type, endlink)),
NULL_TREE, false, true, true, NULL, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
main_identifier_node = get_identifier ("main");
}
void
finish_record_type (tree record_type, tree fieldlist, bool has_rep,
bool defer_debug)
{
enum tree_code code = TREE_CODE (record_type);
tree ada_size = bitsize_zero_node;
tree size = bitsize_zero_node;
bool var_size = false;
bool had_size = TYPE_SIZE (record_type) != 0;
bool had_size_unit = TYPE_SIZE_UNIT (record_type) != 0;
tree field;
TYPE_FIELDS (record_type) = fieldlist;
TYPE_STUB_DECL (record_type)
= build_decl (TYPE_DECL, NULL_TREE, record_type);
DECL_ARTIFICIAL (TYPE_STUB_DECL (record_type)) = 1;
if (has_rep)
{
TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
TYPE_MODE (record_type) = BLKmode;
if (!had_size_unit)
TYPE_SIZE_UNIT (record_type) = size_zero_node;
if (!had_size)
TYPE_SIZE (record_type) = bitsize_zero_node;
else if (code == QUAL_UNION_TYPE)
code = UNION_TYPE;
}
else
{
TYPE_SIZE (record_type) = 0;
layout_type (record_type);
}
if (code == QUAL_UNION_TYPE)
fieldlist = nreverse (fieldlist);
for (field = fieldlist; field; field = TREE_CHAIN (field))
{
tree pos = bit_position (field);
tree type = TREE_TYPE (field);
tree this_size = DECL_SIZE (field);
tree this_ada_size = DECL_SIZE (field);
if (TREE_CODE (this_size) != INTEGER_CST)
var_size = true;
if ((TREE_CODE (type) == RECORD_TYPE || TREE_CODE (type) == UNION_TYPE
|| TREE_CODE (type) == QUAL_UNION_TYPE)
&& !TYPE_IS_FAT_POINTER_P (type)
&& !TYPE_CONTAINS_TEMPLATE_P (type)
&& TYPE_ADA_SIZE (type))
this_ada_size = TYPE_ADA_SIZE (type);
if (DECL_BIT_FIELD (field) && !STRICT_ALIGNMENT
&& value_factor_p (pos, BITS_PER_UNIT)
&& operand_equal_p (this_size, TYPE_SIZE (type), 0))
DECL_BIT_FIELD (field) = 0;
DECL_NONADDRESSABLE_P (field)
|= DECL_BIT_FIELD (field) && DECL_MODE (field) != BLKmode;
if (has_rep && !DECL_BIT_FIELD (field))
TYPE_ALIGN (record_type)
= MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
switch (code)
{
case UNION_TYPE:
ada_size = size_binop (MAX_EXPR, ada_size, this_ada_size);
size = size_binop (MAX_EXPR, size, this_size);
break;
case QUAL_UNION_TYPE:
ada_size
= fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
this_ada_size, ada_size));
size = fold (build3 (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
this_size, size));
break;
case RECORD_TYPE:
ada_size
= merge_sizes (ada_size, pos, this_ada_size,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
size = merge_sizes (size, pos, this_size,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
break;
default:
gcc_unreachable ();
}
}
if (code == QUAL_UNION_TYPE)
nreverse (fieldlist);
if (TREE_CODE (record_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type))
size = TYPE_SIZE (record_type);
if (!TYPE_IS_FAT_POINTER_P (record_type)
&& !TYPE_CONTAINS_TEMPLATE_P (record_type))
SET_TYPE_ADA_SIZE (record_type, ada_size);
if (has_rep)
{
tree size_unit
= (had_size_unit ? TYPE_SIZE_UNIT (record_type)
: convert (sizetype, size_binop (CEIL_DIV_EXPR, size,
bitsize_unit_node)));
TYPE_SIZE (record_type)
= variable_size (round_up (size, TYPE_ALIGN (record_type)));
TYPE_SIZE_UNIT (record_type)
= variable_size (round_up (size_unit,
TYPE_ALIGN (record_type) / BITS_PER_UNIT));
compute_record_mode (record_type);
}
if (!defer_debug)
{
if (var_size
&& !(TREE_CODE (record_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (record_type)))
{
tree new_record_type
= make_node (TREE_CODE (record_type) == QUAL_UNION_TYPE
? UNION_TYPE : TREE_CODE (record_type));
tree orig_name = TYPE_NAME (record_type);
tree orig_id
= (TREE_CODE (orig_name) == TYPE_DECL ? DECL_NAME (orig_name)
: orig_name);
tree new_id
= concat_id_with_name (orig_id,
TREE_CODE (record_type) == QUAL_UNION_TYPE
? "XVU" : "XVE");
tree last_pos = bitsize_zero_node;
tree old_field;
tree prev_old_field = 0;
TYPE_NAME (new_record_type) = new_id;
TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
TYPE_STUB_DECL (new_record_type)
= build_decl (TYPE_DECL, NULL_TREE, new_record_type);
DECL_ARTIFICIAL (TYPE_STUB_DECL (new_record_type)) = 1;
DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
= DECL_IGNORED_P (TYPE_STUB_DECL (record_type));
TYPE_SIZE (new_record_type) = size_int (TYPE_ALIGN (record_type));
TYPE_SIZE_UNIT (new_record_type)
= size_int (TYPE_ALIGN (record_type) / BITS_PER_UNIT);
for (old_field = TYPE_FIELDS (record_type); old_field;
old_field = TREE_CHAIN (old_field))
{
tree field_type = TREE_TYPE (old_field);
tree field_name = DECL_NAME (old_field);
tree new_field;
tree curpos = bit_position (old_field);
bool var = false;
unsigned int align = 0;
tree pos;
if (TREE_CODE (new_record_type) == UNION_TYPE)
pos = bitsize_zero_node, align = 0;
else
pos = compute_related_constant (curpos, last_pos);
if (!pos && TREE_CODE (curpos) == MULT_EXPR
&& TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST)
{
align = TREE_INT_CST_LOW (TREE_OPERAND (curpos, 1));
pos = compute_related_constant (curpos,
round_up (last_pos, align));
}
else if (!pos && TREE_CODE (curpos) == PLUS_EXPR
&& TREE_CODE (TREE_OPERAND (curpos, 1)) == INTEGER_CST
&& TREE_CODE (TREE_OPERAND (curpos, 0)) == MULT_EXPR
&& host_integerp (TREE_OPERAND
(TREE_OPERAND (curpos, 0), 1),
1))
{
align
= tree_low_cst
(TREE_OPERAND (TREE_OPERAND (curpos, 0), 1), 1);
pos = compute_related_constant (curpos,
round_up (last_pos, align));
}
else if (potential_alignment_gap (prev_old_field, old_field,
pos))
{
align = TYPE_ALIGN (field_type);
pos = compute_related_constant (curpos,
round_up (last_pos, align));
}
if (!pos)
pos = bitsize_zero_node;
if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
{
field_type = build_pointer_type (field_type);
var = true;
}
if (var || align != 0)
{
char suffix[6];
if (align != 0)
sprintf (suffix, "XV%c%u", var ? 'L' : 'A',
align / BITS_PER_UNIT);
else
strcpy (suffix, "XVL");
field_name = concat_id_with_name (field_name, suffix);
}
new_field = create_field_decl (field_name, field_type,
new_record_type, 0,
DECL_SIZE (old_field), pos, 0);
TREE_CHAIN (new_field) = TYPE_FIELDS (new_record_type);
TYPE_FIELDS (new_record_type) = new_field;
last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
(TREE_CODE (TREE_TYPE (old_field))
== QUAL_UNION_TYPE)
? bitsize_zero_node
: DECL_SIZE (old_field));
prev_old_field = old_field;
}
TYPE_FIELDS (new_record_type)
= nreverse (TYPE_FIELDS (new_record_type));
rest_of_type_compilation (new_record_type, global_bindings_p ());
}
rest_of_type_compilation (record_type, global_bindings_p ());
}
}
static tree
merge_sizes (tree last_size, tree first_bit, tree size, bool special,
bool has_rep)
{
tree type = TREE_TYPE (last_size);
tree new;
if (!special || TREE_CODE (size) != COND_EXPR)
{
new = size_binop (PLUS_EXPR, first_bit, size);
if (has_rep)
new = size_binop (MAX_EXPR, last_size, new);
}
else
new = fold (build3 (COND_EXPR, type, TREE_OPERAND (size, 0),
integer_zerop (TREE_OPERAND (size, 1))
? last_size : merge_sizes (last_size, first_bit,
TREE_OPERAND (size, 1),
1, has_rep),
integer_zerop (TREE_OPERAND (size, 2))
? last_size : merge_sizes (last_size, first_bit,
TREE_OPERAND (size, 2),
1, has_rep)));
while (TREE_CODE (new) == NON_LVALUE_EXPR)
new = TREE_OPERAND (new, 0);
return new;
}
static tree
compute_related_constant (tree op0, tree op1)
{
tree op0_var, op1_var;
tree op0_con = split_plus (op0, &op0_var);
tree op1_con = split_plus (op1, &op1_var);
tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
if (operand_equal_p (op0_var, op1_var, 0))
return result;
else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
return result;
else
return 0;
}
static tree
split_plus (tree in, tree *pvar)
{
STRIP_NOPS (in);
*pvar = convert (bitsizetype, in);
if (TREE_CODE (in) == INTEGER_CST)
{
*pvar = bitsize_zero_node;
return convert (bitsizetype, in);
}
else if (TREE_CODE (in) == PLUS_EXPR || TREE_CODE (in) == MINUS_EXPR)
{
tree lhs_var, rhs_var;
tree lhs_con = split_plus (TREE_OPERAND (in, 0), &lhs_var);
tree rhs_con = split_plus (TREE_OPERAND (in, 1), &rhs_var);
if (lhs_var == TREE_OPERAND (in, 0)
&& rhs_var == TREE_OPERAND (in, 1))
return bitsize_zero_node;
*pvar = size_binop (TREE_CODE (in), lhs_var, rhs_var);
return size_binop (TREE_CODE (in), lhs_con, rhs_con);
}
else
return bitsize_zero_node;
}
tree
create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
bool returns_unconstrained, bool returns_by_ref,
bool returns_with_dsp, bool returns_by_target_ptr)
{
tree param_type_list = NULL;
tree param_decl;
tree type;
for (param_decl = param_decl_list; param_decl;
param_decl = TREE_CHAIN (param_decl))
param_type_list = tree_cons (NULL_TREE, TREE_TYPE (param_decl),
param_type_list);
param_type_list = tree_cons (NULL_TREE, void_type_node, param_type_list);
param_type_list = nreverse (param_type_list);
type = build_function_type (return_type, param_type_list);
if (TYPE_CI_CO_LIST (type) || cico_list
|| TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
|| TYPE_RETURNS_BY_REF_P (type) != returns_by_ref
|| TYPE_RETURNS_BY_TARGET_PTR_P (type) != returns_by_target_ptr)
type = copy_type (type);
TYPE_CI_CO_LIST (type) = cico_list;
TYPE_RETURNS_UNCONSTRAINED_P (type) = returns_unconstrained;
TYPE_RETURNS_STACK_DEPRESSED (type) = returns_with_dsp;
TYPE_RETURNS_BY_REF_P (type) = returns_by_ref;
TYPE_RETURNS_BY_TARGET_PTR_P (type) = returns_by_target_ptr;
return type;
}
tree
copy_type (tree type)
{
tree new = copy_node (type);
TYPE_STUB_DECL (new) = TYPE_STUB_DECL (type);
TYPE_POINTER_TO (new) = 0;
TYPE_REFERENCE_TO (new) = 0;
TYPE_MAIN_VARIANT (new) = new;
TYPE_NEXT_VARIANT (new) = 0;
return new;
}
tree
create_index_type (tree min, tree max, tree index)
{
tree type = build_index_2_type (min, max);
if (TYPE_INDEX_TYPE (type) == index)
return type;
else if (TYPE_INDEX_TYPE (type))
type = copy_type (type);
SET_TYPE_INDEX_TYPE (type, index);
create_type_decl (NULL_TREE, type, NULL, true, false, Empty);
return type;
}
tree
create_type_decl (tree type_name, tree type, struct attrib *attr_list,
bool artificial_p, bool debug_info_p, Node_Id gnat_node)
{
tree type_decl = build_decl (TYPE_DECL, type_name, type);
enum tree_code code = TREE_CODE (type);
DECL_ARTIFICIAL (type_decl) = artificial_p;
process_attributes (type_decl, attr_list);
if (code == UNCONSTRAINED_ARRAY_TYPE || TYPE_IS_DUMMY_P (type)
|| !debug_info_p)
DECL_IGNORED_P (type_decl) = 1;
else if (code != ENUMERAL_TYPE && code != RECORD_TYPE
&& !((code == POINTER_TYPE || code == REFERENCE_TYPE)
&& TYPE_IS_DUMMY_P (TREE_TYPE (type))))
rest_of_decl_compilation (type_decl, global_bindings_p (), 0);
if (!TYPE_IS_DUMMY_P (type))
gnat_pushdecl (type_decl, gnat_node);
return type_decl;
}
tree
create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
bool const_flag, bool public_flag, bool extern_flag,
bool static_flag, struct attrib *attr_list, Node_Id gnat_node)
{
bool init_const
= (!var_init
? false
: (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
&& (global_bindings_p () || static_flag
? 0 != initializer_constant_valid_p (var_init,
TREE_TYPE (var_init))
: TREE_CONSTANT (var_init))));
tree var_decl
= build_decl ((const_flag && init_const
&& TYPE_SIZE (type) != 0
&& host_integerp (TYPE_SIZE_UNIT (type), 1)
&& 0 >= compare_tree_int (TYPE_SIZE_UNIT (type),
GET_MODE_SIZE (DCmode)))
? CONST_DECL : VAR_DECL, var_name, type);
if ((extern_flag && TREE_CODE (var_decl) != CONST_DECL)
|| (type_annotate_only && var_init && !TREE_CONSTANT (var_init)))
var_init = NULL_TREE;
#if !defined(ASM_OUTPUT_BSS) && !defined(ASM_OUTPUT_ALIGNED_BSS)
DECL_COMMON (var_decl) = !flag_no_common;
#endif
DECL_INITIAL (var_decl) = var_init;
TREE_READONLY (var_decl) = const_flag;
DECL_EXTERNAL (var_decl) = extern_flag;
TREE_PUBLIC (var_decl) = public_flag || extern_flag;
TREE_CONSTANT (var_decl) = TREE_CODE (var_decl) == CONST_DECL;
TREE_THIS_VOLATILE (var_decl) = TREE_SIDE_EFFECTS (var_decl)
= TYPE_VOLATILE (type);
TREE_STATIC (var_decl)
= public_flag || (global_bindings_p () ? !extern_flag : static_flag);
if (asm_name)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
process_attributes (var_decl, attr_list);
gnat_pushdecl (var_decl, gnat_node);
if (TREE_SIDE_EFFECTS (var_decl))
TREE_ADDRESSABLE (var_decl) = 1;
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, global_bindings_p (), 0);
return var_decl;
}
tree
create_field_decl (tree field_name, tree field_type, tree record_type,
int packed, tree size, tree pos, int addressable)
{
tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
DECL_CONTEXT (field_decl) = record_type;
TREE_READONLY (field_decl) = TYPE_READONLY (field_type);
if (packed && TYPE_MODE (field_type) == BLKmode)
DECL_ALIGN (field_decl) = BITS_PER_UNIT;
if (size)
size = convert (bitsizetype, size);
else if (packed == 1)
{
size = rm_size (field_type);
if (TREE_CODE (size) == INTEGER_CST
&& compare_tree_int (size, MAX_FIXED_MODE_SIZE) > 0)
size = round_up (size, BITS_PER_UNIT);
}
if (addressable >= 0
&& size
&& TREE_CODE (size) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
&& (!operand_equal_p (TYPE_SIZE (field_type), size, 0)
|| (pos && !value_factor_p (pos, TYPE_ALIGN (field_type)))
|| packed
|| (TYPE_ALIGN (record_type) != 0
&& TYPE_ALIGN (record_type) < TYPE_ALIGN (field_type))))
{
DECL_BIT_FIELD (field_decl) = 1;
DECL_SIZE (field_decl) = size;
if (!packed && !pos)
DECL_ALIGN (field_decl)
= (TYPE_ALIGN (record_type) != 0
? MIN (TYPE_ALIGN (record_type), TYPE_ALIGN (field_type))
: TYPE_ALIGN (field_type));
}
DECL_PACKED (field_decl) = pos ? DECL_BIT_FIELD (field_decl) : packed;
DECL_ALIGN (field_decl)
= MAX (DECL_ALIGN (field_decl),
DECL_BIT_FIELD (field_decl) ? 1
: packed && TYPE_MODE (field_type) != BLKmode ? BITS_PER_UNIT
: TYPE_ALIGN (field_type));
if (pos)
{
unsigned int known_align;
if (host_integerp (pos, 1))
known_align = tree_low_cst (pos, 1) & - tree_low_cst (pos, 1);
else
known_align = BITS_PER_UNIT;
if (TYPE_ALIGN (record_type)
&& (known_align == 0 || known_align > TYPE_ALIGN (record_type)))
known_align = TYPE_ALIGN (record_type);
layout_decl (field_decl, known_align);
SET_DECL_OFFSET_ALIGN (field_decl,
host_integerp (pos, 1) ? BIGGEST_ALIGNMENT
: BITS_PER_UNIT);
pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
&DECL_FIELD_BIT_OFFSET (field_decl),
DECL_OFFSET_ALIGN (field_decl), pos);
DECL_HAS_REP_P (field_decl) = 1;
}
if (must_pass_by_ref (field_type) || default_pass_by_ref (field_type))
addressable = 1;
if (AGGREGATE_TYPE_P (field_type))
addressable = 1;
DECL_NONADDRESSABLE_P (field_decl) = !addressable;
return field_decl;
}
static bool
value_zerop (tree exp)
{
if (TREE_CODE (exp) == COMPOUND_EXPR)
return value_zerop (TREE_OPERAND (exp, 1));
return integer_zerop (exp);
}
tree
create_param_decl (tree param_name, tree param_type, bool readonly)
{
tree param_decl = build_decl (PARM_DECL, param_name, param_type);
if (targetm.calls.promote_prototypes (param_type)
&& (TREE_CODE (param_type) == INTEGER_TYPE
|| TREE_CODE (param_type) == ENUMERAL_TYPE)
&& TYPE_PRECISION (param_type) < TYPE_PRECISION (integer_type_node))
{
if (TREE_CODE (param_type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (param_type))
{
param_type
= copy_type (build_range_type (integer_type_node,
TYPE_MIN_VALUE (param_type),
TYPE_MAX_VALUE (param_type)));
TYPE_BIASED_REPRESENTATION_P (param_type) = 1;
}
else
param_type = integer_type_node;
}
DECL_ARG_TYPE (param_decl) = param_type;
DECL_ARG_TYPE_AS_WRITTEN (param_decl) = param_type;
TREE_READONLY (param_decl) = readonly;
return param_decl;
}
void
process_attributes (tree decl, struct attrib *attr_list)
{
for (; attr_list; attr_list = attr_list->next)
switch (attr_list->type)
{
case ATTR_MACHINE_ATTRIBUTE:
decl_attributes (&decl, tree_cons (attr_list->name, attr_list->args,
NULL_TREE),
ATTR_FLAG_TYPE_IN_PLACE);
break;
case ATTR_LINK_ALIAS:
TREE_STATIC (decl) = 1;
assemble_alias (decl, attr_list->name);
break;
case ATTR_WEAK_EXTERNAL:
if (SUPPORTS_WEAK)
declare_weak (decl);
else
post_error ("?weak declarations not supported on this target",
attr_list->error_point);
break;
case ATTR_LINK_SECTION:
if (targetm.have_named_sections)
{
DECL_SECTION_NAME (decl)
= build_string (IDENTIFIER_LENGTH (attr_list->name),
IDENTIFIER_POINTER (attr_list->name));
DECL_COMMON (decl) = 0;
}
else
post_error ("?section attributes are not supported for this target",
attr_list->error_point);
break;
}
}
static bool
value_factor_p (tree value, HOST_WIDE_INT factor)
{
if (host_integerp (value, 1))
return tree_low_cst (value, 1) % factor == 0;
if (TREE_CODE (value) == MULT_EXPR)
return (value_factor_p (TREE_OPERAND (value, 0), factor)
|| value_factor_p (TREE_OPERAND (value, 1), factor));
return 0;
}
static bool
potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
{
if (!prev_field)
return false;
if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
return false;
if (offset && host_integerp (offset, 1))
return !integer_zerop (offset);
if (host_integerp (DECL_SIZE (prev_field), 1)
&& host_integerp (bit_position (prev_field), 1))
return ((tree_low_cst (bit_position (prev_field), 1)
+ tree_low_cst (DECL_SIZE (prev_field), 1))
% DECL_ALIGN (curr_field) != 0);
if (value_factor_p (bit_position (prev_field), DECL_ALIGN (curr_field))
&& value_factor_p (DECL_SIZE (prev_field), DECL_ALIGN (curr_field)))
return false;
return true;
}
tree
create_label_decl (tree label_name)
{
tree label_decl = build_decl (LABEL_DECL, label_name, void_type_node);
DECL_CONTEXT (label_decl) = current_function_decl;
DECL_MODE (label_decl) = VOIDmode;
DECL_SOURCE_LOCATION (label_decl) = input_location;
return label_decl;
}
tree
create_subprog_decl (tree subprog_name, tree asm_name,
tree subprog_type, tree param_decl_list, bool inline_flag,
bool public_flag, bool extern_flag,
struct attrib *attr_list, Node_Id gnat_node)
{
tree return_type = TREE_TYPE (subprog_type);
tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
if (current_function_decl && DECL_INLINE (current_function_decl)
&& DECL_EXTERNAL (current_function_decl))
extern_flag = true;
DECL_EXTERNAL (subprog_decl) = extern_flag;
TREE_PUBLIC (subprog_decl) = public_flag;
TREE_STATIC (subprog_decl) = 1;
TREE_READONLY (subprog_decl) = TYPE_READONLY (subprog_type);
TREE_THIS_VOLATILE (subprog_decl) = TYPE_VOLATILE (subprog_type);
TREE_SIDE_EFFECTS (subprog_decl) = TYPE_VOLATILE (subprog_type);
DECL_ARGUMENTS (subprog_decl) = param_decl_list;
DECL_RESULT (subprog_decl) = build_decl (RESULT_DECL, 0, return_type);
DECL_ARTIFICIAL (DECL_RESULT (subprog_decl)) = 1;
DECL_IGNORED_P (DECL_RESULT (subprog_decl)) = 1;
if (inline_flag)
DECL_DECLARED_INLINE_P (subprog_decl) = 1;
if (asm_name)
SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
process_attributes (subprog_decl, attr_list);
gnat_pushdecl (subprog_decl, gnat_node);
rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
return subprog_decl;
}
void
begin_subprog_body (tree subprog_decl)
{
tree param_decl;
current_function_decl = subprog_decl;
announce_function (subprog_decl);
gnat_pushlevel ();
for (param_decl = DECL_ARGUMENTS (subprog_decl); param_decl;
param_decl = TREE_CHAIN (param_decl))
DECL_CONTEXT (param_decl) = subprog_decl;
make_decl_rtl (subprog_decl);
get_pending_sizes ();
}
void
end_subprog_body (tree body)
{
tree fndecl = current_function_decl;
BLOCK_VARS (current_binding_level->block) = 0;
BLOCK_SUPERCONTEXT (current_binding_level->block) = fndecl;
DECL_INITIAL (fndecl) = current_binding_level->block;
gnat_poplevel ();
DECL_INLINE (fndecl)
= DECL_DECLARED_INLINE_P (fndecl) || flag_inline_trees == 2;
get_pending_sizes ();
DECL_CONTEXT (DECL_RESULT (fndecl)) = fndecl;
DECL_SAVED_TREE (fndecl) = body;
current_function_decl = DECL_CONTEXT (fndecl);
cfun = NULL;
if (type_annotate_only)
return;
if (!DECL_CONTEXT (fndecl))
{
gnat_gimplify_function (fndecl);
cgraph_finalize_function (fndecl, false);
}
else
(void) cgraph_node (fndecl);
}
static void
gnat_gimplify_function (tree fndecl)
{
struct cgraph_node *cgn;
dump_function (TDI_original, fndecl);
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
cgn = cgraph_node (fndecl);
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gnat_gimplify_function (cgn->decl);
}
tree
builtin_function (const char *name, tree type, int function_code,
enum built_in_class class, const char *library_name,
tree attrs)
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
if (library_name)
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (library_name));
gnat_pushdecl (decl, Empty);
DECL_BUILT_IN_CLASS (decl) = class;
DECL_FUNCTION_CODE (decl) = function_code;
if (attrs)
decl_attributes (&decl, attrs, ATTR_FLAG_BUILT_IN);
return decl;
}
tree
gnat_type_for_size (unsigned precision, int unsignedp)
{
tree t;
char type_name[20];
if (precision <= 2 * MAX_BITS_PER_WORD
&& signed_and_unsigned_types[precision][unsignedp])
return signed_and_unsigned_types[precision][unsignedp];
if (unsignedp)
t = make_unsigned_type (precision);
else
t = make_signed_type (precision);
if (precision <= 2 * MAX_BITS_PER_WORD)
signed_and_unsigned_types[precision][unsignedp] = t;
if (!TYPE_NAME (t))
{
sprintf (type_name, "%sSIGNED_%d", unsignedp ? "UN" : "", precision);
TYPE_NAME (t) = get_identifier (type_name);
}
return t;
}
static tree
float_type_for_precision (int precision, enum machine_mode mode)
{
tree t;
char type_name[20];
if (float_types[(int) mode])
return float_types[(int) mode];
float_types[(int) mode] = t = make_node (REAL_TYPE);
TYPE_PRECISION (t) = precision;
layout_type (t);
gcc_assert (TYPE_MODE (t) == mode);
if (!TYPE_NAME (t))
{
sprintf (type_name, "FLOAT_%d", precision);
TYPE_NAME (t) = get_identifier (type_name);
}
return t;
}
tree
gnat_type_for_mode (enum machine_mode mode, int unsignedp)
{
if (mode == BLKmode)
return NULL_TREE;
else if (mode == VOIDmode)
return void_type_node;
else if (COMPLEX_MODE_P (mode))
return NULL_TREE;
else if (SCALAR_FLOAT_MODE_P (mode))
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else if (SCALAR_INT_MODE_P (mode))
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
else
return NULL_TREE;
}
tree
gnat_unsigned_type (tree type_node)
{
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 1);
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
{
type = copy_node (type);
TREE_TYPE (type) = type_node;
}
else if (TREE_TYPE (type_node)
&& TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
&& TYPE_MODULAR_P (TREE_TYPE (type_node)))
{
type = copy_node (type);
TREE_TYPE (type) = TREE_TYPE (type_node);
}
return type;
}
tree
gnat_signed_type (tree type_node)
{
tree type = gnat_type_for_size (TYPE_PRECISION (type_node), 0);
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
{
type = copy_node (type);
TREE_TYPE (type) = type_node;
}
else if (TREE_TYPE (type_node)
&& TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
&& TYPE_MODULAR_P (TREE_TYPE (type_node)))
{
type = copy_node (type);
TREE_TYPE (type) = TREE_TYPE (type_node);
}
return type;
}
tree
gnat_signed_or_unsigned_type (int unsignedp, tree type)
{
if (!INTEGRAL_TYPE_P (type) || TYPE_UNSIGNED (type) == unsignedp)
return type;
else
return gnat_type_for_size (TYPE_PRECISION (type), unsignedp);
}
tree
max_size (tree exp, bool max_p)
{
enum tree_code code = TREE_CODE (exp);
tree type = TREE_TYPE (exp);
switch (TREE_CODE_CLASS (code))
{
case tcc_declaration:
case tcc_constant:
return exp;
case tcc_exceptional:
if (code == TREE_LIST)
return tree_cons (TREE_PURPOSE (exp),
max_size (TREE_VALUE (exp), max_p),
TREE_CHAIN (exp)
? max_size (TREE_CHAIN (exp), max_p) : NULL_TREE);
break;
case tcc_reference:
if (!CONTAINS_PLACEHOLDER_P (exp))
return exp;
type = TREE_TYPE (TREE_OPERAND (exp, 1));
return
max_size (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type), true);
case tcc_comparison:
return max_p ? size_one_node : size_zero_node;
case tcc_unary:
case tcc_binary:
case tcc_expression:
switch (TREE_CODE_LENGTH (code))
{
case 1:
if (code == NON_LVALUE_EXPR)
return max_size (TREE_OPERAND (exp, 0), max_p);
else
return
fold (build1 (code, type,
max_size (TREE_OPERAND (exp, 0),
code == NEGATE_EXPR ? !max_p : max_p)));
case 2:
if (code == COMPOUND_EXPR)
return max_size (TREE_OPERAND (exp, 1), max_p);
{
tree lhs = max_size (TREE_OPERAND (exp, 0), max_p);
tree rhs = max_size (TREE_OPERAND (exp, 1),
code == MINUS_EXPR ? !max_p : max_p);
if (max_p && code == MIN_EXPR && TREE_OVERFLOW (rhs))
return lhs;
else if (max_p && code == MIN_EXPR && TREE_OVERFLOW (lhs))
return rhs;
else if ((code == MINUS_EXPR || code == PLUS_EXPR)
&& ((TREE_CONSTANT (lhs) && TREE_OVERFLOW (lhs))
|| operand_equal_p (lhs, TYPE_MAX_VALUE (type), 0))
&& !TREE_CONSTANT (rhs))
return lhs;
else
return fold (build2 (code, type, lhs, rhs));
}
case 3:
if (code == SAVE_EXPR)
return exp;
else if (code == COND_EXPR)
return fold (build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
max_size (TREE_OPERAND (exp, 1), max_p),
max_size (TREE_OPERAND (exp, 2), max_p)));
else if (code == CALL_EXPR && TREE_OPERAND (exp, 1))
return build3 (CALL_EXPR, type, TREE_OPERAND (exp, 0),
max_size (TREE_OPERAND (exp, 1), max_p), NULL);
}
default:
break;
}
gcc_unreachable ();
}
tree
build_template (tree template_type, tree array_type, tree expr)
{
tree template_elts = NULL_TREE;
tree bound_list = NULL_TREE;
tree field;
if (TREE_CODE (array_type) == RECORD_TYPE
&& (TYPE_IS_PADDING_P (array_type)
|| TYPE_JUSTIFIED_MODULAR_P (array_type)))
array_type = TREE_TYPE (TYPE_FIELDS (array_type));
if (TREE_CODE (array_type) == ARRAY_TYPE
|| (TREE_CODE (array_type) == INTEGER_TYPE
&& TYPE_HAS_ACTUAL_BOUNDS_P (array_type)))
bound_list = TYPE_ACTUAL_BOUNDS (array_type);
for (field = TYPE_FIELDS (template_type); field;
(bound_list
? (bound_list = TREE_CHAIN (bound_list))
: (array_type = TREE_TYPE (array_type))),
field = TREE_CHAIN (TREE_CHAIN (field)))
{
tree bounds, min, max;
if (bound_list)
bounds = TREE_VALUE (bound_list);
else if (TREE_CODE (array_type) == ARRAY_TYPE)
bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
else if (expr && TREE_CODE (expr) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (expr))
bounds = TREE_TYPE (field);
else
gcc_unreachable ();
min = convert (TREE_TYPE (TREE_CHAIN (field)), TYPE_MIN_VALUE (bounds));
max = convert (TREE_TYPE (field), TYPE_MAX_VALUE (bounds));
min = SUBSTITUTE_PLACEHOLDER_IN_EXPR (min, expr);
max = SUBSTITUTE_PLACEHOLDER_IN_EXPR (max, expr);
template_elts = tree_cons (TREE_CHAIN (field), max,
tree_cons (field, min, template_elts));
}
return gnat_build_constructor (template_type, nreverse (template_elts));
}
tree
build_vms_descriptor (tree type, Mechanism_Type mech, Entity_Id gnat_entity)
{
tree record_type = make_node (RECORD_TYPE);
tree field_list = 0;
int class;
int dtype = 0;
tree inner_type;
int ndim;
int i;
tree *idx_arr;
tree tem;
if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
type = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))));
if (TREE_CODE (type) != ARRAY_TYPE)
ndim = 0;
else
for (ndim = 1, inner_type = type;
TREE_CODE (TREE_TYPE (inner_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (inner_type));
ndim++, inner_type = TREE_TYPE (inner_type))
;
idx_arr = (tree *) alloca (ndim * sizeof (tree));
if (mech != By_Descriptor_NCA
&& TREE_CODE (type) == ARRAY_TYPE && TYPE_CONVENTION_FORTRAN_P (type))
for (i = ndim - 1, inner_type = type;
i >= 0;
i--, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
else
for (i = 0, inner_type = type;
i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
idx_arr[i] = TYPE_DOMAIN (inner_type);
switch (TREE_CODE (type))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
if (TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
case 6:
dtype = 10;
break;
case 9:
dtype = 11;
break;
case 15:
dtype = 27;
break;
}
else
switch (GET_MODE_BITSIZE (TYPE_MODE (type)))
{
case 8:
dtype = TYPE_UNSIGNED (type) ? 2 : 6;
break;
case 16:
dtype = TYPE_UNSIGNED (type) ? 3 : 7;
break;
case 32:
dtype = TYPE_UNSIGNED (type) ? 4 : 8;
break;
case 64:
dtype = TYPE_UNSIGNED (type) ? 5 : 9;
break;
case 128:
dtype = TYPE_UNSIGNED (type) ? 25 : 26;
break;
}
break;
case REAL_TYPE:
dtype = GET_MODE_BITSIZE (TYPE_MODE (type)) == 32 ? 52 : 53;
break;
case COMPLEX_TYPE:
if (TREE_CODE (TREE_TYPE (type)) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type))
switch (tree_low_cst (TYPE_DIGITS_VALUE (type), 1))
{
case 6:
dtype = 12;
break;
case 9:
dtype = 13;
break;
case 15:
dtype = 29;
}
else
dtype = GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (type))) == 32 ? 54: 55;
break;
case ARRAY_TYPE:
dtype = 14;
break;
default:
break;
}
switch (mech)
{
case By_Descriptor_A:
class = 4;
break;
case By_Descriptor_NCA:
class = 10;
break;
case By_Descriptor_SB:
class = 15;
break;
default:
class = 1;
}
field_list
= chainon (field_list,
make_descriptor_field
("LENGTH", gnat_type_for_size (16, 1), record_type,
size_in_bytes (mech == By_Descriptor_A ? inner_type : type)));
field_list = chainon (field_list,
make_descriptor_field ("DTYPE",
gnat_type_for_size (8, 1),
record_type, size_int (dtype)));
field_list = chainon (field_list,
make_descriptor_field ("CLASS",
gnat_type_for_size (8, 1),
record_type, size_int (class)));
field_list
= chainon (field_list,
make_descriptor_field
("POINTER",
build_pointer_type_for_mode (type, SImode, false), record_type,
build1 (ADDR_EXPR,
build_pointer_type_for_mode (type, SImode, false),
build0 (PLACEHOLDER_EXPR, type))));
switch (mech)
{
case By_Descriptor:
case By_Descriptor_S:
break;
case By_Descriptor_SB:
field_list
= chainon (field_list,
make_descriptor_field
("SB_L1", gnat_type_for_size (32, 1), record_type,
TREE_CODE (type) == ARRAY_TYPE
? TYPE_MIN_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
field_list
= chainon (field_list,
make_descriptor_field
("SB_L2", gnat_type_for_size (32, 1), record_type,
TREE_CODE (type) == ARRAY_TYPE
? TYPE_MAX_VALUE (TYPE_DOMAIN (type)) : size_zero_node));
break;
case By_Descriptor_A:
case By_Descriptor_NCA:
field_list = chainon (field_list,
make_descriptor_field ("SCALE",
gnat_type_for_size (8, 1),
record_type,
size_zero_node));
field_list = chainon (field_list,
make_descriptor_field ("DIGITS",
gnat_type_for_size (8, 1),
record_type,
size_zero_node));
field_list
= chainon (field_list,
make_descriptor_field
("AFLAGS", gnat_type_for_size (8, 1), record_type,
size_int (mech == By_Descriptor_NCA
? 0
: (TREE_CODE (type) == ARRAY_TYPE
&& TYPE_CONVENTION_FORTRAN_P (type)
? 224 : 192))));
field_list = chainon (field_list,
make_descriptor_field ("DIMCT",
gnat_type_for_size (8, 1),
record_type,
size_int (ndim)));
field_list = chainon (field_list,
make_descriptor_field ("ARSIZE",
gnat_type_for_size (32, 1),
record_type,
size_in_bytes (type)));
tem = build0 (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
tem = build4 (ARRAY_REF, TREE_TYPE (inner_type), tem,
convert (TYPE_DOMAIN (inner_type), size_zero_node),
NULL_TREE, NULL_TREE);
field_list
= chainon (field_list,
make_descriptor_field
("A0",
build_pointer_type_for_mode (inner_type, SImode, false),
record_type,
build1 (ADDR_EXPR,
build_pointer_type_for_mode (inner_type, SImode,
false),
tem)));
tem = size_int (1);
for (i = 0; i < ndim; i++)
{
char fname[3];
tree idx_length
= size_binop (MULT_EXPR, tem,
size_binop (PLUS_EXPR,
size_binop (MINUS_EXPR,
TYPE_MAX_VALUE (idx_arr[i]),
TYPE_MIN_VALUE (idx_arr[i])),
size_int (1)));
fname[0] = (mech == By_Descriptor_NCA ? 'S' : 'M');
fname[1] = '0' + i, fname[2] = 0;
field_list
= chainon (field_list,
make_descriptor_field (fname,
gnat_type_for_size (32, 1),
record_type, idx_length));
if (mech == By_Descriptor_NCA)
tem = idx_length;
}
for (i = 0; i < ndim; i++)
{
char fname[3];
fname[0] = 'L', fname[1] = '0' + i, fname[2] = 0;
field_list
= chainon (field_list,
make_descriptor_field
(fname, gnat_type_for_size (32, 1), record_type,
TYPE_MIN_VALUE (idx_arr[i])));
fname[0] = 'U';
field_list
= chainon (field_list,
make_descriptor_field
(fname, gnat_type_for_size (32, 1), record_type,
TYPE_MAX_VALUE (idx_arr[i])));
}
break;
default:
post_error ("unsupported descriptor type for &", gnat_entity);
}
finish_record_type (record_type, field_list, false, true);
create_type_decl (create_concat_name (gnat_entity, "DESC"), record_type,
NULL, true, false, gnat_entity);
return record_type;
}
static tree
make_descriptor_field (const char *name, tree type,
tree rec_type, tree initial)
{
tree field
= create_field_decl (get_identifier (name), type, rec_type, 0, 0, 0, 0);
DECL_INITIAL (field) = initial;
return field;
}
tree
build_unc_object_type (tree template_type, tree object_type, tree name)
{
tree type = make_node (RECORD_TYPE);
tree template_field = create_field_decl (get_identifier ("BOUNDS"),
template_type, type, 0, 0, 0, 1);
tree array_field = create_field_decl (get_identifier ("ARRAY"), object_type,
type, 0, 0, 0, 1);
TYPE_NAME (type) = name;
TYPE_CONTAINS_TEMPLATE_P (type) = 1;
finish_record_type (type,
chainon (chainon (NULL_TREE, template_field),
array_field),
false, false);
return type;
}
void
update_pointer_to (tree old_type, tree new_type)
{
tree ptr = TYPE_POINTER_TO (old_type);
tree ref = TYPE_REFERENCE_TO (old_type);
tree ptr1, ref1;
tree type;
if (TYPE_MAIN_VARIANT (old_type) == old_type)
for (type = TYPE_NEXT_VARIANT (old_type); type;
type = TYPE_NEXT_VARIANT (type))
update_pointer_to (type, new_type);
if (!ptr && !ref)
return;
new_type = build_qualified_type (new_type,
TYPE_QUALS (old_type)
| TYPE_QUALS (new_type));
if (old_type == new_type)
return;
if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
{
TYPE_POINTER_TO (new_type) = ptr;
TYPE_REFERENCE_TO (new_type) = ref;
for (; ptr; ptr = TYPE_NEXT_PTR_TO (ptr))
for (ptr1 = TYPE_MAIN_VARIANT (ptr); ptr1;
ptr1 = TYPE_NEXT_VARIANT (ptr1))
{
TREE_TYPE (ptr1) = new_type;
if (TYPE_NAME (ptr1)
&& TREE_CODE (TYPE_NAME (ptr1)) == TYPE_DECL
&& TREE_CODE (new_type) != ENUMERAL_TYPE)
rest_of_decl_compilation (TYPE_NAME (ptr1),
global_bindings_p (), 0);
}
for (; ref; ref = TYPE_NEXT_PTR_TO (ref))
for (ref1 = TYPE_MAIN_VARIANT (ref); ref1;
ref1 = TYPE_NEXT_VARIANT (ref1))
{
TREE_TYPE (ref1) = new_type;
if (TYPE_NAME (ref1)
&& TREE_CODE (TYPE_NAME (ref1)) == TYPE_DECL
&& TREE_CODE (new_type) != ENUMERAL_TYPE)
rest_of_decl_compilation (TYPE_NAME (ref1),
global_bindings_p (), 0);
}
}
else if (TREE_CODE (ptr) != RECORD_TYPE || !TYPE_IS_FAT_POINTER_P (ptr))
gcc_unreachable ();
else
{
tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
tree ptr_temp_type;
tree new_ref;
tree var;
SET_DECL_ORIGINAL_FIELD (TYPE_FIELDS (ptr),
TYPE_FIELDS (TYPE_POINTER_TO (new_type)));
SET_DECL_ORIGINAL_FIELD (TREE_CHAIN (TYPE_FIELDS (ptr)),
TREE_CHAIN (TYPE_FIELDS
(TYPE_POINTER_TO (new_type))));
TYPE_FIELDS (ptr) = TYPE_FIELDS (TYPE_POINTER_TO (new_type));
DECL_CONTEXT (TYPE_FIELDS (ptr)) = ptr;
DECL_CONTEXT (TREE_CHAIN (TYPE_FIELDS (ptr))) = ptr;
ptr_temp_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (ptr)));
new_ref = build3 (COMPONENT_REF, ptr_temp_type,
build0 (PLACEHOLDER_EXPR, ptr),
TREE_CHAIN (TYPE_FIELDS (ptr)), NULL_TREE);
update_pointer_to
(TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
gnat_substitute_in_type (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))),
TREE_CHAIN (TYPE_FIELDS (ptr)), new_ref));
for (var = TYPE_MAIN_VARIANT (ptr); var; var = TYPE_NEXT_VARIANT (var))
SET_TYPE_UNCONSTRAINED_ARRAY (var, new_type);
TYPE_POINTER_TO (new_type) = TYPE_REFERENCE_TO (new_type)
= TREE_TYPE (new_type) = ptr;
update_pointer_to (TYPE_OBJECT_RECORD_TYPE (old_type), new_obj_rec);
TREE_TYPE (TYPE_FIELDS (new_obj_rec)) = TREE_TYPE (ptr_temp_type);
TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr)));
DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
= TYPE_SIZE (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec)))
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (ptr))));
TYPE_SIZE (new_obj_rec)
= size_binop (PLUS_EXPR,
DECL_SIZE (TYPE_FIELDS (new_obj_rec)),
DECL_SIZE (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
TYPE_SIZE_UNIT (new_obj_rec)
= size_binop (PLUS_EXPR,
DECL_SIZE_UNIT (TYPE_FIELDS (new_obj_rec)),
DECL_SIZE_UNIT (TREE_CHAIN (TYPE_FIELDS (new_obj_rec))));
rest_of_type_compilation (ptr, global_bindings_p ());
}
}
static tree
convert_to_fat_pointer (tree type, tree expr)
{
tree template_type = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type))));
tree template, template_addr;
tree etype = TREE_TYPE (expr);
if (integer_zerop (expr))
return
gnat_build_constructor
(type,
tree_cons (TYPE_FIELDS (type),
convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
convert (build_pointer_type (template_type),
expr),
NULL_TREE)));
else if (TYPE_THIN_POINTER_P (etype))
{
tree fields = TYPE_FIELDS (TREE_TYPE (etype));
expr = save_expr (expr);
if (TREE_CODE (expr) == ADDR_EXPR)
expr = TREE_OPERAND (expr, 0);
else
expr = build1 (INDIRECT_REF, TREE_TYPE (etype), expr);
template = build_component_ref (expr, NULL_TREE, fields, false);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
TREE_CHAIN (fields), false));
}
else
template = build_template (template_type, TREE_TYPE (etype), expr);
template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
return
gnat_build_constructor
(type, tree_cons (TYPE_FIELDS (type),
convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
template_addr, NULL_TREE)));
}
static tree
convert_to_thin_pointer (tree type, tree expr)
{
if (!TYPE_FAT_POINTER_P (TREE_TYPE (expr)))
expr
= convert_to_fat_pointer
(TREE_TYPE (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type))), expr);
expr = build_component_ref (expr, NULL_TREE, TYPE_FIELDS (TREE_TYPE (expr)),
false);
expr = build1 (NOP_EXPR, type, expr);
return expr;
}
tree
convert (tree type, tree expr)
{
enum tree_code code = TREE_CODE (type);
tree etype = TREE_TYPE (expr);
enum tree_code ecode = TREE_CODE (etype);
tree tem;
if (type == etype)
return expr;
else if (ecode == RECORD_TYPE && code == RECORD_TYPE
&& TYPE_IS_PADDING_P (type) && TYPE_IS_PADDING_P (etype)
&& (!TREE_CONSTANT (TYPE_SIZE (type))
|| !TREE_CONSTANT (TYPE_SIZE (etype))))
;
else if (ecode == RECORD_TYPE && TYPE_IS_PADDING_P (etype))
{
if (TREE_CODE (expr) == CONSTRUCTOR
&& CONSTRUCTOR_ELTS (expr)
&& TREE_PURPOSE (CONSTRUCTOR_ELTS (expr)) == TYPE_FIELDS (etype))
return TREE_VALUE (CONSTRUCTOR_ELTS (expr));
else
return convert (type,
build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), false));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
&& !TREE_CONSTANT (TYPE_SIZE (type)))
expr = TREE_OPERAND (expr, 0);
if (TREE_CODE (expr) == COMPONENT_REF
&& TREE_CODE (TREE_TYPE (TREE_OPERAND (expr, 0))) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (expr, 0)))
&& !TREE_CONSTANT (TYPE_SIZE (type)))
return convert (type, TREE_OPERAND (expr, 0));
else if (TREE_CODE (etype) == RECORD_TYPE
&& CONTAINS_PLACEHOLDER_P (DECL_SIZE (TYPE_FIELDS (type))))
return unchecked_convert (type, expr, false);
else
return
gnat_build_constructor (type,
tree_cons (TYPE_FIELDS (type),
convert (TREE_TYPE
(TYPE_FIELDS (type)),
expr),
NULL_TREE));
}
if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
return convert (type, fold (build2 (PLUS_EXPR, TREE_TYPE (etype),
fold (build1 (NOP_EXPR,
TREE_TYPE (etype),
expr)),
TYPE_MIN_VALUE (etype))));
if (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), false));
if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type))
{
tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
expr = maybe_unconstrained_array (expr);
return
gnat_build_constructor
(type,
tree_cons (TYPE_FIELDS (type),
build_template (TREE_TYPE (TYPE_FIELDS (type)),
obj_type, NULL_TREE),
tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
convert (obj_type, expr), NULL_TREE)));
}
switch (TREE_CODE (expr))
{
case ERROR_MARK:
return expr;
case NULL_EXPR:
expr = copy_node (expr);
TREE_TYPE (expr) = type;
return expr;
case STRING_CST:
if (code == ecode && AGGREGATE_TYPE_P (etype)
&& !(TREE_CODE (TYPE_SIZE (etype)) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (type)) != INTEGER_CST)
&& (TREE_CODE (expr) == STRING_CST
|| get_alias_set (etype) == get_alias_set (type)))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
return expr;
}
break;
case UNCONSTRAINED_ARRAY_REF:
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (expr, 0),
get_identifier ("P_ARRAY"),
NULL_TREE, false));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
case VIEW_CONVERT_EXPR:
if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
&& !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
return convert (type, TREE_OPERAND (expr, 0));
break;
case INDIRECT_REF:
if (0
&& (TREE_CODE (type) == RECORD_TYPE
|| TREE_CODE (type) == UNION_TYPE)
&& (TREE_CODE (etype) == RECORD_TYPE
|| TREE_CODE (etype) == UNION_TYPE)
&& !TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
return build_unary_op (INDIRECT_REF, NULL_TREE,
convert (build_pointer_type (type),
TREE_OPERAND (expr, 0)));
break;
default:
break;
}
if (TYPE_FAT_POINTER_P (type) && !TYPE_FAT_POINTER_P (etype))
return convert_to_fat_pointer (type, expr);
else if (AGGREGATE_TYPE_P (type)
&& TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
return build1 (VIEW_CONVERT_EXPR, type, expr);
else if (TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype)
|| (code == INTEGER_CST && ecode == INTEGER_CST
&& (type == TREE_TYPE (etype) || etype == TREE_TYPE (type))))
return fold (build1 (NOP_EXPR, type, expr));
switch (code)
{
case VOID_TYPE:
return build1 (CONVERT_EXPR, type, expr);
case BOOLEAN_TYPE:
return fold (build1 (NOP_EXPR, type, gnat_truthvalue_conversion (expr)));
case INTEGER_TYPE:
if (TYPE_HAS_ACTUAL_BOUNDS_P (type)
&& (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
|| (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
return unchecked_convert (type, expr, false);
else if (TYPE_BIASED_REPRESENTATION_P (type))
return fold (build1 (CONVERT_EXPR, type,
fold (build2 (MINUS_EXPR, TREE_TYPE (type),
convert (TREE_TYPE (type), expr),
TYPE_MIN_VALUE (type)))));
case ENUMERAL_TYPE:
return fold (convert_to_integer (type, expr));
case POINTER_TYPE:
case REFERENCE_TYPE:
if (TYPE_THIN_POINTER_P (etype) && TYPE_THIN_POINTER_P (type))
{
tree bit_diff
= size_diffop (bit_position (TYPE_FIELDS (TREE_TYPE (etype))),
bit_position (TYPE_FIELDS (TREE_TYPE (type))));
tree byte_diff = size_binop (CEIL_DIV_EXPR, bit_diff,
sbitsize_int (BITS_PER_UNIT));
expr = build1 (NOP_EXPR, type, expr);
TREE_CONSTANT (expr) = TREE_CONSTANT (TREE_OPERAND (expr, 0));
if (integer_zerop (byte_diff))
return expr;
return build_binary_op (PLUS_EXPR, type, expr,
fold (convert_to_pointer (type, byte_diff)));
}
if (TYPE_THIN_POINTER_P (type)
&& TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)))
return convert_to_thin_pointer (type, expr);
else if (TYPE_FAT_POINTER_P (etype))
expr = build_component_ref (expr, get_identifier ("P_ARRAY"),
NULL_TREE, false);
return fold (convert_to_pointer (type, expr));
case REAL_TYPE:
return fold (convert_to_real (type, expr));
case RECORD_TYPE:
if (TYPE_JUSTIFIED_MODULAR_P (type) && !AGGREGATE_TYPE_P (etype))
return
gnat_build_constructor
(type, tree_cons (TYPE_FIELDS (type),
convert (TREE_TYPE (TYPE_FIELDS (type)), expr),
NULL_TREE));
case ARRAY_TYPE:
return unchecked_convert (type, expr, false);
case UNION_TYPE:
if (TYPE_UNCHECKED_UNION_P (type))
{
for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
{
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, expr);
if (TREE_TYPE (tem) == TYPE_MAIN_VARIANT (etype)
|| (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (tem))
|| TYPE_IS_PADDING_P (TREE_TYPE (tem)))
&& TREE_TYPE (TYPE_FIELDS (TREE_TYPE (tem))) == etype))
return build1 (CONVERT_EXPR, type,
convert (TREE_TYPE (tem), expr));
}
gcc_unreachable ();
}
else
return unchecked_convert (type, expr, false);
case UNCONSTRAINED_ARRAY_TYPE:
if (ecode == ARRAY_TYPE
|| (ecode == INTEGER_TYPE && TYPE_HAS_ACTUAL_BOUNDS_P (etype))
|| (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))
|| (ecode == RECORD_TYPE && TYPE_JUSTIFIED_MODULAR_P (etype)))
return
build_unary_op
(INDIRECT_REF, NULL_TREE,
convert_to_fat_pointer (TREE_TYPE (type),
build_unary_op (ADDR_EXPR,
NULL_TREE, expr)));
else if (ecode == UNCONSTRAINED_ARRAY_TYPE)
return
build_unary_op (INDIRECT_REF, NULL_TREE,
convert (TREE_TYPE (type),
build_unary_op (ADDR_EXPR,
NULL_TREE, expr)));
else
gcc_unreachable ();
case COMPLEX_TYPE:
return fold (convert_to_complex (type, expr));
default:
gcc_unreachable ();
}
}
tree
remove_conversions (tree exp, bool true_address)
{
switch (TREE_CODE (exp))
{
case CONSTRUCTOR:
if (true_address
&& TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)), true);
break;
case COMPONENT_REF:
if (TREE_CODE (TREE_TYPE (TREE_OPERAND (exp, 0))) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
return remove_conversions (TREE_OPERAND (exp, 0), true_address);
break;
case VIEW_CONVERT_EXPR: case NON_LVALUE_EXPR:
case NOP_EXPR: case CONVERT_EXPR:
return remove_conversions (TREE_OPERAND (exp, 0), true_address);
default:
break;
}
return exp;
}
tree
maybe_unconstrained_array (tree exp)
{
enum tree_code code = TREE_CODE (exp);
tree new;
switch (TREE_CODE (TREE_TYPE (exp)))
{
case UNCONSTRAINED_ARRAY_TYPE:
if (code == UNCONSTRAINED_ARRAY_REF)
{
new
= build_unary_op (INDIRECT_REF, NULL_TREE,
build_component_ref (TREE_OPERAND (exp, 0),
get_identifier ("P_ARRAY"),
NULL_TREE, false));
TREE_READONLY (new) = TREE_STATIC (new) = TREE_READONLY (exp);
return new;
}
else if (code == NULL_EXPR)
return build1 (NULL_EXPR,
TREE_TYPE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (TREE_TYPE (exp))))),
TREE_OPERAND (exp, 0));
case RECORD_TYPE:
if (TYPE_IS_PADDING_P (TREE_TYPE (exp)))
{
new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (exp))), exp);
if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (new)))
return
build_component_ref (new, NULL_TREE,
TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new))),
0);
}
else if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
return
build_component_ref (exp, NULL_TREE,
TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))), 0);
break;
default:
break;
}
return exp;
}
tree
unchecked_convert (tree type, tree expr, bool notrunc_p)
{
tree etype = TREE_TYPE (expr);
if (etype == type)
return expr;
if ((((INTEGRAL_TYPE_P (type)
&& !(TREE_CODE (type) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (type)))
|| (POINTER_TYPE_P (type) && ! TYPE_THIN_POINTER_P (type))
|| (TREE_CODE (type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (type)))
&& ((INTEGRAL_TYPE_P (etype)
&& !(TREE_CODE (etype) == INTEGER_TYPE
&& TYPE_VAX_FLOATING_POINT_P (etype)))
|| (POINTER_TYPE_P (etype) && !TYPE_THIN_POINTER_P (etype))
|| (TREE_CODE (etype) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (etype))))
|| TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
{
tree rtype = type;
if (TREE_CODE (etype) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (etype))
{
tree ntype = copy_type (etype);
TYPE_BIASED_REPRESENTATION_P (ntype) = 0;
TYPE_MAIN_VARIANT (ntype) = ntype;
expr = build1 (NOP_EXPR, ntype, expr);
}
if (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type))
{
rtype = copy_type (type);
TYPE_BIASED_REPRESENTATION_P (rtype) = 0;
TYPE_MAIN_VARIANT (rtype) = rtype;
}
expr = convert (rtype, expr);
if (type != rtype)
expr = build1 (NOP_EXPR, type, expr);
}
else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type))))
{
tree rec_type = make_node (RECORD_TYPE);
tree field = create_field_decl (get_identifier ("OBJ"), type,
rec_type, 1, 0, 0, 0);
TYPE_FIELDS (rec_type) = field;
layout_type (rec_type);
expr = unchecked_convert (rec_type, expr, notrunc_p);
expr = build_component_ref (expr, NULL_TREE, field, 0);
}
else if (INTEGRAL_TYPE_P (etype) && TYPE_RM_SIZE (etype)
&& 0 != compare_tree_int (TYPE_RM_SIZE (etype),
GET_MODE_BITSIZE (TYPE_MODE (etype))))
{
tree rec_type = make_node (RECORD_TYPE);
tree field
= create_field_decl (get_identifier ("OBJ"), etype, rec_type,
1, 0, 0, 0);
TYPE_FIELDS (rec_type) = field;
layout_type (rec_type);
expr = gnat_build_constructor (rec_type, build_tree_list (field, expr));
expr = unchecked_convert (type, expr, notrunc_p);
}
else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
&& TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build1 (VIEW_CONVERT_EXPR, TREE_TYPE (type),
build_unary_op (ADDR_EXPR, NULL_TREE,
expr)));
else
{
expr = maybe_unconstrained_array (expr);
if (TREE_CODE (expr) == VIEW_CONVERT_EXPR)
expr = TREE_OPERAND (expr, 0);
etype = TREE_TYPE (expr);
expr = build1 (VIEW_CONVERT_EXPR, type, expr);
}
if (!notrunc_p
&& INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type)
&& !(TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type))
&& 0 != compare_tree_int (TYPE_RM_SIZE (type),
GET_MODE_BITSIZE (TYPE_MODE (type)))
&& !(INTEGRAL_TYPE_P (etype)
&& TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
&& operand_equal_p (TYPE_RM_SIZE (type),
(TYPE_RM_SIZE (etype) != 0
? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
0))
&& !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
{
tree base_type = gnat_type_for_mode (TYPE_MODE (type),
TYPE_UNSIGNED (type));
tree shift_expr
= convert (base_type,
size_binop (MINUS_EXPR,
bitsize_int
(GET_MODE_BITSIZE (TYPE_MODE (type))),
TYPE_RM_SIZE (type)));
expr
= convert (type,
build_binary_op (RSHIFT_EXPR, base_type,
build_binary_op (LSHIFT_EXPR, base_type,
convert (base_type, expr),
shift_expr),
shift_expr));
}
if (TREE_CODE (expr) == INTEGER_CST)
TREE_OVERFLOW (expr) = TREE_CONSTANT_OVERFLOW (expr) = 0;
if (TREE_CODE (expr) == VIEW_CONVERT_EXPR
&& !operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype),
OEP_ONLY_CONST))
TREE_CONSTANT (expr) = 0;
return expr;
}
tree
builtin_decl_for (tree name __attribute__ ((unused)))
{
return NULL_TREE;
}
#include "gt-ada-utils.h"
#include "gtype-ada.h"