#include "config.h"
#include "system.h"
#include "tree.h"
#include "flags.h"
#include "defaults.h"
#include "toplev.h"
#include "output.h"
#include "ggc.h"
#include "convert.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];
static tree *associate_gnat_to_gnu;
static tree pending_elaborations;
static struct e_stack {struct e_stack *next; tree elab_list; } *elist_stack;
static tree signed_and_unsigned_types[2 * MAX_BITS_PER_WORD + 1][2];
static tree float_types[NUM_MACHINE_MODES];
struct binding_level
{
tree names;
tree blocks;
tree this_block;
struct binding_level *level_chain;
};
static struct binding_level *current_binding_level = NULL;
static struct binding_level *free_binding_level = NULL;
static struct binding_level *global_binding_level;
static struct binding_level clear_binding_level = {NULL, NULL, NULL, NULL};
static tree merge_sizes PARAMS ((tree, tree, tree, int, int));
static tree compute_related_constant PARAMS ((tree, tree));
static tree split_plus PARAMS ((tree, tree *));
static int value_zerop PARAMS ((tree));
static tree float_type_for_size PARAMS ((int, enum machine_mode));
static tree convert_to_fat_pointer PARAMS ((tree, tree));
static tree convert_to_thin_pointer PARAMS ((tree, tree));
static tree make_descriptor_field PARAMS ((const char *,tree, tree,
tree));
static void mark_binding_level PARAMS((PTR));
static void mark_e_stack PARAMS((PTR));
void
init_gnat_to_gnu ()
{
Node_Id gnat_node;
associate_gnat_to_gnu = (tree *) xmalloc (max_gnat_nodes * sizeof (tree));
ggc_add_tree_root (associate_gnat_to_gnu, max_gnat_nodes);
for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
associate_gnat_to_gnu [gnat_node] = NULL_TREE;
associate_gnat_to_gnu -= First_Node_Id;
pending_elaborations = build_tree_list (NULL_TREE, NULL_TREE);
ggc_add_tree_root (&pending_elaborations, 1);
ggc_add_root ((PTR) &elist_stack, 1, sizeof (struct e_stack), mark_e_stack);
ggc_add_tree_root (&signed_and_unsigned_types[0][0],
(sizeof signed_and_unsigned_types
/ sizeof signed_and_unsigned_types[0][0]));
ggc_add_tree_root (float_types, sizeof float_types / sizeof float_types[0]);
ggc_add_root (¤t_binding_level, 1, sizeof current_binding_level,
mark_binding_level);
}
void
save_gnu_tree (gnat_entity, gnu_decl, no_check)
Entity_Id gnat_entity;
tree gnu_decl;
int no_check;
{
if (gnu_decl
&& (associate_gnat_to_gnu [gnat_entity]
|| (! no_check && ! DECL_P (gnu_decl))))
gigi_abort (401);
associate_gnat_to_gnu [gnat_entity] = gnu_decl;
}
tree
get_gnu_tree (gnat_entity)
Entity_Id gnat_entity;
{
if (! associate_gnat_to_gnu [gnat_entity])
gigi_abort (402);
return associate_gnat_to_gnu [gnat_entity];
}
int
present_gnu_tree (gnat_entity)
Entity_Id gnat_entity;
{
return (associate_gnat_to_gnu [gnat_entity] != NULL_TREE);
}
int
global_bindings_p ()
{
return (force_global != 0 || current_binding_level == global_binding_level
? -1 : 0);
}
tree
getdecls ()
{
return current_binding_level->names;
}
int
kept_level_p ()
{
return (current_binding_level->names != 0);
}
void
pushlevel (ignore)
int ignore ATTRIBUTE_UNUSED;
{
struct binding_level *newlevel = NULL;
if (free_binding_level)
{
newlevel = free_binding_level;
free_binding_level = free_binding_level->level_chain;
}
else
newlevel
= (struct binding_level *) xmalloc (sizeof (struct binding_level));
*newlevel = clear_binding_level;
newlevel->level_chain = current_binding_level;
current_binding_level = newlevel;
}
tree
poplevel (keep, reverse, functionbody)
int keep;
int reverse;
int functionbody;
{
tree block = NULL_TREE;
tree decl_chain;
tree decl_node;
tree subblock_chain = current_binding_level->blocks;
tree subblock_node;
int block_previously_created;
current_binding_level->names
= decl_chain = (reverse) ? nreverse (current_binding_level->names)
: current_binding_level->names;
for (decl_node = decl_chain; decl_node; decl_node = TREE_CHAIN (decl_node))
if (TREE_CODE (decl_node) == FUNCTION_DECL
&& ! TREE_ASM_WRITTEN (decl_node) && TREE_ADDRESSABLE (decl_node)
&& DECL_INITIAL (decl_node) != 0)
{
push_function_context ();
output_inline_function (decl_node);
pop_function_context ();
}
block = 0;
block_previously_created = (current_binding_level->this_block != 0);
if (block_previously_created)
block = current_binding_level->this_block;
else if (keep || functionbody)
block = make_node (BLOCK);
if (block != 0)
{
BLOCK_VARS (block) = keep ? decl_chain : 0;
BLOCK_SUBBLOCKS (block) = subblock_chain;
}
for (subblock_node = subblock_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
BLOCK_SUPERCONTEXT (subblock_node) = block;
for (subblock_node = decl_chain; subblock_node;
subblock_node = TREE_CHAIN (subblock_node))
if (DECL_NAME (subblock_node) != 0)
if (DECL_EXTERNAL (subblock_node))
{
if (TREE_USED (subblock_node))
TREE_USED (DECL_NAME (subblock_node)) = 1;
if (TREE_ADDRESSABLE (subblock_node))
TREE_ADDRESSABLE (DECL_ASSEMBLER_NAME (subblock_node)) = 1;
}
{
struct binding_level *level = current_binding_level;
current_binding_level = current_binding_level->level_chain;
level->level_chain = free_binding_level;
free_binding_level = level;
}
if (functionbody)
{
DECL_INITIAL (current_function_decl) = block;
BLOCK_VARS (block) = 0;
}
else if (block)
{
if (!block_previously_created)
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
}
else if (subblock_chain)
current_binding_level->blocks
= chainon (current_binding_level->blocks, subblock_chain);
if (block)
TREE_USED (block) = 1;
return block;
}
void
insert_block (block)
tree block;
{
TREE_USED (block) = 1;
current_binding_level->blocks
= chainon (current_binding_level->blocks, block);
}
void
set_block (block)
tree block;
{
current_binding_level->this_block = block;
current_binding_level->names = chainon (current_binding_level->names,
BLOCK_VARS (block));
current_binding_level->blocks = chainon (current_binding_level->blocks,
BLOCK_SUBBLOCKS (block));
}
tree
pushdecl (decl)
tree decl;
{
struct binding_level *b;
if (global_bindings_p () && TREE_CODE (decl) != PARM_DECL)
{
b = global_binding_level;
DECL_CONTEXT (decl) = 0;
}
else
{
b = current_binding_level;
DECL_CONTEXT (decl) = current_function_decl;
}
if (TREE_CODE (decl) != TYPE_DECL
|| TREE_CODE (TREE_TYPE (decl)) != UNCONSTRAINED_ARRAY_TYPE)
{
TREE_CHAIN (decl) = b->names;
b->names = 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 ()
{
lineno = 0;
incomplete_decl_finalize_hook = finish_incomplete_decl;
current_function_decl = 0;
current_binding_level = 0;
free_binding_level = 0;
pushlevel (0);
global_binding_level = current_binding_level;
build_common_tree_nodes (0);
set_sizetype (type_for_size (GET_MODE_BITSIZE (ptr_mode), 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 (long_long_float_type, exception_type)
tree long_long_float_type, exception_type;
{
tree endlink;
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 = 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 (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);
raise_constraint_error_decl
= create_subprog_decl
(get_identifier ("__gnat_raise_constraint_error"), 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);
raise_program_error_decl
= create_subprog_decl
(get_identifier ("__gnat_raise_program_error"), 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);
raise_storage_error_decl
= create_subprog_decl
(get_identifier ("__gnat_raise_storage_error"), 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_THIS_VOLATILE (raise_constraint_error_decl) = 1;
TREE_THIS_VOLATILE (raise_program_error_decl) = 1;
TREE_THIS_VOLATILE (raise_storage_error_decl) = 1;
TREE_SIDE_EFFECTS (raise_nodefer_decl) = 1;
TREE_SIDE_EFFECTS (raise_constraint_error_decl) = 1;
TREE_SIDE_EFFECTS (raise_program_error_decl) = 1;
TREE_SIDE_EFFECTS (raise_storage_error_decl) = 1;
TREE_TYPE (raise_nodefer_decl)
= build_qualified_type (TREE_TYPE (raise_nodefer_decl),
TYPE_QUAL_VOLATILE);
TREE_TYPE (raise_constraint_error_decl)
= build_qualified_type (TREE_TYPE (raise_constraint_error_decl),
TYPE_QUAL_VOLATILE);
TREE_TYPE (raise_program_error_decl)
= build_qualified_type (TREE_TYPE (raise_program_error_decl),
TYPE_QUAL_VOLATILE);
TREE_TYPE (raise_storage_error_decl)
= build_qualified_type (TREE_TYPE (raise_storage_error_decl),
TYPE_QUAL_VOLATILE);
setjmp_decl
= create_subprog_decl
(get_identifier ("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;
ggc_add_tree_root (gnat_std_decls,
sizeof gnat_std_decls / sizeof gnat_std_decls[0]);
}
void
incomplete_type_error (dont_care_1, dont_care_2)
tree dont_care_1 ATTRIBUTE_UNUSED;
tree dont_care_2 ATTRIBUTE_UNUSED;
{
gigi_abort (404);
}
void
finish_incomplete_decl (dont_care)
tree dont_care ATTRIBUTE_UNUSED;
{
gigi_abort (405);
}
void
finish_record_type (record_type, fieldlist, has_rep, defer_debug)
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;
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
{
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 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 (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 (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, bit_position (field), this_ada_size,
TREE_CODE (type) == QUAL_UNION_TYPE, has_rep);
size = merge_sizes (size, bit_position (field), 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))
TYPE_ADA_SIZE (record_type) = ada_size;
#ifdef ROUND_TYPE_SIZE
size = ROUND_TYPE_SIZE (record_type, size, TYPE_ALIGN (record_type));
size_unit = ROUND_TYPE_SIZE_UNIT (record_size, size_unit,
TYPE_ALIGN (record_type) / BITS_PER_UNIT);
#else
size = round_up (size, TYPE_ALIGN (record_type));
size_unit = round_up (size_unit, TYPE_ALIGN (record_type) / BITS_PER_UNIT);
#endif
if (has_rep
&& ! (TREE_CODE (record_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (record_type)
&& TREE_CODE (size) != INTEGER_CST
&& contains_placeholder_p (size)))
{
TYPE_SIZE (record_type) = size;
TYPE_SIZE_UNIT (record_type) = size_unit;
}
if (has_rep)
compute_record_mode (record_type);
if (! defer_debug)
{
if (TREE_CODE (TYPE_SIZE (record_type)) != INTEGER_CST)
{
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;
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));
}
if (pos == 0)
pos = bitsize_zero_node;
if (TREE_CODE (TYPE_SIZE (field_type)) != 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,
TYPE_SIZE (field_type), 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
: TYPE_SIZE (TREE_TYPE (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 (last_size, first_bit, size, special, has_rep)
tree last_size;
tree first_bit, size;
int special;
int has_rep;
{
tree type = TREE_TYPE (last_size);
if (! special || TREE_CODE (size) != COND_EXPR)
{
tree new = size_binop (PLUS_EXPR, first_bit, size);
if (has_rep)
new = size_binop (MAX_EXPR, last_size, new);
return new;
}
return 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)));
}
static tree
compute_related_constant (op0, op1)
tree op0, 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 (in, pvar)
tree in;
tree *pvar;
{
tree result = bitsize_zero_node;
while (TREE_CODE (in) == NON_LVALUE_EXPR)
in = TREE_OPERAND (in, 0);
*pvar = in;
if (TREE_CODE (in) == INTEGER_CST)
{
*pvar = bitsize_zero_node;
return 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);
result = size_binop (PLUS_EXPR, result, lhs_con);
result = size_binop (TREE_CODE (in), result, rhs_con);
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 result;
}
else
return bitsize_zero_node;
}
tree
create_subprog_type (return_type, param_decl_list, cico_list,
returns_unconstrained, returns_by_ref, returns_with_dsp)
tree return_type;
tree param_decl_list;
tree cico_list;
int returns_unconstrained, returns_by_ref, 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);
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 (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 (min, max, index)
tree min, 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);
TYPE_INDEX_TYPE (type) = index;
return type;
}
tree
create_type_decl (type_name, type, attr_list, artificial_p, debug_info_p)
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 (var_name, asm_name, type, var_init, const_flag, public_flag,
extern_flag, static_flag, attr_list)
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);
tree assign_init = 0;
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)))
assign_init = var_init, var_init = 0;
DECL_COMMON (var_decl) = !flag_no_common;
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);
expand_decl (var_decl);
if (DECL_CONTEXT (var_decl) != 0)
expand_decl_init (var_decl);
if (TREE_SIDE_EFFECTS (var_decl))
mark_addressable (var_decl);
if (TREE_CODE (var_decl) != CONST_DECL)
rest_of_decl_compilation (var_decl, 0, global_bindings_p (), 0);
if (assign_init != 0)
{
tree lhs = var_decl;
if (TREE_CODE (TREE_TYPE (lhs)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (lhs)))
lhs = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (lhs))), lhs);
expand_expr_stmt (build_binary_op (MODIFY_EXPR, NULL_TREE, lhs,
assign_init));
}
return var_decl;
}
tree
create_field_decl (field_name, field_type, record_type, packed, size, pos,
addressable)
tree field_name;
tree field_type;
tree record_type;
int packed;
tree size, pos;
int addressable;
{
tree field_decl = build_decl (FIELD_DECL, field_name, field_type);
DECL_CONTEXT (field_decl) = record_type;
TREE_READONLY (field_decl) = TREE_READONLY (field_type);
if (packed && TYPE_MODE (field_type) == BLKmode)
DECL_ALIGN (field_decl)
= ((TREE_CODE (field_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (field_type)
&& ! TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (field_type))))
? TYPE_ALIGN (field_type) : BITS_PER_UNIT);
if (size != 0)
size = convert (bitsizetype, size);
else if (packed)
{
if (packed == 1 && ! operand_equal_p (rm_size (field_type),
TYPE_SIZE (field_type), 0))
size = rm_size (field_type);
if (size != 0 && 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
&& (! 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, BIGGEST_ALIGNMENT);
pos_from_bit (&DECL_FIELD_OFFSET (field_decl),
&DECL_FIELD_BIT_OFFSET (field_decl),
BIGGEST_ALIGNMENT, pos);
DECL_HAS_REP_P (field_decl) = 1;
}
DECL_NONADDRESSABLE_P (field_decl)
= ! addressable || DECL_BIT_FIELD (field_decl);
return field_decl;
}
static int
value_zerop (exp)
tree exp;
{
if (TREE_CODE (exp) == COMPOUND_EXPR)
return value_zerop (TREE_OPERAND (exp, 1));
return integer_zerop (exp);
}
tree
create_param_decl (param_name, param_type, readonly)
tree param_name;
tree param_type;
int readonly;
{
tree param_decl = build_decl (PARM_DECL, param_name, param_type);
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 (decl, attr_list)
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:
#ifdef ASM_OUTPUT_SECTION_NAME
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);
#endif
break;
}
}
void
add_pending_elaborations (var_decl, var_init)
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 ()
{
tree result = TREE_CHAIN (pending_elaborations);
TREE_CHAIN (pending_elaborations) = 0;
return result;
}
static void
mark_binding_level (arg)
PTR arg;
{
struct binding_level *level = *(struct binding_level **) arg;
for (; level != 0; level = level->level_chain)
{
ggc_mark_tree (level->names);
ggc_mark_tree (level->blocks);
ggc_mark_tree (level->this_block);
}
}
static void
mark_e_stack (data)
PTR data;
{
struct e_stack *p = *((struct e_stack **) data);
if (p != 0)
{
ggc_mark_tree (p->elab_list);
mark_e_stack (&p->next);
}
}
int
pending_elaborations_p ()
{
return TREE_CHAIN (pending_elaborations) != 0;
}
void
push_pending_elaborations ()
{
struct e_stack *p = (struct e_stack *) xmalloc (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 ()
{
struct e_stack *p = elist_stack;
pending_elaborations = p->elab_list;
elist_stack = p->next;
free (p);
}
tree
get_elaboration_location ()
{
return tree_last (pending_elaborations);
}
void
insert_elaboration_list (elab)
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 (label_name)
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_LINE (label_decl) = lineno;
DECL_SOURCE_FILE (label_decl) = input_filename;
return label_decl;
}
tree
create_subprog_decl (subprog_name, asm_name, subprog_type, param_decl_list,
inline_flag, public_flag, extern_flag, attr_list)
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)
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 (subprog_decl)
tree subprog_decl;
{
tree param_decl_list;
tree param_decl;
tree next_param;
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;
pushlevel (0);
param_decl_list = nreverse (DECL_ARGUMENTS (subprog_decl));
for (param_decl = param_decl_list; param_decl; param_decl = next_param)
{
next_param = TREE_CHAIN (param_decl);
TREE_CHAIN (param_decl) = NULL;
pushdecl (param_decl);
}
DECL_ARGUMENTS (subprog_decl) = getdecls ();
init_function_start (subprog_decl, input_filename, lineno);
expand_function_start (subprog_decl, 0);
}
void
end_subprog_body ()
{
tree decl;
tree cico_list;
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (current_function_decl))
= current_function_decl;
DECL_CONTEXT (DECL_RESULT (current_function_decl)) = current_function_decl;
expand_function_end (input_filename, lineno, 0);
if (function_nesting_depth > 1)
ggc_push_context ();
rest_of_compilation (current_function_decl);
if (function_nesting_depth > 1)
ggc_pop_context ();
#if 0
if (TREE_ASM_WRITTEN (current_function_decl))
mark_fn_defined_in_this_file (current_function_decl);
#endif
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_SAVED_INSNS (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 (name, type, function_code, class, library_name)
const char *name;
tree type;
int function_code;
enum built_in_class class;
const char *library_name;
{
tree decl = build_decl (FUNCTION_DECL, get_identifier (name), type);
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
if (library_name)
DECL_ASSEMBLER_NAME (decl) = get_identifier (library_name);
pushdecl (decl);
DECL_BUILT_IN_CLASS (decl) = class;
DECL_FUNCTION_CODE (decl) = function_code;
return decl;
}
tree
type_for_size (precision, unsignedp)
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_size (precision, mode)
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
type_for_mode (mode, unsignedp)
enum machine_mode mode;
int unsignedp;
{
if (GET_MODE_CLASS (mode) == MODE_FLOAT)
return float_type_for_size (GET_MODE_BITSIZE (mode), mode);
else
return type_for_size (GET_MODE_BITSIZE (mode), unsignedp);
}
tree
unsigned_type (type_node)
tree type_node;
{
tree type = 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
signed_type (type_node)
tree type_node;
{
tree type = 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
signed_or_unsigned_type (unsignedp, type)
int unsignedp;
tree type;
{
if (! INTEGRAL_TYPE_P (type) || TREE_UNSIGNED (type) == unsignedp)
return type;
else
return type_for_size (TYPE_PRECISION (type), unsignedp);
}
tree
max_size (exp, max_p)
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))
gigi_abort (406);
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);
else if (code == WITH_RECORD_EXPR)
return exp;
{
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_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_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));
}
}
gigi_abort (408);
}
tree
build_template (template_type, array_type, expr)
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));
if (! TREE_CONSTANT (min) && contains_placeholder_p (min))
min = build (WITH_RECORD_EXPR, TREE_TYPE (min), min, expr);
if (! TREE_CONSTANT (max) && contains_placeholder_p (max))
max = build (WITH_RECORD_EXPR, TREE_TYPE (max), max, expr);
template_elts = tree_cons (TREE_CHAIN (field), max,
tree_cons (field, min, template_elts));
}
return build_constructor (template_type, nreverse (template_elts));
}
tree
build_vms_descriptor (type, mech, gnat_entity)
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 ((int) TYPE_DIGITS_VALUE (type))
{
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 = TREE_UNSIGNED (type) ? 2 : 6;
break;
case 16:
dtype = TREE_UNSIGNED (type) ? 3 : 7;
break;
case 32:
dtype = TREE_UNSIGNED (type) ? 4 : 8;
break;
case 64:
dtype = TREE_UNSIGNED (type) ? 5 : 9;
break;
case 128:
dtype = TREE_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 ((int) TYPE_DIGITS_VALUE (type))
{
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", 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", type_for_size (8, 1),
record_type, size_int (dtype)));
field_list = chainon (field_list,
make_descriptor_field ("CLASS", type_for_size (8, 1),
record_type, size_int (class)));
field_list
= chainon (field_list,
make_descriptor_field ("POINTER",
build_pointer_type (type),
record_type,
build1 (ADDR_EXPR,
build_pointer_type (type),
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", 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", 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",
type_for_size (8, 1),
record_type,
size_zero_node));
field_list = chainon (field_list,
make_descriptor_field ("DIGITS",
type_for_size (8, 1),
record_type,
size_zero_node));
field_list
= chainon (field_list,
make_descriptor_field
("AFLAGS", 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",
type_for_size (8, 1),
record_type,
size_int (ndim)));
field_list = chainon (field_list,
make_descriptor_field ("ARSIZE",
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 (inner_type), record_type,
build1 (ADDR_EXPR, build_pointer_type (inner_type), 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,
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, 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, 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 (name, type, rec_type, initial)
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 (template_type, object_type, name)
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 (old_type, new_type)
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));
if (old_type == new_type)
return;
if (TREE_CODE (new_type) != UNCONSTRAINED_ARRAY_TYPE)
{
if (ptr != 0)
TREE_TYPE (ptr) = new_type;
TYPE_POINTER_TO (new_type) = ptr;
if (ref != 0)
TREE_TYPE (ref) = new_type;
TYPE_REFERENCE_TO (new_type) = ref;
if (ptr != 0 && 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);
if (ref != 0 && 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))
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 (type, expr)
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
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);
expr = build_unary_op (ADDR_EXPR, NULL_TREE,
build_component_ref (expr, NULL_TREE,
TREE_CHAIN (fields)));
}
else
template = build_template (template_type, TREE_TYPE (etype), expr);
template_addr = build_unary_op (ADDR_EXPR, NULL_TREE, template);
return
build_constructor (type,
tree_cons (TYPE_FIELDS (type), expr,
tree_cons (TREE_CHAIN (TYPE_FIELDS (type)),
template_addr, NULL_TREE)));
}
static tree
convert_to_thin_pointer (type, expr)
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)));
expr = build1 (NOP_EXPR, type, expr);
return expr;
}
tree
convert (type, expr)
tree type, 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;
if (TREE_CODE (expr) == WITH_RECORD_EXPR)
return build (WITH_RECORD_EXPR, type,
convert (type, TREE_OPERAND (expr, 0)),
TREE_OPERAND (expr, 1));
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)));
}
else if (code == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
if (TREE_CODE (expr) == UNCHECKED_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 (DECL_SIZE (TYPE_FIELDS (type))) != INTEGER_CST
&& contains_placeholder_p (DECL_SIZE (TYPE_FIELDS (type)))
&& TREE_CODE (etype) == RECORD_TYPE)
return unchecked_convert (type, expr);
else
return
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)));
if (code == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (type)
&& ! (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype)))
{
tree obj_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
return
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:
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))
{
expr = copy_node (expr);
TREE_TYPE (expr) = type;
if (TYPE_MODE (type) != TYPE_MODE (etype))
TREE_CST_RTL (expr) = 0;
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))
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));
etype = TREE_TYPE (expr);
ecode = TREE_CODE (etype);
break;
case UNCHECKED_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))
return unchecked_convert (type, expr);
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);
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
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);
case UNION_TYPE:
for (tem = TYPE_FIELDS (type); tem; tem = TREE_CHAIN (tem))
if (TREE_TYPE (tem) == etype)
return build1 (CONVERT_EXPR, type, 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 (exp)
tree exp;
{
switch (TREE_CODE (exp))
{
case CONSTRUCTOR:
if (TREE_CODE (TREE_TYPE (exp)) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (TREE_TYPE (exp)))
return remove_conversions (TREE_VALUE (CONSTRUCTOR_ELTS (exp)));
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));
break;
case UNCHECKED_CONVERT_EXPR:
case NOP_EXPR: case CONVERT_EXPR:
return remove_conversions (TREE_OPERAND (exp, 0));
default:
break;
}
return exp;
}
tree
maybe_unconstrained_array (exp)
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));
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));
else if (code == WITH_RECORD_EXPR
&& (TREE_OPERAND (exp, 0)
!= (new = maybe_unconstrained_array
(TREE_OPERAND (exp, 0)))))
return build (WITH_RECORD_EXPR, TREE_TYPE (new), new,
TREE_OPERAND (exp, 1));
case RECORD_TYPE:
if (TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (exp)))
{
new
= build_component_ref (exp, NULL_TREE,
TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (exp))));
if (TREE_CODE (TREE_TYPE (new)) == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (new)))
new = convert (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (new))), new);
return new;
}
break;
default:
break;
}
return exp;
}
tree
unchecked_convert (type, expr)
tree type;
tree expr;
{
tree etype = TREE_TYPE (expr);
if (etype == type)
return expr;
if (TREE_CODE (expr) == WITH_RECORD_EXPR)
return build (WITH_RECORD_EXPR, type,
unchecked_convert (type, TREE_OPERAND (expr, 0)),
TREE_OPERAND (expr, 1));
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);
expr = build_component_ref (expr, NULL_TREE, field);
}
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 = build_constructor (rec_type, build_tree_list (field, expr));
expr = unchecked_convert (type, expr);
}
else if (TREE_CODE (etype) == UNCONSTRAINED_ARRAY_TYPE
&& TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
expr = build_unary_op (INDIRECT_REF, NULL_TREE,
build1 (UNCHECKED_CONVERT_EXPR, TREE_TYPE (type),
build_unary_op (ADDR_EXPR, NULL_TREE,
expr)));
else if (AGGREGATE_TYPE_P (type) && AGGREGATE_TYPE_P (etype)
&& TREE_CODE (type) != UNION_TYPE
&& TYPE_ALIGN (type) == TYPE_ALIGN (etype)
&& TYPE_MODE (type) == TYPE_MODE (etype))
expr = build1 (CONVERT_EXPR, type, expr);
else
{
expr = maybe_unconstrained_array (expr);
etype = TREE_TYPE (expr);
expr = build1 (UNCHECKED_CONVERT_EXPR, type, expr);
}
if (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)
&& TREE_UNSIGNED (type) == TREE_UNSIGNED (etype)
&& operand_equal_p (TYPE_RM_SIZE (type),
(TYPE_RM_SIZE (etype) != 0
? TYPE_RM_SIZE (etype) : TYPE_SIZE (etype)),
0))
&& ! (TREE_UNSIGNED (type) && TREE_UNSIGNED (etype)))
{
tree base_type = type_for_mode (TYPE_MODE (type), TREE_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) == UNCHECKED_CONVERT_EXPR
&& ! operand_equal_p (TYPE_SIZE_UNIT (type), TYPE_SIZE_UNIT (etype), 1))
TREE_CONSTANT (expr) = 0;
return expr;
}