#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 "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 pending_elaborations;
struct e_stack GTY((chain_next ("%h.next"))) {
struct e_stack *next;
tree elab_list;
};
static GTY(()) struct e_stack *elist_stack;
static GTY(()) tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
static GTY(()) tree float_types[NUM_MACHINE_MODES];
struct ada_binding_level GTY((chain_next ("%h.chain")))
{
struct ada_binding_level *chain;
tree block;
};
static GTY(()) struct ada_binding_level *current_binding_level;
static GTY((deletable)) struct ada_binding_level *free_binding_level;
static GTY((deletable)) tree free_block_chain;
struct language_function GTY(())
{
int unused;
};
static tree merge_sizes (tree, tree, tree, int, int);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static int value_zerop (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 int value_factor_p (tree, int);
static int 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));
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
}
void
save_gnu_tree (Entity_Id gnat_entity, tree gnu_decl, int no_check)
{
if (gnu_decl
&& (associate_gnat_to_gnu[gnat_entity - First_Node_Id]
|| (! no_check && ! DECL_P (gnu_decl))))
gigi_abort (401);
associate_gnat_to_gnu[gnat_entity - First_Node_Id] = gnu_decl;
}
tree
get_gnu_tree (Entity_Id gnat_entity)
{
if (! associate_gnat_to_gnu[gnat_entity - First_Node_Id])
gigi_abort (402);
return associate_gnat_to_gnu[gnat_entity - First_Node_Id];
}
int
present_gnu_tree (Entity_Id gnat_entity)
{
return (associate_gnat_to_gnu[gnat_entity - First_Node_Id] != NULL_TREE);
}
int
global_bindings_p (void)
{
return (force_global != 0 || current_binding_level->chain == 0 ? -1 : 0);
}
tree
getdecls (void)
{
return BLOCK_VARS (current_binding_level->block);
}
void
gnat_pushlevel ()
{
struct ada_binding_level *newlevel = NULL;
if (free_binding_level)
{
newlevel = free_binding_level;
free_binding_level = free_binding_level->chain;
}
else
newlevel
= (struct ada_binding_level *)
ggc_alloc (sizeof (struct ada_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;
newlevel->chain = current_binding_level;
current_binding_level = newlevel;
}
void
gnat_poplevel ()
{
struct ada_binding_level *level = current_binding_level;
tree block = level->block;
tree decl;
BLOCK_VARS (block) = nreverse (BLOCK_VARS (block));
BLOCK_SUBBLOCKS (block) = nreverse (BLOCK_SUBBLOCKS (block));
for (decl = BLOCK_VARS (block); decl; decl = TREE_CHAIN (decl))
if (TREE_CODE (decl) == FUNCTION_DECL
&& ! TREE_ASM_WRITTEN (decl) && TREE_ADDRESSABLE (decl)
&& DECL_INITIAL (decl) != 0)
{
push_function_context ();
ggc_push_context ();
output_inline_function (decl);
ggc_pop_context ();
pop_function_context ();
}
if (TREE_CODE (BLOCK_SUPERCONTEXT (block)) == FUNCTION_DECL)
;
else if (BLOCK_VARS (block) == 0)
{
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;
}
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;
}
int
block_has_vars ()
{
return BLOCK_VARS (current_binding_level->block) != 0;
}
tree
pushdecl (tree decl)
{
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
DECL_CONTEXT (decl) = 0;
else
DECL_CONTEXT (decl) = current_function_decl;
if (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) != 0
&& (TYPE_NAME (TREE_TYPE (decl)) == 0
|| 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;
return decl;
}
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 (0);
set_sizetype (gnat_type_for_size (GET_MODE_BITSIZE (Pmode), 0));
build_common_tree_nodes_2 (0);
pushdecl (build_decl (TYPE_DECL, get_identifier (SIZE_TYPE), sizetype));
pushdecl (build_decl (TYPE_DECL, get_identifier ("integer"),
integer_type_node));
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned char"),
char_type_node));
ptr_void_type_node = build_pointer_type (void_type_node);
}
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);
pushdecl (build_decl (TYPE_DECL, get_identifier ("longest float type"),
longest_float_type_node));
}
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);
pushdecl (build_decl (TYPE_DECL, get_identifier ("unsigned int"),
unsigned_type_node));
void_type_decl_node
= pushdecl (build_decl (TYPE_DECL, get_identifier ("void"),
void_type_node));
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
jmpbuf_type
= build_array_type (gnat_type_for_mode (Pmode, 0),
build_index_type (build_int_2 (5, 0)));
pushdecl (build_decl (TYPE_DECL, get_identifier ("JMPBUF_T"), jmpbuf_type));
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
}
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, 0, 1, 1, 0);
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, 0, 1, 1, 0);
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,
int has_rep,
int defer_debug)
{
enum tree_code code = TREE_CODE (record_type);
tree ada_size = bitsize_zero_node;
tree size = bitsize_zero_node;
tree size_unit = size_zero_node;
int var_size = 0;
tree field;
TYPE_FIELDS (record_type) = fieldlist;
if (TYPE_NAME (record_type) != 0
&& TREE_CODE (TYPE_NAME (record_type)) == TYPE_DECL)
TYPE_STUB_DECL (record_type) = TYPE_NAME (record_type);
else
TYPE_STUB_DECL (record_type)
= pushdecl (build_decl (TYPE_DECL, TYPE_NAME (record_type),
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 (TYPE_SIZE (record_type) == 0)
{
TYPE_SIZE (record_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (record_type) = size_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_size_unit = DECL_SIZE_UNIT (field);
tree this_ada_size = DECL_SIZE (field);
if (TREE_CODE (this_size) != INTEGER_CST)
var_size = 1;
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) != 0)
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);
size_unit = size_binop (MAX_EXPR, size_unit, this_size_unit);
break;
case QUAL_UNION_TYPE:
ada_size
= fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
this_ada_size, ada_size));
size = fold (build (COND_EXPR, bitsizetype, DECL_QUALIFIER (field),
this_size, size));
size_unit = fold (build (COND_EXPR, sizetype, DECL_QUALIFIER (field),
this_size_unit, size_unit));
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);
size_unit
= merge_sizes (size_unit, byte_position (field), this_size_unit,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
break;
default:
abort ();
}
}
if (code == QUAL_UNION_TYPE)
nreverse (fieldlist);
if (TREE_CODE (record_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (record_type) && TYPE_SIZE (record_type) != 0)
{
size = TYPE_SIZE (record_type);
size_unit = TYPE_SIZE_UNIT (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)
{
if (! (TREE_CODE (record_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (record_type)
&& CONTAINS_PLACEHOLDER_P (size)))
{
TYPE_SIZE (record_type) = round_up (size, TYPE_ALIGN (record_type));
TYPE_SIZE_UNIT (record_type)
= 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_id = DECL_NAME (TYPE_STUB_DECL (record_type));
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)
= pushdecl (build_decl (TYPE_DECL, new_id, 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));
for (old_field = TYPE_FIELDS (record_type); old_field != 0;
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);
int var = 0;
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 == 0 && 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 == 0 && 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 == 0)
pos = bitsize_zero_node;
if (TREE_CODE (DECL_SIZE (old_field)) != INTEGER_CST)
{
field_type = build_pointer_type (field_type);
var = 1;
}
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,
int special,
int 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 (build (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,
int returns_unconstrained,
int returns_by_ref,
int returns_with_dsp)
{
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) != 0 || cico_list != 0
|| TYPE_RETURNS_UNCONSTRAINED_P (type) != returns_unconstrained
|| TYPE_RETURNS_BY_REF_P (type) != returns_by_ref)
type = copy_type (type);
SET_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;
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) != 0)
type = copy_type (type);
SET_TYPE_INDEX_TYPE (type, index);
return type;
}
tree
create_type_decl (tree type_name,
tree type,
struct attrib *attr_list,
int artificial_p,
int debug_info_p)
{
tree type_decl = build_decl (TYPE_DECL, type_name, type);
enum tree_code code = TREE_CODE (type);
DECL_ARTIFICIAL (type_decl) = artificial_p;
pushdecl (type_decl);
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, NULL, global_bindings_p (), 0);
return type_decl;
}
tree
create_var_decl (tree var_name, tree asm_name, tree type, tree var_init,
int const_flag, int public_flag, int extern_flag,
int static_flag, struct attrib *attr_list)
{
int init_const
= (var_init == 0
? 0
: (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 != 0 && ! TREE_CONSTANT (var_init)))
var_init = 0;
if (global_bindings_p () && var_init != 0 && ! init_const)
{
add_pending_elaborations (var_decl, var_init);
var_init = 0;
}
else if (var_init != 0
&& ((TYPE_MAIN_VARIANT (TREE_TYPE (var_init))
!= TYPE_MAIN_VARIANT (type))
|| (static_flag && ! init_const)))
DECL_INIT_BY_ASSIGN_P (var_decl) = 1;
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) = global_bindings_p () ? !extern_flag : static_flag;
if (asm_name != 0)
SET_DECL_ASSEMBLER_NAME (var_decl, asm_name);
process_attributes (var_decl, attr_list);
var_decl = pushdecl (var_decl);
if (TREE_SIDE_EFFECTS (var_decl))
TREE_ADDRESSABLE (var_decl) = 1;
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, 0, 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 != 0)
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 (size != 0 && TREE_CODE (size) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (field_type)) == INTEGER_CST
&& ! addressable
&& (! operand_equal_p (TYPE_SIZE (field_type), size, 0)
|| (pos != 0
&& ! value_zerop (size_binop (TRUNC_MOD_EXPR, pos,
bitsize_int (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 == 0)
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 != 0 ? 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 != 0)
{
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 int
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, int 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->arg,
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));
}
else
post_error ("?section attributes are not supported for this target",
attr_list->error_point);
break;
}
}
void
add_pending_elaborations (tree var_decl, tree var_init)
{
if (var_init != 0)
Check_Elaboration_Code_Allowed (error_gnat_node);
pending_elaborations
= chainon (pending_elaborations, build_tree_list (var_decl, var_init));
}
tree
get_pending_elaborations (void)
{
tree result = TREE_CHAIN (pending_elaborations);
TREE_CHAIN (pending_elaborations) = 0;
return result;
}
static int
value_factor_p (tree value, 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 int
potential_alignment_gap (tree prev_field, tree curr_field, tree offset)
{
if (!prev_field)
return 0;
if (TREE_CODE (TREE_TYPE (prev_field)) == QUAL_UNION_TYPE)
return 0;
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 0;
return 1;
}
int
pending_elaborations_p (void)
{
return TREE_CHAIN (pending_elaborations) != 0;
}
void
push_pending_elaborations (void)
{
struct e_stack *p = (struct e_stack *) ggc_alloc (sizeof (struct e_stack));
p->next = elist_stack;
p->elab_list = pending_elaborations;
elist_stack = p;
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
}
void
pop_pending_elaborations (void)
{
struct e_stack *p = elist_stack;
pending_elaborations = p->elab_list;
elist_stack = p->next;
}
tree
get_elaboration_location (void)
{
return tree_last (pending_elaborations);
}
void
insert_elaboration_list (tree elab)
{
tree next = TREE_CHAIN (elab);
if (TREE_CHAIN (pending_elaborations))
{
TREE_CHAIN (elab) = TREE_CHAIN (pending_elaborations);
TREE_CHAIN (tree_last (pending_elaborations)) = next;
TREE_CHAIN (pending_elaborations) = 0;
}
}
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,
int inline_flag,
int public_flag,
int extern_flag,
struct attrib *attr_list)
{
tree return_type = TREE_TYPE (subprog_type);
tree subprog_decl = build_decl (FUNCTION_DECL, subprog_name, subprog_type);
if (current_function_decl != 0 && DECL_INLINE (current_function_decl)
&& DECL_EXTERNAL (current_function_decl))
extern_flag = 1;
DECL_EXTERNAL (subprog_decl) = extern_flag;
TREE_PUBLIC (subprog_decl) = public_flag;
DECL_INLINE (subprog_decl) = inline_flag;
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);
if (asm_name != 0)
SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
process_attributes (subprog_decl, attr_list);
subprog_decl = pushdecl (subprog_decl);
rest_of_decl_compilation (subprog_decl, 0, global_bindings_p (), 0);
return subprog_decl;
}
static int function_nesting_depth;
void
begin_subprog_body (tree subprog_decl)
{
tree param_decl;
if (function_nesting_depth++ != 0)
push_function_context ();
announce_function (subprog_decl);
DECL_INITIAL (subprog_decl) = error_mark_node;
TREE_STATIC (subprog_decl) = 1;
current_function_decl = 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;
init_function_start (subprog_decl);
expand_function_start (subprog_decl, 0);
if (DECL_ASSEMBLER_NAME (subprog_decl) != 0
&& MAIN_NAME_P (DECL_ASSEMBLER_NAME (subprog_decl))
&& DECL_CONTEXT (subprog_decl) == NULL_TREE)
expand_main_function ();
}
void
end_subprog_body (void)
{
tree decl;
tree cico_list;
BLOCK_VARS (current_binding_level->block) = 0;
BLOCK_SUPERCONTEXT (current_binding_level->block) = current_function_decl;
DECL_INITIAL (current_function_decl) = current_binding_level->block;
gnat_poplevel ();
DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;
expand_function_end ();
if (function_nesting_depth > 1)
ggc_push_context ();
if (!type_annotate_only)
{
rest_of_compilation (current_function_decl);
if (! DECL_DEFER_OUTPUT (current_function_decl))
{
free_after_compilation (cfun);
DECL_STRUCT_FUNCTION (current_function_decl) = 0;
}
cfun = 0;
}
if (function_nesting_depth > 1)
ggc_pop_context ();
for (cico_list = TYPE_CI_CO_LIST (TREE_TYPE (current_function_decl));
cico_list != 0; cico_list = TREE_CHAIN (cico_list))
TREE_VALUE (cico_list) = 0;
if (DECL_STRUCT_FUNCTION (current_function_decl) == 0)
{
for (decl = DECL_ARGUMENTS (current_function_decl);
decl != 0; decl = TREE_CHAIN (decl))
{
SET_DECL_RTL (decl, 0);
DECL_INCOMING_RTL (decl) = 0;
}
SET_DECL_RTL (DECL_RESULT (current_function_decl), 0);
if (DECL_INITIAL (current_function_decl) != 0)
DECL_INITIAL (current_function_decl) = error_mark_node;
DECL_ARGUMENTS (current_function_decl) = 0;
}
if (--function_nesting_depth != 0)
pop_function_context ();
else
current_function_decl = 0;
}
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));
pushdecl (decl);
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] != 0)
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) == 0)
{
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] != 0)
return float_types[(int) mode];
float_types[(int) mode] = t = make_node (REAL_TYPE);
TYPE_PRECISION (t) = precision;
layout_type (t);
if (TYPE_MODE (t) != mode)
gigi_abort (414);
if (TYPE_NAME (t) == 0)
{
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 (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_precision (GET_MODE_PRECISION (mode), mode);
else
return gnat_type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
}
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) != 0
&& 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) != 0
&& 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, int max_p)
{
enum tree_code code = TREE_CODE (exp);
tree type = TREE_TYPE (exp);
switch (TREE_CODE_CLASS (code))
{
case 'd':
case 'c':
return exp;
case 'x':
if (code == TREE_LIST)
return tree_cons (TREE_PURPOSE (exp),
max_size (TREE_VALUE (exp), max_p),
TREE_CHAIN (exp) != 0
? max_size (TREE_CHAIN (exp), max_p) : 0);
break;
case 'r':
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), 1);
case '<':
return max_p ? size_one_node : size_zero_node;
case '1':
case '2':
case 'e':
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 == RTL_EXPR)
gigi_abort (407);
else 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 (build (code, type, lhs, rhs));
}
case 3:
if (code == SAVE_EXPR)
return exp;
else if (code == COND_EXPR)
return fold (build (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) != 0)
return build (CALL_EXPR, type, TREE_OPERAND (exp, 0),
max_size (TREE_OPERAND (exp, 1), max_p), NULL);
}
}
gigi_abort (408);
}
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_LEFT_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 != 0
? (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 != 0)
bounds = TREE_VALUE (bound_list);
else if (TREE_CODE (array_type) == ARRAY_TYPE)
bounds = TYPE_INDEX_TYPE (TYPE_DOMAIN (array_type));
else if (expr != 0 && TREE_CODE (expr) == PARM_DECL
&& DECL_BY_COMPONENT_PTR_P (expr))
bounds = TREE_TYPE (field);
else
gigi_abort (411);
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),
build (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 = build (PLACEHOLDER_EXPR, type);
for (i = 0, inner_type = type; i < ndim;
i++, inner_type = TREE_TYPE (inner_type))
tem = build (ARRAY_REF, TREE_TYPE (inner_type), tem,
convert (TYPE_DOMAIN (inner_type), size_zero_node));
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, 0, 1);
pushdecl (build_decl (TYPE_DECL, create_concat_name (gnat_entity, "DESC"),
record_type));
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),
0, 0);
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 type;
if (TYPE_MAIN_VARIANT (old_type) == old_type)
for (type = TYPE_NEXT_VARIANT (old_type); type != 0;
type = TYPE_NEXT_VARIANT (type))
update_pointer_to (type, new_type);
if (ptr == 0 && ref == 0)
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))
{
TREE_TYPE (ptr) = new_type;
if (TYPE_NAME (ptr) != 0
&& TREE_CODE (TYPE_NAME (ptr)) == TYPE_DECL
&& TREE_CODE (new_type) != ENUMERAL_TYPE)
rest_of_decl_compilation (TYPE_NAME (ptr), NULL,
global_bindings_p (), 0);
}
for (; ref; ref = TYPE_NEXT_PTR_TO (ref))
{
TREE_TYPE (ref) = new_type;
if (TYPE_NAME (ref) != 0
&& TREE_CODE (TYPE_NAME (ref)) == TYPE_DECL
&& TREE_CODE (new_type) != ENUMERAL_TYPE)
rest_of_decl_compilation (TYPE_NAME (ref), NULL,
global_bindings_p (), 0);
}
}
else if (TREE_CODE (ptr) != RECORD_TYPE || ! TYPE_IS_FAT_POINTER_P (ptr))
gigi_abort (412);
else
{
tree new_obj_rec = TYPE_OBJECT_RECORD_TYPE (new_type);
tree ptr_temp_type;
tree new_ref;
tree var;
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 = build (COMPONENT_REF, ptr_temp_type,
build (PLACEHOLDER_EXPR, ptr),
TREE_CHAIN (TYPE_FIELDS (ptr)));
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, 0);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
TREE_CHAIN (fields), 0));
}
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)), 0);
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 (AGGREGATE_TYPE_P (type)
&& TYPE_MAIN_VARIANT (type) == TYPE_MAIN_VARIANT (etype))
return build1 (NOP_EXPR, type, 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) != 0
&& 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), 0));
}
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, 0);
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 (build (PLUS_EXPR, TREE_TYPE (etype),
fold (build1 (GNAT_NOP_EXPR,
TREE_TYPE (etype), expr)),
TYPE_MIN_VALUE (etype))));
if (ecode == RECORD_TYPE && TYPE_LEFT_JUSTIFIED_MODULAR_P (etype)
&& code != UNCONSTRAINED_ARRAY_TYPE)
return convert (type, build_component_ref (expr, NULL_TREE,
TYPE_FIELDS (etype), 0));
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 TRANSFORM_EXPR:
case NULL_EXPR:
expr = copy_node (expr);
TREE_TYPE (expr) = type;
return expr;
case STRING_CST:
case CONSTRUCTOR:
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 COMPONENT_REF:
if (code == ecode && TYPE_MODE (type) == TYPE_MODE (etype)
&& AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
&& TYPE_ALIGN (type) == TYPE_ALIGN (etype)
&& operand_equal_p (TYPE_SIZE (type), TYPE_SIZE (etype), 0)
&& get_alias_set (type) == get_alias_set (etype))
return build (COMPONENT_REF, type, TREE_OPERAND (expr, 0),
TREE_OPERAND (expr, 1));
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, 0));
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);
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 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, 0);
else if (TYPE_BIASED_REPRESENTATION_P (type))
return fold (build1 (CONVERT_EXPR, type,
fold (build (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)) != 0)
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, 0);
return fold (convert_to_pointer (type, expr));
case REAL_TYPE:
return fold (convert_to_real (type, expr));
case RECORD_TYPE:
if (TYPE_LEFT_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, 0);
case UNION_TYPE:
for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
{
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, expr);
else if (TREE_CODE (TREE_TYPE (tem)) == RECORD_TYPE
&& (TYPE_LEFT_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));
}
gigi_abort (413);
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_LEFT_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
gigi_abort (409);
case COMPLEX_TYPE:
return fold (convert_to_complex (type, expr));
default:
gigi_abort (410);
}
}
tree
remove_conversions (tree exp, int true_address)
{
switch (TREE_CODE (exp))
{
case CONSTRUCTOR:
if (true_address
&& TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)), 1);
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: case GNAT_NOP_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, 0));
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, int 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_LEFT_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_LEFT_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 (GNAT_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 (GNAT_NOP_EXPR, type, expr);
}
else if (INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
&& 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
&& 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);
etype = TREE_TYPE (expr);
expr = build1 (VIEW_CONVERT_EXPR, type, expr);
}
if (! notrunc_p
&& INTEGRAL_TYPE_P (type) && TYPE_RM_SIZE (type) != 0
&& ! (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;
}
#include "gt-ada-utils.h"
#include "gtype-ada.h"