#include "config.h"
#include "system.h"
#include "tree.h"
#include "flags.h"
#include "toplev.h"
#include "convert.h"
#include "ggc.h"
#include "obstack.h"
#include "ada.h"
#include "types.h"
#include "atree.h"
#include "elists.h"
#include "namet.h"
#include "nlists.h"
#include "repinfo.h"
#include "snames.h"
#include "stringt.h"
#include "uintp.h"
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
#include "ada-tree.h"
#include "gigi.h"
extern int debug_no_type_hash;
#ifndef STACK_CHECK_BUILTIN
#define STACK_CHECK_BUILTIN 0
#endif
#ifndef STACK_CHECK_PROBE_INTERVAL
#define STACK_CHECK_PROBE_INTERVAL 4096
#endif
#ifndef STACK_CHECK_MAX_FRAME_SIZE
#define STACK_CHECK_MAX_FRAME_SIZE \
(STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
#endif
#ifndef STACK_CHECK_MAX_VAR_SIZE
#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
#endif
static int defer_incomplete_level = 0;
static struct incomplete
{
struct incomplete *next;
tree old_type;
Entity_Id full_type;
} *defer_incomplete_list = 0;
static tree substitution_list PARAMS ((Entity_Id, Entity_Id,
tree, int));
static int allocatable_size_p PARAMS ((tree, int));
static struct attrib *build_attr_list PARAMS ((Entity_Id));
static tree elaborate_expression PARAMS ((Node_Id, Entity_Id, tree,
int, int, int));
static tree elaborate_expression_1 PARAMS ((Node_Id, Entity_Id, tree,
tree, int, int));
static tree make_packable_type PARAMS ((tree));
static tree maybe_pad_type PARAMS ((tree, tree, unsigned int,
Entity_Id, const char *, int,
int, int));
static tree gnat_to_gnu_field PARAMS ((Entity_Id, tree, int, int));
static void components_to_record PARAMS ((tree, Node_Id, tree, int,
int, tree *, int, int));
static int compare_field_bitpos PARAMS ((const PTR, const PTR));
static Uint annotate_value PARAMS ((tree));
static void annotate_rep PARAMS ((Entity_Id, tree));
static tree compute_field_positions PARAMS ((tree, tree, tree, tree));
static tree validate_size PARAMS ((Uint, tree, Entity_Id,
enum tree_code, int, int));
static void set_rm_size PARAMS ((Uint, tree, Entity_Id));
static tree make_type_from_size PARAMS ((tree, tree, int));
static unsigned int validate_alignment PARAMS ((Uint, Entity_Id,
unsigned int));
static void check_ok_for_atomic PARAMS ((tree, Entity_Id, int));
tree
gnat_to_gnu_type (gnat_entity)
Entity_Id gnat_entity;
{
tree gnu_decl;
gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
if (TREE_CODE (gnu_decl) != TYPE_DECL)
gigi_abort (101);
return TREE_TYPE (gnu_decl);
}
tree
gnat_to_gnu_entity (gnat_entity, gnu_expr, definition)
Entity_Id gnat_entity;
tree gnu_expr;
int definition;
{
tree gnu_entity_id;
tree gnu_type = 0;
tree gnu_decl = 0;
int saved = 0;
int this_deferred = 0;
int this_global = 0;
int maybe_present = 0;
int this_made_decl = 0;
struct attrib *attr_list = 0;
int debug_info_p = (Needs_Debug_Info (gnat_entity)
|| debug_info_level == DINFO_LEVEL_VERBOSE);
Entity_Kind kind = Ekind (gnat_entity);
Entity_Id gnat_temp;
unsigned int esize
= ((Known_Esize (gnat_entity)
&& UI_Is_In_Int_Range (Esize (gnat_entity)))
? MIN (UI_To_Int (Esize (gnat_entity)),
IN (kind, Float_Kind)
? LONG_DOUBLE_TYPE_SIZE
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
: LONG_LONG_TYPE_SIZE)
: LONG_LONG_TYPE_SIZE);
tree gnu_size = 0;
int imported_p
= ((Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)))
|| From_With_Type (gnat_entity));
unsigned int align = 0;
if (! definition && Is_Itype (gnat_entity)
&& ! present_gnu_tree (gnat_entity)
&& In_Extended_Main_Code_Unit (gnat_entity))
{
if (current_function_decl == 0
|| DECL_ELABORATION_PROC_P (current_function_decl))
{
process_type (gnat_entity);
return get_gnu_tree (gnat_entity);
}
for (gnat_temp = Scope (gnat_entity);
Present (gnat_temp); gnat_temp = Scope (gnat_temp))
{
if (Is_Type (gnat_temp))
gnat_temp = Underlying_Type (gnat_temp);
if (Ekind (gnat_temp) == E_Subprogram_Body)
gnat_temp
= Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
if (IN (Ekind (gnat_temp), Subprogram_Kind)
&& Present (Protected_Body_Subprogram (gnat_temp)))
gnat_temp = Protected_Body_Subprogram (gnat_temp);
if (Ekind (gnat_temp) == E_Entry
|| Ekind (gnat_temp) == E_Entry_Family
|| Ekind (gnat_temp) == E_Task_Type
|| (IN (Ekind (gnat_temp), Subprogram_Kind)
&& present_gnu_tree (gnat_temp)
&& (current_function_decl
== gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
{
process_type (gnat_entity);
return get_gnu_tree (gnat_entity);
}
}
gigi_abort (122);
}
if (gnat_entity == 0)
gigi_abort (102);
if (present_gnu_tree (gnat_entity)
&& (! definition
|| (Is_Type (gnat_entity) && imported_p)))
{
gnu_decl = get_gnu_tree (gnat_entity);
if (TREE_CODE (gnu_decl) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl))
&& IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
NULL_TREE, 0);
save_gnu_tree (gnat_entity, NULL_TREE, 0);
save_gnu_tree (gnat_entity, gnu_decl, 0);
}
return gnu_decl;
}
if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind)
|| (IN (kind, Access_Kind)
&& kind != E_Access_Protected_Subprogram_Type
&& kind != E_Access_Subtype))
&& Unknown_Esize (gnat_entity)
&& ! Has_Size_Clause (gnat_entity))
gigi_abort (109);
if (IN (kind, Discrete_Or_Fixed_Point_Kind)
&& Unknown_RM_Size (gnat_entity))
gigi_abort (123);
gnu_entity_id = get_entity_name (gnat_entity);
set_lineno (gnat_entity, 0);
if (! definition && ! Is_Public (gnat_entity)
&& ! type_annotate_only
&& kind != E_Discriminant && kind != E_Component
&& kind != E_Label
&& ! (kind == E_Constant && Present (Full_View (gnat_entity)))
#if 1
&& !IN (kind, Type_Kind)
#endif
)
gigi_abort (116);
if (! definition && Is_Public (gnat_entity)
&& ! Is_Statically_Allocated (gnat_entity)
&& kind != E_Discriminant && kind != E_Component)
force_global++, this_global = 1;
if (Has_Gigi_Rep_Item (gnat_entity))
attr_list = build_attr_list (gnat_entity);
switch (kind)
{
case E_Constant:
if (! definition && Present (Full_View (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
gnu_expr, definition);
saved = 1;
break;
}
if (! definition
&& Present (Expression (Declaration_Node (gnat_entity)))
&& ! No_Initialization (Declaration_Node (gnat_entity)))
gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
if (definition && gnu_expr == 0
&& ! No_Initialization (Declaration_Node (gnat_entity))
&& No (Renamed_Object (gnat_entity)))
{
gnu_decl = error_mark_node;
saved = 1;
break;
}
else if (! definition && IN (kind, Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
NULL_TREE, 0);
saved = 1;
break;
}
goto object;
case E_Exception:
if (! Is_VMS_Exception (gnat_entity))
goto object;
gnu_decl = create_var_decl (gnu_entity_id,
(Present (Interface_Name (gnat_entity))
? create_concat_name (gnat_entity, 0)
: NULL_TREE),
char_type_node, NULL_TREE, 0, 0, 1, 1,
0);
gnu_decl
= build_binary_op (BIT_AND_EXPR, integer_type_node,
convert (integer_type_node,
build_unary_op (ADDR_EXPR, NULL_TREE,
gnu_decl)),
build_unary_op (NEGATE_EXPR, integer_type_node,
build_int_2 (7, 0)));
save_gnu_tree (gnat_entity, gnu_decl, 1);
saved = 1;
break;
case E_Discriminant:
case E_Component:
{
Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
if ((Base_Type (gnat_record) == gnat_record
|| Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
|| Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
&& Present (Original_Record_Component (gnat_entity))
&& Original_Record_Component (gnat_entity) != gnat_entity)
{
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
gnu_expr, definition);
saved = 1;
break;
}
else if (Present (Corresponding_Discriminant (gnat_entity))
&& Is_Tagged_Type (gnat_record))
{
if (First_Discriminant (gnat_record)
!= First_Girder_Discriminant (gnat_record))
gigi_abort (119);
gnu_decl
= gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
gnu_expr, definition);
saved = 1;
break;
}
else if (Present (Corresponding_Discriminant (gnat_entity))
&& (First_Discriminant (gnat_record)
!= First_Girder_Discriminant (gnat_record)))
gigi_abort (120);
else if (! definition && ! present_gnu_tree (gnat_record))
{
if (Is_Protected_Type (Scope (Scope (gnat_entity)))
&& Present (Original_Record_Component (gnat_entity)))
{
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component
(gnat_entity),
gnu_expr, definition);
saved = 1;
break;
}
gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
gnu_decl = get_gnu_tree (gnat_entity);
saved = 1;
break;
}
else
gigi_abort (103);
}
case E_Loop_Parameter:
case E_Out_Parameter:
case E_Variable:
object:
{
int used_by_ref = 0;
int const_flag
= ((kind == E_Constant || kind == E_Variable)
&& ! Is_Statically_Allocated (gnat_entity)
&& Is_True_Constant (gnat_entity)
&& (((Nkind (Declaration_Node (gnat_entity))
== N_Object_Declaration)
&& Present (Expression (Declaration_Node (gnat_entity))))
|| Present (Renamed_Object (gnat_entity))));
int inner_const_flag = const_flag;
int static_p = Is_Statically_Allocated (gnat_entity);
tree gnu_ext_name = NULL_TREE;
if (Present (Renamed_Object (gnat_entity)) && ! definition)
{
if (kind == E_Exception)
gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
NULL_TREE, 0);
else
gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
}
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
if (kind == E_Loop_Parameter)
gnu_type = get_base_type (gnu_type);
if ((TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE
&& No (Renamed_Object (gnat_entity)))
|| TYPE_IS_DUMMY_P (gnu_type)
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
if (type_annotate_only)
return error_mark_node;
else
gigi_abort (104);
}
if (definition)
gnu_size = validate_size (Esize (gnat_entity), gnu_type,
gnat_entity, VAR_DECL, 0,
Has_Size_Clause (gnat_entity));
if (gnu_size != 0)
{
gnu_type
= make_type_from_size (gnu_type, gnu_size,
Has_Biased_Representation (gnat_entity));
if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0))
gnu_size = 0;
}
if (No (Renamed_Object (gnat_entity))
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type)))
{
if (gnu_expr != 0 && kind == E_Constant)
{
gnu_size = TYPE_SIZE (TREE_TYPE (gnu_expr));
if (TREE_CODE (gnu_size) != INTEGER_CST
&& contains_placeholder_p (gnu_size))
{
tree gnu_temp = gnu_expr;
while (TREE_CODE (gnu_temp) == UNCHECKED_CONVERT_EXPR)
gnu_temp = TREE_OPERAND (gnu_temp, 0);
gnu_size = TYPE_SIZE (TREE_TYPE (gnu_temp));
if (TREE_CODE (gnu_size) != INTEGER_CST
&& contains_placeholder_p (gnu_size))
gnu_size = build (WITH_RECORD_EXPR, bitsizetype,
gnu_size, gnu_temp);
}
}
else if (kind == E_Constant
&& (Nkind (Declaration_Node (gnat_entity))
== N_Object_Declaration)
&& Present (Expression (Declaration_Node (gnat_entity))))
gnu_size
= TYPE_SIZE (gnat_to_gnu_type
(Etype
(Expression (Declaration_Node (gnat_entity)))));
else
gnu_size = max_size (TYPE_SIZE (gnu_type), 1);
}
if (((gnu_size != 0 && integer_zerop (gnu_size))
|| (TYPE_SIZE (gnu_type) != 0
&& integer_zerop (TYPE_SIZE (gnu_type))))
&& (! Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
|| ! Is_Array_Type (Etype (gnat_entity))))
gnu_size = bitsize_unit_node;
if (kind != E_Exception && Known_Alignment (gnat_entity))
{
if (No (Alignment (gnat_entity)))
gigi_abort (125);
align
= validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (gnu_type));
}
if (Is_Atomic (gnat_entity) && gnu_size == 0 && align == 0
&& TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
{
if (! host_integerp (TYPE_SIZE (gnu_type), 1)
|| 0 <= compare_tree_int (TYPE_SIZE (gnu_type),
BIGGEST_ALIGNMENT))
align = BIGGEST_ALIGNMENT;
else
align = ((unsigned int) 1
<< (floor_log2 (tree_low_cst
(TYPE_SIZE (gnu_type), 1) - 1)
+ 1));
}
#ifdef MINIMUM_ATOMIC_ALIGNMENT
if (align == 0 && MINIMUM_ATOMIC_ALIGNMENT > TYPE_ALIGN (gnu_type)
&& ! FLOAT_TYPE_P (gnu_type)
&& ! const_flag && No (Renamed_Object (gnat_entity))
&& ! imported_p && No (Address_Clause (gnat_entity))
&& kind != E_Out_Parameter
&& (gnu_size != 0 ? TREE_CODE (gnu_size) == INTEGER_CST
: TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
align = MINIMUM_ATOMIC_ALIGNMENT;
#endif
if (Has_Atomic_Components (gnat_entity))
{
tree gnu_inner
= (TREE_CODE (gnu_type) == ARRAY_TYPE
? TREE_TYPE (gnu_type) : gnu_type);
while (TREE_CODE (gnu_inner) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (gnu_inner))
gnu_inner = TREE_TYPE (gnu_inner);
check_ok_for_atomic (gnu_inner, gnat_entity, 1);
}
gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
gnat_entity, "PAD", 0, definition, 1);
if ((Is_Volatile (gnat_entity)
|| Is_Exported (gnat_entity)
|| Is_Imported (gnat_entity)
|| Present (Address_Clause (gnat_entity)))
&& ! TYPE_VOLATILE (gnu_type))
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| TYPE_QUAL_VOLATILE));
if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
&& Is_Array_Type (Etype (gnat_entity))
&& ! type_annotate_only)
{
tree gnu_fat
= TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
tree gnu_temp_type
= TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
gnu_type
= build_unc_object_type (gnu_temp_type, gnu_type,
concat_id_with_name (gnu_entity_id,
"UNC"));
}
if (gnu_expr != 0
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type)))
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type)
&& (contains_placeholder_p
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
if (Present (Renamed_Object (gnat_entity)))
{
if (TREE_CODE (gnu_expr) == COMPONENT_REF
&& (TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
== RECORD_TYPE)
&& (TYPE_IS_PADDING_P
(TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
{
gnu_expr = TREE_OPERAND (gnu_expr, 0);
gnu_type = TREE_TYPE (gnu_expr);
}
if (const_flag
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& TYPE_MODE (gnu_type) != BLKmode
&& Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
&& !Is_Array_Type (Etype (gnat_entity)))
;
else if ((DECL_P (gnu_expr)
|| TREE_CODE_CLASS (TREE_CODE (gnu_expr)) == 'r')
&& ! Materialize_Entity (gnat_entity)
&& (! global_bindings_p ()
|| (staticp (gnu_expr)
&& ! TREE_SIDE_EFFECTS (gnu_expr))))
{
set_lineno (gnat_entity, ! global_bindings_p ());
gnu_decl = gnat_stabilize_reference (gnu_expr, 1);
save_gnu_tree (gnat_entity, gnu_decl, 1);
saved = 1;
if (! global_bindings_p ())
expand_expr_stmt (build1 (CONVERT_EXPR, void_type_node,
gnu_decl));
break;
}
else
{
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = 1;
gnu_type = build_reference_type (gnu_type);
gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
gnu_size = 0;
used_by_ref = 1;
}
}
else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type)
&& gnu_expr == 0)
gnu_expr
= build_constructor
(gnu_type,
tree_cons
(TYPE_FIELDS (gnu_type),
build_template
(TREE_TYPE (TYPE_FIELDS (gnu_type)),
TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))),
NULL_TREE),
NULL_TREE));
if (definition
&& (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
&& gnu_expr == 0)
gnu_expr = integer_zero_node;
if (definition && Present (Address_Clause (gnat_entity)))
{
tree gnu_address
= (present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity)
: gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
save_gnu_tree (gnat_entity, NULL_TREE, 0);
gnu_size = 0;
gnu_type = build_reference_type (gnu_type);
gnu_address = convert (gnu_type, gnu_address);
used_by_ref = 1;
const_flag = ! Is_Public (gnat_entity);
if (gnu_expr == 0)
gnu_expr = gnu_address;
else
gnu_expr
= build (COMPOUND_EXPR, gnu_type,
build_binary_op
(MODIFY_EXPR, NULL_TREE,
build_unary_op (INDIRECT_REF, NULL_TREE,
gnu_address),
gnu_expr),
gnu_address);
}
if ((! definition && Present (Address_Clause (gnat_entity)))
|| (Is_Imported (gnat_entity)
&& Convention (gnat_entity) == Convention_Stdcall))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = 0;
used_by_ref = 1;
}
if (! allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
global_bindings_p () || ! definition
|| static_p)
|| (gnu_size != 0
&& ! allocatable_size_p (gnu_size,
global_bindings_p () || ! definition
|| static_p)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = 0;
used_by_ref = 1;
const_flag = 1;
if (definition)
{
tree gnu_alloc_type = TREE_TYPE (gnu_type);
if (TREE_CODE (gnu_alloc_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
{
gnu_alloc_type
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))));
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
&& ! Is_Imported (gnat_entity))
post_error ("Storage_Error will be raised at run-time?",
gnat_entity);
gnu_expr = build_allocator (gnu_alloc_type, gnu_expr,
gnu_type, 0, 0);
}
else
{
gnu_expr = 0;
const_flag = 0;
}
}
if (! global_bindings_p () && ! static_p && definition
&& ! imported_p && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
{
tree gnu_new_type
= make_aligning_type (gnu_type, TYPE_ALIGN (gnu_type),
TYPE_SIZE_UNIT (gnu_type));
tree gnu_new_var;
if (gnu_expr != 0)
gnu_expr
= build_constructor (gnu_new_type,
tree_cons (TYPE_FIELDS (gnu_new_type),
gnu_expr, NULL_TREE));
set_lineno (gnat_entity, 1);
gnu_new_var
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, gnu_expr,
0, 0, 0, 0, 0);
gnu_type = build_reference_type (gnu_type);
gnu_expr
= build_unary_op
(ADDR_EXPR, gnu_type,
build_component_ref (gnu_new_var, NULL_TREE,
TYPE_FIELDS (gnu_new_type)));
gnu_size = 0;
used_by_ref = 1;
const_flag = 1;
}
if (gnu_expr != 0
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& ! (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type)))
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type)
&& (contains_placeholder_p
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
if ((Present (Interface_Name (gnat_entity))
&& No (Address_Clause (gnat_entity)))
|| (Is_Public (gnat_entity)
&& (! Is_Imported (gnat_entity) || Is_Exported (gnat_entity))))
gnu_ext_name = create_concat_name (gnat_entity, 0);
if (const_flag)
gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
| TYPE_QUAL_CONST));
if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
&& host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
&& (AGGREGATE_TYPE_P (gnu_type)
&& ! (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type))))
static_p = 1;
set_lineno (gnat_entity, ! global_bindings_p ());
gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, const_flag,
Is_Public (gnat_entity),
imported_p || !definition,
static_p, attr_list);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
if (definition && DECL_SIZE (gnu_decl) != 0
&& gnu_block_stack != 0
&& TREE_VALUE (gnu_block_stack) != 0
&& (TREE_CODE (DECL_SIZE (gnu_decl)) != INTEGER_CST
|| (flag_stack_check && ! STACK_CHECK_BUILTIN
&& 0 < compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
STACK_CHECK_MAX_VAR_SIZE))))
update_setjmp_buf (TREE_VALUE (gnu_block_stack));
if (definition && TREE_CODE (gnu_decl) == CONST_DECL
&& (Is_Public (gnat_entity)
|| optimize == 0
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
|| Is_Aliased (Etype (gnat_entity))))
DECL_CONST_CORRESPONDING_VAR (gnu_decl)
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, 0, Is_Public (gnat_entity), 0,
static_p, 0);
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_decl, gnat_entity, 0);
if (Has_Nested_Block_With_Handler (Scope (gnat_entity)))
{
mark_addressable (gnu_decl);
flush_addressof (gnu_decl);
}
if (! used_by_ref && Unknown_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
UI_From_Int (DECL_ALIGN (gnu_decl) / BITS_PER_UNIT));
if (! used_by_ref && Unknown_Esize (gnat_entity)
&& DECL_SIZE (gnu_decl) != 0)
{
tree gnu_back_size = DECL_SIZE (gnu_decl);
if (TREE_CODE (TREE_TYPE (gnu_decl)) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (TREE_TYPE (gnu_decl)))
gnu_back_size
= TYPE_SIZE (TREE_TYPE (TREE_CHAIN
(TYPE_FIELDS (TREE_TYPE (gnu_decl)))));
Set_Esize (gnat_entity, annotate_value (gnu_back_size));
}
}
break;
case E_Void:
gnu_decl = void_type_decl_node;
break;
case E_Enumeration_Type:
if (No (First_Literal (gnat_entity)))
{
gnu_type = make_unsigned_type (esize);
break;
}
{
Entity_Id gnat_literal;
tree gnu_literal_list = NULL_TREE;
if (Is_Unsigned_Type (gnat_entity))
gnu_type = make_unsigned_type (esize);
else
gnu_type = make_signed_type (esize);
TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
for (gnat_literal = First_Literal (gnat_entity);
Present (gnat_literal);
gnat_literal = Next_Literal (gnat_literal))
{
tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
gnu_type);
tree gnu_literal
= create_var_decl (get_entity_name (gnat_literal),
0, gnu_type, gnu_value, 1, 0, 0, 0, 0);
save_gnu_tree (gnat_literal, gnu_literal, 0);
gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
gnu_value, gnu_literal_list);
}
TYPE_FIELDS (gnu_type) = nreverse (gnu_literal_list);
}
break;
case E_Signed_Integer_Type:
case E_Ordinary_Fixed_Point_Type:
case E_Decimal_Fixed_Point_Type:
gnu_type = make_signed_type (esize);
break;
case E_Modular_Integer_Type:
{
enum machine_mode mode;
tree gnu_modulus;
tree gnu_high = 0;
if (Is_Packed_Array_Type (gnat_entity))
esize = UI_To_Int (RM_Size (gnat_entity));
for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
GET_MODE_BITSIZE (mode) < esize;
mode = GET_MODE_WIDER_MODE (mode))
;
gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= Is_Packed_Array_Type (gnat_entity);
gnu_modulus = UI_To_gnu (Modulus (gnat_entity), gnu_type);
if (! integer_zerop (gnu_modulus))
{
TYPE_MODULAR_P (gnu_type) = 1;
TYPE_MODULUS (gnu_type) = gnu_modulus;
gnu_high = fold (build (MINUS_EXPR, gnu_type, gnu_modulus,
convert (gnu_type, integer_one_node)));
}
if (TYPE_PRECISION (gnu_type) != esize
|| (TYPE_MODULAR_P (gnu_type)
&& ! tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
{
tree gnu_subtype = make_node (INTEGER_TYPE);
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
TREE_TYPE (gnu_subtype) = gnu_type;
TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
TYPE_MAX_VALUE (gnu_subtype)
= TYPE_MODULAR_P (gnu_type)
? gnu_high : TYPE_MAX_VALUE (gnu_type);
TYPE_PRECISION (gnu_subtype) = esize;
TREE_UNSIGNED (gnu_subtype) = 1;
TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
= Is_Packed_Array_Type (gnat_entity);
layout_type (gnu_subtype);
gnu_type = gnu_subtype;
}
}
break;
case E_Signed_Integer_Subtype:
case E_Enumeration_Subtype:
case E_Modular_Integer_Subtype:
case E_Ordinary_Fixed_Point_Subtype:
case E_Decimal_Fixed_Point_Subtype:
if (definition == 0
&& Present (Ancestor_Subtype (gnat_entity))
&& ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
&& (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
|| ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
gnu_expr, definition);
gnu_type = make_node (INTEGER_TYPE);
if (Is_Packed_Array_Type (gnat_entity))
{
esize = UI_To_Int (RM_Size (gnat_entity));
TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
}
TYPE_PRECISION (gnu_type) = esize;
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
TYPE_MIN_VALUE (gnu_type)
= convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_Low_Bound (gnat_entity),
gnat_entity,
get_identifier ("L"), definition, 1,
Needs_Debug_Info (gnat_entity)));
TYPE_MAX_VALUE (gnu_type)
= convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_High_Bound (gnat_entity),
gnat_entity,
get_identifier ("U"), definition, 1,
Needs_Debug_Info (gnat_entity)));
if (present_gnu_tree (gnat_entity))
{
maybe_present = 1;
break;
}
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
TREE_UNSIGNED (gnu_type)
= (TREE_UNSIGNED (TREE_TYPE (gnu_type))
|| (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
&& TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
|| TYPE_BIASED_REPRESENTATION_P (gnu_type)
|| Is_Unsigned_Type (gnat_entity));
layout_type (gnu_type);
if (Is_Packed_Array_Type (gnat_entity) && BYTES_BIG_ENDIAN)
{
tree gnu_field_type = gnu_type;
tree gnu_field;
TYPE_RM_SIZE_INT (gnu_field_type)
= UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "LJM");
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
gnu_field = create_field_decl (get_identifier ("OBJECT"),
gnu_field_type, gnu_type, 1, 0, 0, 1),
finish_record_type (gnu_type, gnu_field, 0, 0);
TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type) = 1;
TYPE_ADA_SIZE (gnu_type) = bitsize_int (esize);
}
break;
case E_Floating_Point_Type:
if (Vax_Float (gnat_entity))
{
gnu_type = make_signed_type (esize);
TYPE_VAX_FLOATING_POINT_P (gnu_type) = 1;
TYPE_DIGITS_VALUE (gnu_type)
= UI_To_Int (Digits_Value (gnat_entity));
break;
}
gnu_type = make_node (REAL_TYPE);
TYPE_PRECISION (gnu_type) = esize;
layout_type (gnu_type);
break;
case E_Floating_Point_Subtype:
if (Vax_Float (gnat_entity))
{
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
break;
}
{
enum machine_mode mode;
if (definition == 0
&& Present (Ancestor_Subtype (gnat_entity))
&& ! In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
&& (! Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
|| ! Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
gnu_expr, definition);
for (mode = GET_CLASS_NARROWEST_MODE (MODE_FLOAT);
(GET_MODE_WIDER_MODE (mode) != VOIDmode
&& GET_MODE_BITSIZE (GET_MODE_WIDER_MODE (mode)) <= esize);
mode = GET_MODE_WIDER_MODE (mode))
;
gnu_type = make_node (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
TYPE_PRECISION (gnu_type) = GET_MODE_BITSIZE (mode);
TYPE_MIN_VALUE (gnu_type)
= convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_Low_Bound (gnat_entity),
gnat_entity, get_identifier ("L"),
definition, 1,
Needs_Debug_Info (gnat_entity)));
TYPE_MAX_VALUE (gnu_type)
= convert (TREE_TYPE (gnu_type),
elaborate_expression (Type_High_Bound (gnat_entity),
gnat_entity, get_identifier ("U"),
definition, 1,
Needs_Debug_Info (gnat_entity)));
if (present_gnu_tree (gnat_entity))
{
maybe_present = 1;
break;
}
layout_type (gnu_type);
}
break;
case E_String_Type:
case E_Array_Type:
{
tree gnu_template_fields = NULL_TREE;
tree gnu_template_type = make_node (RECORD_TYPE);
tree gnu_ptr_template = build_pointer_type (gnu_template_type);
tree gnu_fat_type = make_node (RECORD_TYPE);
int ndim = Number_Dimensions (gnat_entity);
int firstdim
= (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
int nextdim
= (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
tree gnu_comp_size = 0;
tree gnu_max_size = size_one_node;
tree gnu_max_size_unit;
int index;
Entity_Id gnat_ind_subtype;
Entity_Id gnat_ind_base_subtype;
tree gnu_template_reference;
tree tem;
TYPE_NAME (gnu_template_type)
= create_concat_name (gnat_entity, "XUB");
TYPE_NAME (gnu_fat_type) = create_concat_name (gnat_entity, "XUP");
TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
TREE_READONLY (gnu_template_type) = 1;
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
if (! definition)
{
defer_incomplete_level++;
this_deferred = this_made_decl = 1;
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
save_gnu_tree (gnat_entity, gnu_decl, 0);
saved = 1;
}
tem = chainon (chainon (NULL_TREE,
create_field_decl (get_identifier ("P_ARRAY"),
ptr_void_type_node,
gnu_fat_type, 0, 0, 0, 0)),
create_field_decl (get_identifier ("P_BOUNDS"),
gnu_ptr_template,
gnu_fat_type, 0, 0, 0, 0));
TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
finish_record_type (gnu_fat_type, tem, 0, 1);
tem = build (COMPONENT_REF, gnu_ptr_template,
build (PLACEHOLDER_EXPR, gnu_fat_type),
TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
gnu_template_reference
= build_unary_op (INDIRECT_REF, gnu_template_type, tem);
TREE_READONLY (gnu_template_reference) = 1;
for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
gnat_ind_base_subtype
= First_Index (Implementation_Base_Type (gnat_entity));
index < ndim && index >= 0;
index += nextdim,
gnat_ind_subtype = Next_Index (gnat_ind_subtype),
gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
{
char field_name[10];
tree gnu_ind_subtype
= get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
tree gnu_base_subtype
= get_unpadded_type (Etype (gnat_ind_base_subtype));
tree gnu_base_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
tree gnu_base_max
= convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
set_lineno (gnat_entity, 0);
sprintf (field_name, "LB%d", index);
gnu_min_field = create_field_decl (get_identifier (field_name),
gnu_ind_subtype,
gnu_template_type, 0, 0, 0, 0);
field_name[0] = 'U';
gnu_max_field = create_field_decl (get_identifier (field_name),
gnu_ind_subtype,
gnu_template_type, 0, 0, 0, 0);
gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
gnu_min = build (COMPONENT_REF, gnu_ind_subtype,
gnu_template_reference, gnu_min_field);
gnu_max = build (COMPONENT_REF, gnu_ind_subtype,
gnu_template_reference, gnu_max_field);
TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
gnu_index_types[index]
= create_index_type (convert (sizetype, gnu_min),
convert (sizetype, gnu_max),
build_range_type (gnu_ind_subtype,
gnu_min, gnu_max));
gnu_max_size
= size_binop (MULT_EXPR, gnu_max_size,
size_binop (PLUS_EXPR, size_one_node,
size_binop (MINUS_EXPR, gnu_base_max,
gnu_base_min)));
TYPE_NAME (gnu_index_types[index])
= create_concat_name (gnat_entity, field_name);
}
for (index = 0; index < ndim; index++)
gnu_template_fields
= chainon (gnu_template_fields, gnu_temp_fields[index]);
finish_record_type (gnu_template_type, gnu_template_fields, 0, 0);
TREE_READONLY (gnu_template_type) = 1;
tem = gnat_to_gnu_type (Component_Type (gnat_entity));
gnu_comp_size
= validate_size (Component_Size (gnat_entity), tem,
gnat_entity,
(Is_Bit_Packed_Array (gnat_entity)
? TYPE_DECL : VAR_DECL), 1,
Has_Component_Size_Clause (gnat_entity));
if (Has_Atomic_Components (gnat_entity))
check_ok_for_atomic (tem, gnat_entity, 1);
if (gnu_comp_size == 0 && TREE_CODE (tem) == RECORD_TYPE
&& TREE_CODE (TYPE_SIZE (tem)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (tem)))
gnu_comp_size = max_size (TYPE_SIZE (tem), 1);
if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
{
tem = make_type_from_size (tem, gnu_comp_size, 0);
tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
"C_PAD", 0, definition, 1);
}
if (Has_Volatile_Components (gnat_entity))
tem = build_qualified_type (tem,
TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
if (Unknown_Component_Size (gnat_entity))
Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
size_binop (MULT_EXPR, gnu_max_size,
TYPE_SIZE_UNIT (tem)));
gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
size_binop (MULT_EXPR,
convert (bitsizetype,
gnu_max_size),
TYPE_SIZE (tem)));
for (index = ndim - 1; index >= 0; index--)
{
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
TYPE_NONALIASED_COMPONENT (tem)
= ! Has_Aliased_Components (gnat_entity);
}
if (No (Packed_Array_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
if (No (Alignment (gnat_entity)))
gigi_abort (124);
TYPE_ALIGN (tem)
= validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (tem));
}
TYPE_CONVENTION_FORTRAN_P (tem)
= (Convention (gnat_entity) == Convention_Fortran);
TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
= TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
TYPE_MODE (gnu_type) = BLKmode;
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type) = gnu_type;
if (TREE_CODE (gnu_max_size) == INTEGER_CST
&& ! TREE_OVERFLOW (gnu_max_size))
{
TYPE_SIZE (tem)
= size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
TYPE_SIZE_UNIT (tem)
= size_binop (MIN_EXPR, gnu_max_size_unit,
TYPE_SIZE_UNIT (tem));
}
create_type_decl (create_concat_name (gnat_entity, "XUA"),
tem, 0, ! Comes_From_Source (gnat_entity),
debug_info_p);
rest_of_type_compilation (gnu_fat_type, global_bindings_p ());
tem = build_unc_object_type (gnu_template_type, tem,
create_concat_name (gnat_entity, "XUT"));
DECL_FIELD_OFFSET (TYPE_FIELDS (tem))
= size_binop (MINUS_EXPR, size_zero_node,
byte_position (TREE_CHAIN (TYPE_FIELDS (tem))));
DECL_FIELD_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem))) = size_zero_node;
DECL_FIELD_BIT_OFFSET (TREE_CHAIN (TYPE_FIELDS (tem)))
= bitsize_zero_node;
TYPE_UNCONSTRAINED_ARRAY (tem) = gnu_type;
TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
create_type_decl (create_concat_name (gnat_entity, "XUX"),
build_pointer_type (tem), 0,
! Comes_From_Source (gnat_entity), debug_info_p);
}
break;
case E_String_Subtype:
case E_Array_Subtype:
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
if (! Is_Constrained (gnat_entity))
break;
else
{
int index;
int array_dim = Number_Dimensions (gnat_entity);
int first_dim
= ((Convention (gnat_entity) == Convention_Fortran)
? array_dim - 1 : 0);
int next_dim
= (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
Entity_Id gnat_ind_subtype;
Entity_Id gnat_ind_base_subtype;
tree gnu_base_type = gnu_type;
tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
tree gnu_comp_size = 0;
tree gnu_max_size = size_one_node;
tree gnu_max_size_unit;
int need_index_type_struct = 0;
int max_overflow = 0;
for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
gnat_ind_base_subtype
= First_Index (Implementation_Base_Type (gnat_entity));
index < array_dim && index >= 0;
index += next_dim,
gnat_ind_subtype = Next_Index (gnat_ind_subtype),
gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
{
tree gnu_index_subtype
= get_unpadded_type (Etype (gnat_ind_subtype));
tree gnu_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
tree gnu_max
= convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
tree gnu_base_subtype
= get_unpadded_type (Etype (gnat_ind_base_subtype));
tree gnu_base_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
tree gnu_base_max
= convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
tree gnu_base_type = get_base_type (gnu_base_subtype);
tree gnu_base_base_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
tree gnu_base_base_max
= convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
tree gnu_high;
tree gnu_this_max;
if ((TYPE_PRECISION (gnu_index_subtype)
> TYPE_PRECISION (sizetype))
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
&& (! TREE_OVERFLOW
(fold (build (MINUS_EXPR, gnu_index_subtype,
TYPE_MAX_VALUE (gnu_index_subtype),
TYPE_MIN_VALUE (gnu_index_subtype))))))
TREE_OVERFLOW (gnu_min) = TREE_OVERFLOW (gnu_max)
= TREE_CONSTANT_OVERFLOW (gnu_min)
= TREE_CONSTANT_OVERFLOW (gnu_max) = 0;
else if ((TYPE_PRECISION (gnu_index_subtype)
> TYPE_PRECISION (sizetype))
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
&& tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
TYPE_MIN_VALUE (gnu_index_subtype)))
gnu_min = size_one_node, gnu_max = size_zero_node;
gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
if (TREE_CODE (gnu_base_min) == INTEGER_CST
&& TREE_CODE (gnu_base_max) == INTEGER_CST
&& ! TREE_CONSTANT_OVERFLOW (gnu_base_min)
&& ! TREE_CONSTANT_OVERFLOW (gnu_base_max)
&& tree_int_cst_lt (gnu_base_max, gnu_base_min))
gnu_high = size_zero_node, gnu_min = size_one_node;
else if (TREE_CODE (gnu_high) == INTEGER_CST
&& TREE_OVERFLOW (gnu_high))
gnu_high = gnu_max;
else if (TREE_UNSIGNED (gnu_base_subtype)
|| TREE_CODE (gnu_high) == INTEGER_CST)
gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
else
gnu_high
= build_cond_expr
(sizetype, build_binary_op (GE_EXPR, integer_type_node,
gnu_max, gnu_min),
gnu_max, gnu_high);
gnu_index_type[index]
= create_index_type (gnu_min, gnu_high, gnu_index_subtype);
if ((TREE_CODE (gnu_min) == INTEGER_CST
&& ! TREE_OVERFLOW (gnu_min)
&& ! operand_equal_p (gnu_min, gnu_base_base_min, 0))
|| (TREE_CODE (gnu_min) != INTEGER_CST
&& ! contains_placeholder_p (gnu_min)))
gnu_base_min = gnu_min;
if ((TREE_CODE (gnu_max) == INTEGER_CST
&& ! TREE_OVERFLOW (gnu_max)
&& ! operand_equal_p (gnu_max, gnu_base_base_max, 0))
|| (TREE_CODE (gnu_max) != INTEGER_CST
&& ! contains_placeholder_p (gnu_max)))
gnu_base_max = gnu_max;
if ((TREE_CODE (gnu_base_min) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_base_min))
|| operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
|| (TREE_CODE (gnu_base_max) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_base_max))
|| operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
max_overflow = 1;
gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
gnu_this_max
= size_binop (MAX_EXPR,
size_binop (PLUS_EXPR, size_one_node,
size_binop (MINUS_EXPR, gnu_base_max,
gnu_base_min)),
size_zero_node);
if (TREE_CODE (gnu_this_max) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_this_max))
max_overflow = 1;
gnu_max_size
= size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
if (! integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
|| (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
!= INTEGER_CST)
|| TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
|| (TREE_TYPE (gnu_index_subtype) != 0
&& (TREE_CODE (TREE_TYPE (gnu_index_subtype))
!= INTEGER_TYPE))
|| TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
|| (TYPE_PRECISION (gnu_index_subtype)
> TYPE_PRECISION (sizetype)))
need_index_type_struct = 1;
}
gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
if (present_gnu_tree (gnat_entity))
{
maybe_present = 1;
break;
}
gnu_comp_size
= validate_size (Component_Size (gnat_entity), gnu_type,
gnat_entity,
(Is_Bit_Packed_Array (gnat_entity)
? TYPE_DECL : VAR_DECL),
1, Has_Component_Size_Clause (gnat_entity));
if (gnu_comp_size == 0 && TREE_CODE (gnu_type) == RECORD_TYPE
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type)))
gnu_comp_size = max_size (TYPE_SIZE (gnu_type), 1);
if (! Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size != 0)
{
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, 0);
gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
gnat_entity, "C_PAD", 0,
definition, 1);
}
if (Has_Volatile_Components (Base_Type (gnat_entity)))
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| TYPE_QUAL_VOLATILE));
gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
TYPE_SIZE_UNIT (gnu_type));
gnu_max_size = size_binop (MULT_EXPR,
convert (bitsizetype, gnu_max_size),
TYPE_SIZE (gnu_type));
debug_no_type_hash = 1;
for (index = array_dim - 1; index >= 0; index --)
{
gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
TYPE_NONALIASED_COMPONENT (gnu_type)
= ! Has_Aliased_Components (gnat_entity);
}
if (global_bindings_p () && array_dim > 1)
{
tree gnu_str_name = get_identifier ("ST");
tree gnu_arr_type;
for (gnu_arr_type = TREE_TYPE (gnu_type);
TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
gnu_arr_type = TREE_TYPE (gnu_arr_type),
gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
{
TYPE_SIZE (gnu_arr_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_arr_type),
gnu_str_name, definition, 0);
TYPE_SIZE_UNIT (gnu_arr_type)
= elaborate_expression_1
(gnat_entity, gnat_entity, TYPE_SIZE_UNIT (gnu_arr_type),
concat_id_with_name (gnu_str_name, "U"), definition, 0);
}
}
if (need_index_type_struct && debug_info_p)
{
tree gnu_bound_rec_type = make_node (RECORD_TYPE);
tree gnu_field_list = 0;
tree gnu_field;
TYPE_NAME (gnu_bound_rec_type)
= create_concat_name (gnat_entity, "XA");
for (index = array_dim - 1; index >= 0; index--)
{
tree gnu_type_name
= TYPE_NAME (TYPE_INDEX_TYPE (gnu_index_type[index]));
if (TREE_CODE (gnu_type_name) == TYPE_DECL)
gnu_type_name = DECL_NAME (gnu_type_name);
gnu_field = create_field_decl (gnu_type_name,
integer_type_node,
gnu_bound_rec_type,
0, NULL_TREE, NULL_TREE, 0);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
finish_record_type (gnu_bound_rec_type, gnu_field_list, 0, 0);
}
debug_no_type_hash = 0;
TYPE_CONVENTION_FORTRAN_P (gnu_type)
= (Convention (gnat_entity) == Convention_Fortran);
if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type))
&& ! (TREE_CODE (gnu_max_size) == INTEGER_CST
&& TREE_OVERFLOW (gnu_max_size))
&& ! max_overflow)
{
TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
TYPE_SIZE (gnu_type));
TYPE_SIZE_UNIT (gnu_type)
= size_binop (MIN_EXPR, gnu_max_size_unit,
TYPE_SIZE_UNIT (gnu_type));
}
TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
record_component_aliases (gnu_type);
}
if (Present (Packed_Array_Type (gnat_entity)))
{
Entity_Id gnat_index;
tree gnu_inner_type;
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
* Is_Volatile (gnat_entity))));
set_lineno (gnat_entity, 0);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
if (! Comes_From_Source (gnat_entity))
DECL_ARTIFICIAL (gnu_decl) = 1;
save_gnu_tree (gnat_entity, gnu_decl, 0);
gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
NULL_TREE, 0);
this_made_decl = 1;
gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
save_gnu_tree (gnat_entity, NULL_TREE, 0);
if (TREE_CODE (gnu_inner_type) == RECORD_TYPE
&& (TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_inner_type)
|| TYPE_IS_PADDING_P (gnu_inner_type)))
gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
&& TYPE_ACTUAL_BOUNDS (gnu_inner_type) == 0)
|| (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
&& ! TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
{
if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
{
if (TYPE_MODULAR_P (gnu_inner_type))
{
tree gnu_subtype;
gnu_subtype = make_node (INTEGER_TYPE);
TREE_TYPE (gnu_subtype) = gnu_inner_type;
TYPE_MIN_VALUE (gnu_subtype)
= TYPE_MIN_VALUE (gnu_inner_type);
TYPE_MAX_VALUE (gnu_subtype)
= TYPE_MAX_VALUE (gnu_inner_type);
TYPE_PRECISION (gnu_subtype)
= TYPE_PRECISION (gnu_inner_type);
TREE_UNSIGNED (gnu_subtype)
= TREE_UNSIGNED (gnu_inner_type);
TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
layout_type (gnu_subtype);
gnu_inner_type = gnu_subtype;
}
TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
}
TYPE_ACTUAL_BOUNDS (gnu_inner_type) = NULL_TREE;
for (gnat_index = First_Index (gnat_entity);
Present (gnat_index); gnat_index = Next_Index (gnat_index))
TYPE_ACTUAL_BOUNDS (gnu_inner_type)
= tree_cons (NULL_TREE,
get_unpadded_type (Etype (gnat_index)),
TYPE_ACTUAL_BOUNDS (gnu_inner_type));
if (Convention (gnat_entity) != Convention_Fortran)
TYPE_ACTUAL_BOUNDS (gnu_inner_type)
= nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type));
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_type))
TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
}
}
else if (Is_Packed (gnat_entity))
gigi_abort (107);
break;
case E_String_Literal_Subtype:
{
Entity_Id gnat_full_type
= (IN (Ekind (Etype (gnat_entity)), Private_Kind)
&& Present (Full_View (Etype (gnat_entity)))
? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
tree gnu_string_type = get_unpadded_type (gnat_full_type);
tree gnu_string_array_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_string_type))));
tree gnu_string_index_type
= TREE_TYPE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_string_array_type)));
tree gnu_lower_bound
= convert (gnu_string_index_type,
gnat_to_gnu (String_Literal_Low_Bound (gnat_entity)));
int length = UI_To_Int (String_Literal_Length (gnat_entity));
tree gnu_length = ssize_int (length - 1);
tree gnu_upper_bound
= build_binary_op (PLUS_EXPR, gnu_string_index_type,
gnu_lower_bound,
convert (gnu_string_index_type, gnu_length));
tree gnu_range_type
= build_range_type (gnu_string_index_type,
gnu_lower_bound, gnu_upper_bound);
tree gnu_index_type
= create_index_type (convert (sizetype,
TYPE_MIN_VALUE (gnu_range_type)),
convert (sizetype,
TYPE_MAX_VALUE (gnu_range_type)),
gnu_range_type);
gnu_type
= build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
gnu_index_type);
}
break;
case E_Record_Type:
#if 0
if (Has_Complex_Representation (gnat_entity))
{
gnu_type
= build_complex_type
(get_unpadded_type
(Etype (Defining_Entity
(First (Component_Items
(Component_List
(Type_Definition
(Declaration_Node (gnat_entity)))))))));
if (GET_MODE_BITSIZE (TYPE_MODE (TREE_TYPE (gnu_type)))
>= BITS_PER_WORD)
break;
}
#endif
{
Node_Id full_definition = Declaration_Node (gnat_entity);
Node_Id record_definition = Type_Definition (full_definition);
Entity_Id gnat_field;
tree gnu_field;
tree gnu_field_list = NULL_TREE;
tree gnu_get_parent;
int packed = (Is_Packed (gnat_entity) ? 1
: (Component_Alignment (gnat_entity)
== Calign_Storage_Unit) ? -1
: 0);
int has_rep = Has_Specified_Layout (gnat_entity);
int all_rep = has_rep;
int is_extension
= (Is_Tagged_Type (gnat_entity)
&& Nkind (record_definition) == N_Derived_Type_Definition);
for (gnat_field = First_Entity (gnat_entity);
Present (gnat_field) && all_rep;
gnat_field = Next_Entity (gnat_field))
if ((Ekind (gnat_field) == E_Component
|| Ekind (gnat_field) == E_Discriminant)
&& No (Component_Clause (gnat_field)))
all_rep = 0;
if (is_extension)
{
if (! type_annotate_only
|| Present (Record_Extension_Part (record_definition)))
record_definition = Record_Extension_Part (record_definition);
if (! type_annotate_only && No (Parent_Subtype (gnat_entity)))
gigi_abort (121);
}
gnu_type = make_dummy_type (gnat_entity);
TYPE_DUMMY_P (gnu_type) = 0;
if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL && debug_info_p)
DECL_IGNORED_P (TYPE_NAME (gnu_type)) = 0;
TYPE_ALIGN (gnu_type) = 0;
TYPE_PACKED (gnu_type) = packed != 0 || has_rep;
if (! definition)
{
defer_incomplete_level++;
this_deferred = 1;
set_lineno (gnat_entity, 0);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
}
if (has_rep && Known_Esize (gnat_entity))
TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
if (Known_Alignment (gnat_entity))
TYPE_ALIGN (gnu_type)
= validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
else if (Is_Atomic (gnat_entity))
TYPE_ALIGN (gnu_type) = BITS_PER_WORD;
if (Present (Parent_Subtype (gnat_entity)))
{
tree gnu_parent;
gnu_get_parent = build (COMPONENT_REF, void_type_node,
build (PLACEHOLDER_EXPR, gnu_type),
build_decl (FIELD_DECL, NULL_TREE,
NULL_TREE));
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Girder_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Girder_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree
(gnat_field,
build (COMPONENT_REF,
get_unpadded_type (Etype (gnat_field)),
gnu_get_parent,
gnat_to_gnu_entity (Corresponding_Discriminant
(gnat_field),
NULL_TREE, 0)),
1);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
gnu_field_list
= create_field_decl (get_identifier
(Get_Name_String (Name_uParent)),
gnu_parent, gnu_type, 0,
has_rep ? TYPE_SIZE (gnu_parent) : 0,
has_rep ? bitsize_zero_node : 0, 1);
DECL_INTERNAL_P (gnu_field_list) = 1;
TREE_TYPE (gnu_get_parent) = gnu_parent;
TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
}
if (! Is_Unchecked_Union (gnat_entity)
&& Has_Discriminants (gnat_entity))
for (gnat_field = First_Girder_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Girder_Discriminant (gnat_field))
{
if (Present (Parent_Subtype (gnat_entity))
&& Present (Corresponding_Discriminant (gnat_field)))
continue;
gnu_field
= gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
save_gnu_tree (gnat_field,
build (COMPONENT_REF, TREE_TYPE (gnu_field),
build (PLACEHOLDER_EXPR,
DECL_CONTEXT (gnu_field)),
gnu_field),
1);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
TYPE_FIELDS (gnu_type) = gnu_field_list;
components_to_record (gnu_type, Component_List (record_definition),
gnu_field_list, packed, definition, 0,
0, all_rep);
TYPE_DUMMY_P (gnu_type) = 0;
TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity);
TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
if (! Is_Unchecked_Union (gnat_entity)
&& Has_Discriminants (gnat_entity))
for (gnat_field = First_Girder_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Girder_Discriminant (gnat_field))
{
if (Present (Parent_Subtype (gnat_entity))
&& Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree (gnat_field, NULL_TREE, 0);
else
{
gnu_field = get_gnu_tree (gnat_field);
save_gnu_tree (gnat_field, NULL_TREE, 0);
save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1), 0);
}
}
if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
TYPE_MODE (gnu_type) = BLKmode;
annotate_rep (gnat_entity, gnu_type);
for (gnat_temp = First_Entity (gnat_entity);
Present (gnat_temp); gnat_temp = Next_Entity (gnat_temp))
if ((Ekind (gnat_temp) == E_Component
|| Ekind (gnat_temp) == E_Discriminant)
&& Is_Itype (Etype (gnat_temp))
&& ! present_gnu_tree (gnat_temp))
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
}
break;
case E_Class_Wide_Subtype:
if (Present (Equivalent_Type (gnat_entity)))
{
gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
maybe_present = 1;
break;
}
case E_Record_Subtype:
if (Present (Cloned_Subtype (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
NULL_TREE, 0);
maybe_present = 1;
}
else
{
Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
tree gnu_base_type;
tree gnu_orig_type;
if (! definition)
defer_incomplete_level++, this_deferred = 1;
gnu_type = gnu_orig_type = gnu_base_type
= gnat_to_gnu_type (gnat_base_type);
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type))
gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_type));
if (present_gnu_tree (gnat_entity))
{
maybe_present = 1;
break;
}
if (IN (Ekind (gnat_base_type), Record_Kind)
&& ! Is_For_Access_Subtype (gnat_entity)
&& ! Is_Unchecked_Union (gnat_base_type)
&& Is_Constrained (gnat_entity)
&& Girder_Constraint (gnat_entity) != No_Elist
&& Present (Discriminant_Constraint (gnat_entity)))
{
Entity_Id gnat_field;
Entity_Id gnat_root_type;
tree gnu_field_list = 0;
tree gnu_pos_list
= compute_field_positions (gnu_orig_type, NULL_TREE,
size_zero_node, bitsize_zero_node);
tree gnu_subst_list
= substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
definition);
tree gnu_temp;
for (gnat_root_type = gnat_base_type;
Underlying_Type (Etype (gnat_root_type)) != gnat_root_type;
gnat_root_type = Underlying_Type (Etype (gnat_root_type)))
{
gnu_pos_list
= compute_field_positions
(gnat_to_gnu_type (Etype (gnat_root_type)),
gnu_pos_list, size_zero_node, bitsize_zero_node);
if (Present (Parent_Subtype (gnat_root_type)))
gnu_subst_list
= substitution_list (Parent_Subtype (gnat_root_type),
Empty, gnu_subst_list, definition);
}
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
for (gnat_field = First_Entity (gnat_entity);
Present (gnat_field); gnat_field = Next_Entity (gnat_field))
if (Ekind (gnat_field) == E_Component
|| Ekind (gnat_field) == E_Discriminant)
{
tree gnu_old_field
= gnat_to_gnu_entity
(Original_Record_Component (gnat_field), NULL_TREE, 0);
tree gnu_offset
= TREE_VALUE (purpose_member (gnu_old_field,
gnu_pos_list));
tree gnu_pos = TREE_PURPOSE (gnu_offset);
tree gnu_bitpos = TREE_VALUE (gnu_offset);
tree gnu_field_type
= gnat_to_gnu_type (Etype (gnat_field));
tree gnu_size = TYPE_SIZE (gnu_field_type);
tree gnu_new_pos = 0;
tree gnu_field;
if (Present (Component_Clause
(Original_Record_Component (gnat_field))))
{
gnu_size = DECL_SIZE (gnu_old_field);
gnu_field_type = TREE_TYPE (gnu_old_field);
}
else if (DECL_BIT_FIELD (gnu_old_field))
{
gnu_size = DECL_SIZE (gnu_old_field);
if (TYPE_MODE (gnu_field_type) == BLKmode
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
&& host_integerp (TYPE_SIZE (gnu_field_type), 1))
gnu_field_type = make_packable_type (gnu_field_type);
}
if (TREE_CODE (gnu_pos) != INTEGER_CST
&& contains_placeholder_p (gnu_pos))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
gnu_pos = substitute_in_expr (gnu_pos,
TREE_PURPOSE (gnu_temp),
TREE_VALUE (gnu_temp));
if (TREE_CONSTANT (gnu_pos))
gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
gnu_field
= create_field_decl
(DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
0, gnu_size, gnu_new_pos,
! DECL_NONADDRESSABLE_P (gnu_old_field));
if (! TREE_CONSTANT (gnu_pos))
{
normalize_offset (&gnu_pos, &gnu_bitpos,
DECL_OFFSET_ALIGN (gnu_old_field));
DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
SET_DECL_OFFSET_ALIGN
(gnu_field, DECL_OFFSET_ALIGN (gnu_old_field));
DECL_SIZE (gnu_field) = gnu_size;
DECL_SIZE_UNIT (gnu_field)
= convert (sizetype,
size_binop (CEIL_DIV_EXPR, gnu_size,
bitsize_unit_node));
layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
}
DECL_INTERNAL_P (gnu_field)
= DECL_INTERNAL_P (gnu_old_field);
DECL_ORIGINAL_FIELD (gnu_field)
= DECL_ORIGINAL_FIELD (gnu_old_field) != 0
? DECL_ORIGINAL_FIELD (gnu_old_field) : gnu_old_field;
DECL_DISCRIMINANT_NUMBER (gnu_field)
= DECL_DISCRIMINANT_NUMBER (gnu_old_field);
TREE_THIS_VOLATILE (gnu_field)
= TREE_THIS_VOLATILE (gnu_old_field);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
save_gnu_tree (gnat_field, gnu_field, 0);
}
finish_record_type (gnu_type, nreverse (gnu_field_list), 1, 0);
TYPE_ALIAS_SET (gnu_type) = get_alias_set (gnu_base_type);
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
TYPE_ADA_SIZE (gnu_type) = TYPE_ADA_SIZE (gnu_base_type);
if (TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
TYPE_SIZE (gnu_type)
= substitute_in_expr (TYPE_SIZE (gnu_type),
TREE_PURPOSE (gnu_temp),
TREE_VALUE (gnu_temp));
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE_UNIT (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
TYPE_SIZE_UNIT (gnu_type)
= substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
TREE_PURPOSE (gnu_temp),
TREE_VALUE (gnu_temp));
if (TYPE_ADA_SIZE (gnu_type) != 0
&& TREE_CODE (TYPE_ADA_SIZE (gnu_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_ADA_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
TYPE_ADA_SIZE (gnu_type)
= substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
TREE_PURPOSE (gnu_temp),
TREE_VALUE (gnu_temp));
compute_record_mode (gnu_type);
annotate_rep (gnat_entity, gnu_type);
}
if (gnu_type != gnu_orig_type)
{
if (debug_info_p)
{
tree gnu_subtype_marker = make_node (RECORD_TYPE);
tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
gnu_orig_name = DECL_NAME (gnu_orig_name);
TYPE_NAME (gnu_subtype_marker)
= create_concat_name (gnat_entity, "XVS");
finish_record_type (gnu_subtype_marker,
create_field_decl (gnu_orig_name,
integer_type_node,
gnu_subtype_marker,
0, NULL_TREE,
NULL_TREE, 0),
0, 0);
}
TYPE_VOLATILE (gnu_type) = Is_Volatile (gnat_entity);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, TYPE_NAME (gnu_type),
gnu_type));
DECL_ARTIFICIAL (TYPE_STUB_DECL (gnu_type)) = 1;
DECL_IGNORED_P (TYPE_STUB_DECL (gnu_type)) = ! debug_info_p;
rest_of_type_compilation (gnu_type, global_bindings_p ());
}
else
for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
if ((Ekind (gnat_temp) == E_Discriminant
&& ! Is_Unchecked_Union (gnat_base_type))
|| Ekind (gnat_temp) == E_Component)
save_gnu_tree (gnat_temp,
get_gnu_tree
(Original_Record_Component (gnat_temp)), 0);
}
break;
case E_Access_Subprogram_Type:
if (! definition && defer_incomplete_level != 0)
{
struct incomplete *p
= (struct incomplete *) xmalloc (sizeof (struct incomplete));
gnu_type
= build_pointer_type
(make_dummy_type (Directly_Designated_Type (gnat_entity)));
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
p->old_type = TREE_TYPE (gnu_type);
p->full_type = Directly_Designated_Type (gnat_entity);
p->next = defer_incomplete_list;
defer_incomplete_list = p;
break;
}
case E_Allocator_Type:
case E_Access_Type:
case E_Access_Attribute_Type:
case E_Anonymous_Access_Type:
case E_General_Access_Type:
{
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
Entity_Id gnat_desig_full
= ((IN (Ekind (Etype (gnat_desig_type)),
Incomplete_Or_Private_Kind))
? Full_View (gnat_desig_type) : 0);
int in_main_unit
= (Present (gnat_desig_full)
? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type));
int got_fat_p = 0;
int made_dummy = 0;
tree gnu_desig_type = 0;
if (No (gnat_desig_full)
&& (Ekind (gnat_desig_type) == E_Class_Wide_Type
|| (Ekind (gnat_desig_type) == E_Class_Wide_Subtype
&& Present (Equivalent_Type (gnat_desig_type)))))
{
if (Present (Equivalent_Type (gnat_desig_type)))
{
gnat_desig_full = Equivalent_Type (gnat_desig_type);
if (IN (Ekind (gnat_desig_full), Incomplete_Or_Private_Kind))
gnat_desig_full = Full_View (gnat_desig_full);
}
else if (IN (Ekind (Root_Type (gnat_desig_type)),
Incomplete_Or_Private_Kind))
gnat_desig_full = Full_View (Root_Type (gnat_desig_type));
}
if (Present (gnat_desig_full) && Is_Concurrent_Type (gnat_desig_full))
gnat_desig_full = Corresponding_Record_Type (gnat_desig_full);
if (Ekind (gnat_desig_type) == E_Array_Subtype
&& ! Is_Constrained (gnat_desig_type))
gnat_desig_type = Etype (gnat_desig_type);
if (Present (gnat_desig_full)
&& Ekind (gnat_desig_full) == E_Array_Subtype
&& ! Is_Constrained (gnat_desig_full))
gnat_desig_full = Etype (gnat_desig_full);
if ((Present (gnat_desig_full)
&& Is_Array_Type (gnat_desig_full)
&& ! Is_Constrained (gnat_desig_full))
|| (present_gnu_tree (gnat_desig_type)
&& TYPE_IS_DUMMY_P (TREE_TYPE
(get_gnu_tree (gnat_desig_type)))
&& Is_Array_Type (gnat_desig_type)
&& ! Is_Constrained (gnat_desig_type))
|| (present_gnu_tree (gnat_desig_type)
&& (TREE_CODE (TREE_TYPE (get_gnu_tree (gnat_desig_type)))
== UNCONSTRAINED_ARRAY_TYPE)
&& (TYPE_POINTER_TO (TREE_TYPE
(get_gnu_tree (gnat_desig_type)))
== 0))
|| (No (gnat_desig_full) && ! in_main_unit
&& defer_incomplete_level != 0
&& ! present_gnu_tree (gnat_desig_type)
&& Is_Array_Type (gnat_desig_type)
&& ! Is_Constrained (gnat_desig_type)))
{
tree gnu_old
= (present_gnu_tree (gnat_desig_type)
? gnat_to_gnu_type (gnat_desig_type)
: make_dummy_type (gnat_desig_type));
tree fields;
got_fat_p = made_dummy = 1;
gnu_type = TYPE_POINTER_TO (gnu_old);
if (gnu_type == 0)
{
gnu_type = make_node (RECORD_TYPE);
TYPE_UNCONSTRAINED_ARRAY (gnu_type) = gnu_old;
TYPE_POINTER_TO (gnu_old) = gnu_type;
set_lineno (gnat_entity, 0);
fields
= chainon (chainon (NULL_TREE,
create_field_decl
(get_identifier ("P_ARRAY"),
ptr_void_type_node, gnu_type,
0, 0, 0, 0)),
create_field_decl (get_identifier ("P_BOUNDS"),
ptr_void_type_node,
gnu_type, 0, 0, 0, 0));
TYPE_ALIGN (gnu_type)
= MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
finish_record_type (gnu_type, fields, 0, 1);
TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
= concat_id_with_name (get_entity_name (gnat_desig_type),
"XUT");
TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
}
}
else if (Present (gnat_desig_full)
&& present_gnu_tree (gnat_desig_full))
gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
else if (! in_main_unit
&& ! present_gnu_tree (gnat_desig_type)
&& Present (gnat_desig_full)
&& ! present_gnu_tree (gnat_desig_full)
&& Is_Record_Type (gnat_desig_full))
{
gnu_desig_type = make_dummy_type (gnat_desig_type);
made_dummy = 1;
}
else if ((! in_main_unit || imported_p) && defer_incomplete_level != 0
&& ! present_gnu_tree (gnat_desig_type)
&& ((Is_Record_Type (gnat_desig_type)
|| Is_Array_Type (gnat_desig_type))
|| (Present (gnat_desig_full)
&& (Is_Record_Type (gnat_desig_full)
|| Is_Array_Type (gnat_desig_full)))))
{
gnu_desig_type = make_dummy_type (gnat_desig_type);
made_dummy = 1;
}
else if (gnat_desig_type == gnat_entity)
{
gnu_type = build_pointer_type (make_node (VOID_TYPE));
TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type) = gnu_type;
}
else
gnu_desig_type = gnat_to_gnu_type (gnat_desig_type);
if (present_gnu_tree (gnat_entity))
{
maybe_present = 1;
break;
}
if (gnu_type == 0 && gnu_desig_type != 0)
{
if (Is_Access_Constant (gnat_entity)
&& TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
gnu_desig_type
= build_qualified_type (gnu_desig_type,
(TYPE_QUALS (gnu_desig_type)
| TYPE_QUAL_CONST));
gnu_type = build_pointer_type (gnu_desig_type);
}
if (! in_main_unit && made_dummy)
{
tree gnu_old_type
= TYPE_FAT_POINTER_P (gnu_type)
? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
if (esize == POINTER_SIZE
&& (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
gnu_type
= build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
(TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
save_gnu_tree (gnat_entity, gnu_decl, 0);
this_made_decl = saved = 1;
if (defer_incomplete_level == 0)
update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_type),
gnat_to_gnu_type (gnat_desig_type));
else
{
struct incomplete *p
= (struct incomplete *) xmalloc (sizeof (struct incomplete));
p->old_type = gnu_old_type;
p->full_type = gnat_desig_type;
p->next = defer_incomplete_list;
defer_incomplete_list = p;
}
}
}
break;
case E_Access_Protected_Subprogram_Type:
if (type_annotate_only && No (Equivalent_Type (gnat_entity)))
gnu_type = build_pointer_type (void_type_node);
else
gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
&& ! Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
break;
case E_Access_Subtype:
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& ! present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& Is_Frozen (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
{
if (! definition && defer_incomplete_level != 0)
{
struct incomplete *p
= (struct incomplete *) xmalloc (sizeof (struct incomplete));
tree gnu_ptr_type
= build_pointer_type
(make_dummy_type (Directly_Designated_Type (gnat_entity)));
p->old_type = TREE_TYPE (gnu_ptr_type);
p->full_type = Directly_Designated_Type (gnat_entity);
p->next = defer_incomplete_list;
defer_incomplete_list = p;
}
else
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
}
maybe_present = 1;
break;
case E_Subprogram_Type:
case E_Function:
case E_Procedure:
{
tree gnu_param_list = NULL_TREE;
tree gnu_return_type = void_type_node;
tree gnu_field_list = NULL_TREE;
tree gnu_return_list = NULL_TREE;
Entity_Id gnat_param;
int inline_flag = Is_Inlined (gnat_entity);
int public_flag = Is_Public (gnat_entity);
int extern_flag
= (Is_Public (gnat_entity) && !definition) || imported_p;
int pure_flag = Is_Pure (gnat_entity);
int volatile_flag = No_Return (gnat_entity);
int returns_by_ref = 0;
int returns_unconstrained = 0;
tree gnu_ext_name = NULL_TREE;
int has_copy_in_out = 0;
int parmnum;
if (kind == E_Subprogram_Type && ! definition)
defer_incomplete_level++, this_deferred = 1;
if (Present (Alias (gnat_entity)))
{
if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
gnu_expr, 0);
for (gnat_temp = First_Formal (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp)))
gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
break;
}
if (kind == E_Function || kind == E_Subprogram_Type)
gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
if (Returns_By_Ref (gnat_entity))
{
returns_by_ref = 1;
gnu_return_type = build_pointer_type (gnu_return_type);
}
else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
{
gnu_return_type = TREE_TYPE (gnu_return_type);
returns_unconstrained = 1;
}
else if (Requires_Transient_Scope (Etype (gnat_entity)))
{
gnu_return_type = build_pointer_type (gnu_return_type);
returns_unconstrained = 1;
}
else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_return_type)
&& (! default_pass_by_ref (TREE_TYPE
(TYPE_FIELDS (gnu_return_type)))
|| Has_Foreign_Convention (gnat_entity)))
gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
for (gnat_param = First_Formal (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
{
tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
tree gnu_param, gnu_field;
int by_ref_p = 0;
int by_descr_p = 0;
int by_component_ptr_p = 0;
int copy_in_copy_out_flag = 0;
int req_by_copy = 0, req_by_ref = 0;
if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
req_by_copy = 1;
else if (Mechanism (gnat_param) == Default)
;
else if (Mechanism (gnat_param) == By_Copy)
req_by_copy = 1;
else if (Mechanism (gnat_param) == By_Reference)
req_by_ref = 1;
else if (Mechanism (gnat_param) <= By_Descriptor)
by_descr_p = 1;
else if (Mechanism (gnat_param) > 0)
{
if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
|| TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
|| 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
Mechanism (gnat_param)))
req_by_ref = 1;
else
req_by_copy = 1;
}
else
post_error ("unsupported mechanism for&", gnat_param);
if (TREE_CODE (gnu_param_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_param_type)
&& (req_by_ref || Has_Foreign_Convention (gnat_entity)
|| ! must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
(gnu_param_type)))))
gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
if (Ekind (gnat_param) == E_In_Parameter
&& TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
&& ! (TYPE_SIZE (gnu_param_type) != 0
&& TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
&& contains_placeholder_p (TYPE_SIZE (gnu_param_type))))
gnu_param_type
= build_qualified_type (gnu_param_type,
(TYPE_QUALS (gnu_param_type)
| TYPE_QUAL_CONST));
if (Has_Foreign_Convention (gnat_entity)
&& TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS
(TREE_TYPE (gnu_param_type))));
if (by_descr_p)
gnu_param_type
= build_pointer_type
(build_vms_descriptor (gnu_param_type,
Mechanism (gnat_param),
gnat_entity));
else if (Has_Foreign_Convention (gnat_entity)
&& ! req_by_copy
&& TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{
while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
gnu_param_type = TREE_TYPE (gnu_param_type);
by_component_ptr_p = 1;
gnu_param_type = TREE_TYPE (gnu_param_type);
if (Ekind (gnat_param) == E_In_Parameter)
gnu_param_type
= build_qualified_type (gnu_param_type,
(TYPE_QUALS (gnu_param_type)
| TYPE_QUAL_CONST));
gnu_param_type = build_pointer_type (gnu_param_type);
}
else if (Has_Foreign_Convention (gnat_entity)
&& TYPE_FAT_POINTER_P (gnu_param_type))
gnu_param_type
= make_type_from_size (gnu_param_type,
size_int (POINTER_SIZE), 0);
else if (must_pass_by_ref (gnu_param_type) || req_by_ref
|| (! req_by_copy
&& ((Has_Foreign_Convention (gnat_entity)
&& (Ekind (gnat_param) != E_In_Parameter
|| AGGREGATE_TYPE_P (gnu_param_type)))
|| (((Convention (gnat_entity)
== Convention_Fortran)
|| (Convention (gnat_entity)
== Convention_COBOL))
&& (INTEGRAL_TYPE_P (gnu_param_type)
|| FLOAT_TYPE_P (gnu_param_type)))
|| (! Has_Foreign_Convention (gnat_entity)
&& default_pass_by_ref (gnu_param_type)))))
{
gnu_param_type = build_reference_type (gnu_param_type);
by_ref_p = 1;
}
else if (Ekind (gnat_param) != E_In_Parameter)
copy_in_copy_out_flag = 1;
if (req_by_copy && (by_ref_p || by_component_ptr_p))
post_error ("?cannot pass & by copy", gnat_param);
if (Ekind (gnat_param) == E_Out_Parameter && ! by_ref_p
&& ((Is_Valued_Procedure (gnat_entity) && parmnum == 0)
|| (! by_descr_p
&& ! POINTER_TYPE_P (gnu_param_type)
&& ! AGGREGATE_TYPE_P (gnu_param_type))))
gnu_param = 0;
else
{
set_lineno (gnat_param, 0);
gnu_param
= create_param_decl
(gnu_param_name, gnu_param_type,
by_ref_p || by_component_ptr_p
|| Ekind (gnat_param) == E_In_Parameter);
DECL_BY_REF_P (gnu_param) = by_ref_p;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr_p;
DECL_BY_DESCRIPTOR_P (gnu_param) = by_descr_p;
DECL_POINTS_TO_READONLY_P (gnu_param)
= (Ekind (gnat_param) == E_In_Parameter
&& (by_ref_p || by_component_ptr_p));
save_gnu_tree (gnat_param, gnu_param, 0);
gnu_param_list = chainon (gnu_param, gnu_param_list);
if (POINTER_TYPE_P (gnu_param_type)
|| TYPE_FAT_POINTER_P (gnu_param_type))
pure_flag = 0;
}
if (copy_in_copy_out_flag)
{
if (! has_copy_in_out)
{
if (TREE_CODE (gnu_return_type) != VOID_TYPE)
gigi_abort (111);
gnu_return_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
has_copy_in_out = 1;
}
set_lineno (gnat_param, 0);
gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
gnu_return_type, 0, 0, 0, 0);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
gnu_return_list = tree_cons (gnu_field, gnu_param,
gnu_return_list);
}
}
if (gnu_field_list != 0
&& Convention (gnat_entity) != Convention_Stubbed)
finish_record_type (gnu_return_type, nreverse (gnu_field_list),
0, 0);
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
if (Convention (gnat_entity) == Convention_Stdcall)
{
struct attrib *attr
= (struct attrib *) xmalloc (sizeof (struct attrib));
attr->next = attr_list;
attr->type = ATTR_MACHINE_ATTRIBUTE;
attr->name = get_identifier ("stdcall");
attr->arg = NULL_TREE;
attr->error_point = gnat_entity;
attr_list = attr;
}
gnu_param_list = nreverse (gnu_param_list);
gnu_return_list = nreverse (gnu_return_list);
gnu_type
= create_subprog_type (gnu_return_type, gnu_param_list,
gnu_return_list, returns_unconstrained,
returns_by_ref,
Function_Returns_With_DSP (gnat_entity));
if (! global_bindings_p ())
pure_flag = 0;
gnu_type
= build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_CONST * pure_flag)
| (TYPE_QUAL_VOLATILE * volatile_flag)));
if (Present (Interface_Name (gnat_entity))
|| ! (Is_Imported (gnat_entity) || Is_Exported (gnat_entity)))
gnu_ext_name = create_concat_name (gnat_entity, 0);
set_lineno (gnat_entity, 0);
if (Present (Address_Clause (gnat_entity)))
{
tree gnu_address = 0;
if (definition)
gnu_address
= (present_gnu_tree (gnat_entity)
? get_gnu_tree (gnat_entity)
: gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
save_gnu_tree (gnat_entity, NULL_TREE, 0);
gnu_type = build_reference_type (gnu_type);
if (gnu_address != 0)
gnu_address = convert (gnu_type, gnu_address);
gnu_decl
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_address, 0, Is_Public (gnat_entity),
extern_flag, 0, 0);
DECL_BY_REF_P (gnu_decl) = 1;
}
else if (kind == E_Subprogram_Type)
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
else
{
gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
gnu_type, gnu_param_list,
inline_flag, public_flag,
extern_flag, attr_list);
DECL_STUBBED_P (gnu_decl)
= Convention (gnat_entity) == Convention_Stubbed;
}
}
break;
case E_Incomplete_Type:
case E_Private_Type:
case E_Limited_Private_Type:
case E_Record_Type_With_Private:
case E_Private_Subtype:
case E_Limited_Private_Subtype:
case E_Record_Subtype_With_Private:
if (No (Full_View (gnat_entity)))
{
if (kind == E_Incomplete_Type)
gnu_type = make_dummy_type (gnat_entity);
else if (Present (Underlying_Full_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
NULL_TREE, 0);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
NULL_TREE, 0);
maybe_present = 1;
}
break;
}
else if (! definition
|| (Is_Itype (Full_View (gnat_entity))
&& No (Freeze_Node (gnat_entity)))
|| (Is_Itype (gnat_entity)
&& No (Freeze_Node (Full_View (gnat_entity)))))
{
gnu_decl = gnat_to_gnu_entity (Full_View (gnat_entity),
NULL_TREE, 0);
maybe_present = 1;
break;
}
gnu_type = make_dummy_type (gnat_entity);
set_lineno (gnat_entity, 0);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
save_gnu_tree (Full_View (gnat_entity), gnu_decl, 0);
break;
case E_Class_Wide_Type:
if (Present (Equivalent_Type (gnat_entity)))
gnu_type = gnat_to_gnu_type (Equivalent_Type (gnat_entity));
else
gnu_type = gnat_to_gnu_type (Root_Type (gnat_entity));
maybe_present = 1;
break;
case E_Task_Type:
case E_Task_Subtype:
case E_Protected_Type:
case E_Protected_Subtype:
if (type_annotate_only && No (Corresponding_Record_Type (gnat_entity)))
gnu_type = void_type_node;
else
gnu_type = gnat_to_gnu_type (Corresponding_Record_Type (gnat_entity));
maybe_present = 1;
break;
case E_Label:
gnu_decl = create_label_decl (gnu_entity_id);
break;
case E_Block:
case E_Loop:
gnu_decl = error_mark_node;
saved = 1;
break;
default:
gigi_abort (113);
}
if (maybe_present && present_gnu_tree (gnat_entity))
{
gnu_decl = get_gnu_tree (gnat_entity);
saved = 1;
}
if ((gnu_decl == 0 || this_made_decl) && IN (kind, Type_Kind))
{
if (Is_Tagged_Type (gnat_entity))
TYPE_ALIGN_OK_P (gnu_type) = 1;
if (AGGREGATE_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
TYPE_BY_REFERENCE_P (gnu_type) = 1;
if (gnu_size == 0 && kind != E_String_Literal_Subtype)
gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
TYPE_DECL, 0, Has_Size_Clause (gnat_entity));
if (gnu_size != 0)
{
gnu_type
= make_type_from_size (gnu_type, gnu_size,
Has_Biased_Representation (gnat_entity));
if (operand_equal_p (TYPE_SIZE (gnu_type), gnu_size, 0)
&& operand_equal_p (rm_size (gnu_type), gnu_size, 0))
gnu_size = 0;
}
if (align != 0 || TREE_CODE (gnu_type) == UNCONSTRAINED_ARRAY_TYPE)
;
else if (Known_Alignment (gnat_entity))
align = validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (gnu_type));
else if (Is_Atomic (gnat_entity) && gnu_size == 0
&& host_integerp (TYPE_SIZE (gnu_type), 1)
&& integer_pow2p (TYPE_SIZE (gnu_type)))
align = MIN (BIGGEST_ALIGNMENT,
tree_low_cst (TYPE_SIZE (gnu_type), 1));
else if (Is_Atomic (gnat_entity) && gnu_size != 0
&& host_integerp (gnu_size, 1)
&& integer_pow2p (gnu_size))
align = MIN (BIGGEST_ALIGNMENT, tree_low_cst (gnu_size, 1));
gnu_type = maybe_pad_type (gnu_type, gnu_size, align,
gnat_entity, "PAD", 1, definition, 0);
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_type))
{
gnu_entity_id = TYPE_NAME (gnu_type);
if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
gnu_entity_id = DECL_NAME (gnu_entity_id);
}
set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
if (global_bindings_p ()
&& TYPE_SIZE (gnu_type) != 0
&& TREE_CODE (TYPE_SIZE (gnu_type)) != INTEGER_CST
&& ! contains_placeholder_p (TYPE_SIZE (gnu_type)))
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& operand_equal_p (TYPE_ADA_SIZE (gnu_type),
TYPE_SIZE (gnu_type), 0))
TYPE_ADA_SIZE (gnu_type) = TYPE_SIZE (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_type),
get_identifier ("SIZE"),
definition, 0);
else if (TREE_CODE (gnu_type) == RECORD_TYPE)
{
TYPE_ADA_SIZE (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_ADA_SIZE (gnu_type),
get_identifier ("RM_SIZE"),
definition, 0);
TYPE_SIZE (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_type),
get_identifier ("SIZE"),
definition, 0);
TYPE_SIZE_UNIT (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE_UNIT (gnu_type),
get_identifier ("SIZE_UNIT"),
definition, 0);
}
else
{
TYPE_SIZE (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_type),
get_identifier ("SIZE"),
definition, 0);
TYPE_SIZE_UNIT (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE_UNIT (gnu_type),
get_identifier ("SIZE_UNIT"),
definition, 0);
}
}
if (IN (kind, Record_Kind))
for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
{
tree gnu_field = get_gnu_tree (gnat_temp);
if (TREE_CODE (DECL_FIELD_OFFSET (gnu_field)) != INTEGER_CST
&& ! contains_placeholder_p (DECL_FIELD_OFFSET (gnu_field)))
DECL_FIELD_OFFSET (gnu_field)
= elaborate_expression_1 (gnat_temp, gnat_temp,
DECL_FIELD_OFFSET (gnu_field),
get_identifier ("OFFSET"),
definition, 0);
}
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
* Is_Volatile (gnat_entity))));
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, 0);
if (Known_Alignment (gnat_entity))
TYPE_USER_ALIGN (gnu_type) = 1;
if (gnu_decl == 0)
{
set_lineno (gnat_entity, 0);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
! Comes_From_Source (gnat_entity),
debug_info_p);
}
else
TREE_TYPE (gnu_decl) = gnu_type;
}
if (IN (kind, Type_Kind) && ! TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
{
gnu_type = TREE_TYPE (gnu_decl);
if (Unknown_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type) != 0)
{
tree gnu_size = TYPE_SIZE (gnu_type);
if (contains_placeholder_p (gnu_size))
gnu_size = max_size (gnu_size, 1);
Set_Esize (gnat_entity, annotate_value (gnu_size));
}
if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type) != 0)
Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
}
if (! Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
DECL_ARTIFICIAL (gnu_decl) = 1;
if (! debug_info_p && DECL_P (gnu_decl)
&& TREE_CODE (gnu_decl) != FUNCTION_DECL)
DECL_IGNORED_P (gnu_decl) = 1;
if (TREE_CODE (gnu_decl) == VAR_DECL)
adjust_decl_rtl (gnu_decl);
if (! saved)
save_gnu_tree (gnat_entity, gnu_decl, 0);
if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
|| (kind == E_Floating_Point_Type && ! Vax_Float (gnat_entity)))
{
tree gnu_scalar_type = gnu_type;
if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
&& TYPE_IS_PADDING_P (gnu_scalar_type))
gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
if (longest_float_type_node == 0 && kind == E_Floating_Point_Type)
longest_float_type_node = gnu_type;
TYPE_MIN_VALUE (gnu_scalar_type)
= gnat_to_gnu (Type_Low_Bound (gnat_entity));
TYPE_MAX_VALUE (gnu_scalar_type)
= gnat_to_gnu (Type_High_Bound (gnat_entity));
if (kind == E_Enumeration_Type)
{
TYPE_STUB_DECL (gnu_scalar_type) = gnu_decl;
DECL_ARTIFICIAL (gnu_decl) = 1;
rest_of_type_compilation (gnu_scalar_type, global_bindings_p ());
}
}
if (this_deferred && --defer_incomplete_level == 0
&& defer_incomplete_list != 0)
{
struct incomplete *incp = defer_incomplete_list;
struct incomplete *next;
defer_incomplete_list = 0;
for (; incp; incp = next)
{
next = incp->next;
if (incp->old_type != 0)
update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
gnat_to_gnu_type (incp->full_type));
free (incp);
}
}
else if (! definition)
{
struct incomplete *incp;
for (incp = defer_incomplete_list; incp; incp = incp->next)
if (incp->old_type != 0 && incp->full_type == gnat_entity)
{
update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
TREE_TYPE (gnu_decl));
incp->old_type = 0;
}
}
if (this_global)
force_global--;
if (Is_Packed_Array_Type (gnat_entity)
&& Is_Itype (Associated_Node_For_Itype (gnat_entity))
&& No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
&& ! present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
return gnu_decl;
}
void
elaborate_entity (gnat_entity)
Entity_Id gnat_entity;
{
switch (Ekind (gnat_entity))
{
case E_Signed_Integer_Subtype:
case E_Modular_Integer_Subtype:
case E_Enumeration_Subtype:
case E_Ordinary_Fixed_Point_Subtype:
case E_Decimal_Fixed_Point_Subtype:
case E_Floating_Point_Subtype:
{
Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
Node_Id gnat_hb = Type_High_Bound (gnat_entity);
if (! Raises_Constraint_Error (gnat_lb))
elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
1, 0, Needs_Debug_Info (gnat_entity));
if (! Raises_Constraint_Error (gnat_hb))
elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
1, 0, Needs_Debug_Info (gnat_entity));
break;
}
case E_Record_Type:
{
Node_Id full_definition = Declaration_Node (gnat_entity);
Node_Id record_definition = Type_Definition (full_definition);
if (Nkind (record_definition) == N_Derived_Type_Definition)
record_definition = Record_Extension_Part (record_definition);
}
break;
case E_Record_Subtype:
case E_Private_Subtype:
case E_Limited_Private_Subtype:
case E_Record_Subtype_With_Private:
if (Is_Constrained (gnat_entity)
&& Has_Discriminants (Base_Type (gnat_entity))
&& Present (Discriminant_Constraint (gnat_entity)))
{
Node_Id gnat_discriminant_expr;
Entity_Id gnat_field;
for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
gnat_discriminant_expr
= First_Elmt (Discriminant_Constraint (gnat_entity));
Present (gnat_field);
gnat_field = Next_Discriminant (gnat_field),
gnat_discriminant_expr = Next_Elmt (gnat_discriminant_expr))
if (! Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
elaborate_expression (Node (gnat_discriminant_expr),
gnat_entity,
get_entity_name (gnat_field), 1, 0, 0);
}
break;
}
}
void
mark_out_of_scope (gnat_entity)
Entity_Id gnat_entity;
{
Entity_Id gnat_sub_entity;
unsigned int kind = Ekind (gnat_entity);
if (IN (kind, Class_Wide_Kind) || IN (kind, Concurrent_Kind)
|| IN (kind, Private_Kind)
|| kind == E_Block || kind == E_Entry || kind == E_Entry_Family
|| kind == E_Function || kind == E_Generic_Function
|| kind == E_Generic_Package || kind == E_Generic_Procedure
|| kind == E_Loop || kind == E_Operator || kind == E_Package
|| kind == E_Package_Body || kind == E_Procedure
|| kind == E_Record_Type || kind == E_Record_Subtype
|| kind == E_Subprogram_Body || kind == E_Subprogram_Type)
for (gnat_sub_entity = First_Entity (gnat_entity);
Present (gnat_sub_entity);
gnat_sub_entity = Next_Entity (gnat_sub_entity))
if (Scope (gnat_sub_entity) == gnat_entity
&& gnat_sub_entity != gnat_entity)
mark_out_of_scope (gnat_sub_entity);
if (present_gnu_tree (gnat_entity) && ! Is_Statically_Allocated (gnat_entity)
&& kind != E_Procedure && kind != E_Function && ! IN (kind, Formal_Kind))
{
save_gnu_tree (gnat_entity, NULL_TREE, 1);
save_gnu_tree (gnat_entity, error_mark_node, 1);
}
}
static tree
substitution_list (gnat_subtype, gnat_type, gnu_list, definition)
Entity_Id gnat_subtype;
Entity_Id gnat_type;
tree gnu_list;
int definition;
{
Entity_Id gnat_discrim;
Node_Id gnat_value;
if (No (gnat_type))
gnat_type = Implementation_Base_Type (gnat_subtype);
if (Has_Discriminants (gnat_type))
for (gnat_discrim = First_Girder_Discriminant (gnat_type),
gnat_value = First_Elmt (Girder_Constraint (gnat_subtype));
Present (gnat_discrim);
gnat_discrim = Next_Girder_Discriminant (gnat_discrim),
gnat_value = Next_Elmt (gnat_value))
if (! Is_Access_Type (Etype (Node (gnat_value))))
gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0),
elaborate_expression
(Node (gnat_value), gnat_subtype,
get_entity_name (gnat_discrim), definition,
1, 0),
gnu_list);
return gnu_list;
}
static tree *dummy_node_table;
void
init_dummy_type ()
{
Node_Id gnat_node;
dummy_node_table = (tree *) xmalloc (max_gnat_nodes * sizeof (tree));
ggc_add_tree_root (dummy_node_table, max_gnat_nodes);
for (gnat_node = 0; gnat_node < max_gnat_nodes; gnat_node++)
dummy_node_table[gnat_node] = NULL_TREE;
dummy_node_table -= First_Node_Id;
}
tree
make_dummy_type (gnat_type)
Entity_Id gnat_type;
{
Entity_Id gnat_underlying;
tree gnu_type;
if (Is_Class_Wide_Type (gnat_type) && Present (Equivalent_Type (gnat_type)))
gnat_type = Equivalent_Type (gnat_type);
else if (Ekind (gnat_type) == E_Class_Wide_Type)
gnat_type = Root_Type (gnat_type);
for (gnat_underlying = gnat_type;
(IN (Ekind (gnat_underlying), Incomplete_Or_Private_Kind)
&& Present (Full_View (gnat_underlying)));
gnat_underlying = Full_View (gnat_underlying))
;
if (dummy_node_table[gnat_underlying])
return dummy_node_table[gnat_underlying];
if (Is_Record_Type (gnat_underlying))
gnu_type = make_node (Is_Unchecked_Union (gnat_underlying)
? UNION_TYPE : RECORD_TYPE);
else
gnu_type = make_node (ENUMERAL_TYPE);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
if (AGGREGATE_TYPE_P (gnu_type))
TYPE_STUB_DECL (gnu_type)
= pushdecl (build_decl (TYPE_DECL, NULL_TREE, gnu_type));
TYPE_DUMMY_P (gnu_type) = 1;
dummy_node_table[gnat_underlying] = gnu_type;
return gnu_type;
}
static int
allocatable_size_p (gnu_size, static_p)
tree gnu_size;
int static_p;
{
if (! static_p)
return ! (TREE_CODE (gnu_size) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_size));
return host_integerp (gnu_size, 1);
}
static struct attrib *
build_attr_list (gnat_entity)
Entity_Id gnat_entity;
{
struct attrib *attr_list = 0;
Node_Id gnat_temp;
for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Rep_Item (gnat_temp))
if (Nkind (gnat_temp) == N_Pragma)
{
struct attrib *attr;
tree gnu_arg0 = 0, gnu_arg1 = 0;
Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
enum attr_type etype;
if (Present (gnat_assoc) && Present (First (gnat_assoc))
&& Present (Next (First (gnat_assoc)))
&& (Nkind (Expression (Next (First (gnat_assoc))))
== N_String_Literal))
{
gnu_arg0 = get_identifier (TREE_STRING_POINTER
(gnat_to_gnu
(Expression (Next
(First (gnat_assoc))))));
if (Present (Next (Next (First (gnat_assoc))))
&& (Nkind (Expression (Next (Next (First (gnat_assoc)))))
== N_String_Literal))
gnu_arg1 = get_identifier (TREE_STRING_POINTER
(gnat_to_gnu
(Expression
(Next (Next
(First (gnat_assoc)))))));
}
switch (Get_Pragma_Id (Chars (gnat_temp)))
{
case Pragma_Machine_Attribute:
etype = ATTR_MACHINE_ATTRIBUTE;
break;
case Pragma_Linker_Alias:
etype = ATTR_LINK_ALIAS;
break;
case Pragma_Linker_Section:
etype = ATTR_LINK_SECTION;
break;
case Pragma_Weak_External:
etype = ATTR_WEAK_EXTERNAL;
break;
default:
continue;
}
attr = (struct attrib *) xmalloc (sizeof (struct attrib));
attr->next = attr_list;
attr->type = etype;
attr->name = gnu_arg0;
attr->arg = gnu_arg1;
attr->error_point
= Present (Next (First (gnat_assoc)))
? Expression (Next (First (gnat_assoc))) : gnat_temp;
attr_list = attr;
}
return attr_list;
}
tree
get_unpadded_type (gnat_entity)
Entity_Id gnat_entity;
{
tree type = gnat_to_gnu_type (gnat_entity);
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
type = TREE_TYPE (TYPE_FIELDS (type));
return type;
}
tree
maybe_variable (gnu_operand, gnat_node)
tree gnu_operand;
Node_Id gnat_node;
{
if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
|| TREE_CODE (gnu_operand) == SAVE_EXPR
|| TREE_CODE (gnu_operand) == NULL_EXPR)
return gnu_operand;
if (! global_bindings_p () && ! TREE_CONSTANT (gnu_operand)
&& ! contains_placeholder_p (gnu_operand))
set_lineno (gnat_node, 1);
if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
return build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
variable_size (TREE_OPERAND (gnu_operand, 0)));
else
return variable_size (gnu_operand);
}
static tree
elaborate_expression (gnat_expr, gnat_entity, gnu_name, definition,
need_value, need_debug)
Node_Id gnat_expr;
Entity_Id gnat_entity;
tree gnu_name;
int definition;
int need_value;
int need_debug;
{
tree gnu_expr;
if (present_gnu_tree (gnat_expr))
return get_gnu_tree (gnat_expr);
else if (! need_value
&& (Is_OK_Static_Expression (gnat_expr)
|| (Nkind (gnat_expr) == N_Identifier
&& Ekind (Entity (gnat_expr)) == E_Discriminant)))
return 0;
gnu_expr
= elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
gnu_name, definition, need_debug);
if (! TREE_CONSTANT (gnu_expr) && ! contains_placeholder_p (gnu_expr))
save_gnu_tree (gnat_expr, gnu_expr, 1);
return need_value ? gnu_expr : error_mark_node;
}
static tree
elaborate_expression_1 (gnat_expr, gnat_entity, gnu_expr, gnu_name, definition,
need_debug)
Node_Id gnat_expr;
Entity_Id gnat_entity;
tree gnu_expr;
tree gnu_name;
int definition;
int need_debug;
{
tree gnu_decl = 0;
tree gnu_inner_expr = gnu_expr;
int expr_variable;
int expr_global = Is_Public (gnat_entity) || global_bindings_p ();
while (TREE_CODE (gnu_inner_expr) == NOP_EXPR
&& TREE_CODE (gnu_inner_expr) == CONVERT_EXPR)
gnu_inner_expr = TREE_OPERAND (gnu_inner_expr, 0);
if (TREE_CODE (gnu_expr) == FIELD_DECL)
gnu_expr = build (COMPONENT_REF, TREE_TYPE (gnu_expr),
build (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
gnu_expr);
expr_variable = (TREE_CODE_CLASS (TREE_CODE (gnu_expr)) != 'c'
&& ! (TREE_CODE (gnu_inner_expr) == VAR_DECL
&& TREE_READONLY (gnu_inner_expr))
&& ! contains_placeholder_p (gnu_expr));
if (need_debug
&& (Is_OK_Static_Expression (gnat_expr)
|| contains_placeholder_p (gnu_expr)))
need_debug = 0;
if (need_debug || (expr_variable && expr_global))
{
set_lineno (gnat_entity, ! global_bindings_p ());
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, 1,
Is_Public (gnat_entity), ! definition, 0, 0);
}
if (expr_global && expr_variable)
return gnu_decl;
else
return maybe_variable (gnu_expr, gnat_expr);
}
tree
make_aligning_type (type, align, size)
tree type;
int align;
tree size;
{
tree record_type = make_node (RECORD_TYPE);
tree place = build (PLACEHOLDER_EXPR, record_type);
tree size_addr_place = convert (sizetype,
build_unary_op (ADDR_EXPR, NULL_TREE,
place));
tree name = TYPE_NAME (type);
tree pos, field;
if (TREE_CODE (name) == TYPE_DECL)
name = DECL_NAME (name);
TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
pos = size_binop (MULT_EXPR,
convert (bitsizetype,
size_binop (BIT_AND_EXPR,
size_diffop (size_zero_node,
size_addr_place),
ssize_int ((align / BITS_PER_UNIT)
- 1))),
bitsize_unit_node);
field = create_field_decl (get_identifier ("F"), type, record_type,
1, size, pos, 1);
DECL_BIT_FIELD (field) = 0;
finish_record_type (record_type, field, 1, 0);
TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
TYPE_SIZE (record_type)
= size_binop (PLUS_EXPR,
size_binop (MULT_EXPR, convert (bitsizetype, size),
bitsize_unit_node),
bitsize_int (align));
TYPE_SIZE_UNIT (record_type)
= size_binop (PLUS_EXPR, size, size_int (align / BITS_PER_UNIT));
return record_type;
}
static tree
make_packable_type (type)
tree type;
{
tree new_type = make_node (RECORD_TYPE);
tree field_list = NULL_TREE;
tree old_field;
TYPE_NAME (new_type) = TYPE_NAME (type);
TYPE_LEFT_JUSTIFIED_MODULAR_P (new_type)
= TYPE_LEFT_JUSTIFIED_MODULAR_P (type);
TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
TYPE_ALIGN (new_type)
= ((HOST_WIDE_INT) 1
<< (floor_log2 (tree_low_cst (TYPE_SIZE (type), 1) - 1) + 1));
for (old_field = TYPE_FIELDS (type); old_field != 0;
old_field = TREE_CHAIN (old_field))
{
tree new_field
= create_field_decl (DECL_NAME (old_field), TREE_TYPE (old_field),
new_type, TYPE_PACKED (type),
DECL_SIZE (old_field),
bit_position (old_field),
! DECL_NONADDRESSABLE_P (old_field));
DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
DECL_ORIGINAL_FIELD (new_field)
= (DECL_ORIGINAL_FIELD (old_field) != 0
? DECL_ORIGINAL_FIELD (old_field) : old_field);
TREE_CHAIN (new_field) = field_list;
field_list = new_field;
}
finish_record_type (new_type, nreverse (field_list), 1, 1);
return TYPE_MODE (new_type) == BLKmode ? type : new_type;
}
static tree
maybe_pad_type (type, size, align, gnat_entity, name_trailer,
is_user_type, definition, same_rm_size)
tree type;
tree size;
unsigned int align;
Entity_Id gnat_entity;
const char *name_trailer;
int is_user_type;
int definition;
int same_rm_size;
{
tree orig_size = TYPE_SIZE (type);
tree record;
tree field;
if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
{
if ((size == 0
|| operand_equal_p (round_up (size,
MAX (align, TYPE_ALIGN (type))),
round_up (TYPE_SIZE (type),
MAX (align, TYPE_ALIGN (type))),
0))
&& (align == 0 || align == TYPE_ALIGN (type)))
return type;
if (size == 0)
size = TYPE_SIZE (type);
if (align == 0)
align = TYPE_ALIGN (type);
type = TREE_TYPE (TYPE_FIELDS (type));
orig_size = TYPE_SIZE (type);
}
if (size != 0
&& (operand_equal_p (size, orig_size, 0)
|| (TREE_CODE (orig_size) == INTEGER_CST
&& tree_int_cst_lt (size, orig_size))))
size = 0;
if (align == TYPE_ALIGN (type))
align = 0;
if (align == 0 && size == 0)
return type;
record = make_node (RECORD_TYPE);
if (Present (gnat_entity))
TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
if (is_user_type)
create_type_decl (get_entity_name (gnat_entity), type,
0, ! Comes_From_Source (gnat_entity),
! (TYPE_NAME (type) != 0
&& TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
&& DECL_IGNORED_P (TYPE_NAME (type))));
if (align != 0
&& TREE_CODE (type) == RECORD_TYPE
&& TYPE_MODE (type) == BLKmode
&& host_integerp (orig_size, 1)
&& compare_tree_int (orig_size, BIGGEST_ALIGNMENT) <= 0
&& (size == 0
|| (TREE_CODE (size) == INTEGER_CST
&& compare_tree_int (size, BIGGEST_ALIGNMENT) <= 0))
&& tree_low_cst (orig_size, 1) % align == 0)
type = make_packable_type (type);
field = create_field_decl (get_identifier ("F"), type, record, 0,
NULL_TREE, bitsize_zero_node, 1);
DECL_INTERNAL_P (field) = 1;
TYPE_SIZE (record) = size != 0 ? size : orig_size;
TYPE_SIZE_UNIT (record)
= convert (sizetype,
size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
bitsize_unit_node));
TYPE_ALIGN (record) = align;
TYPE_IS_PADDING_P (record) = 1;
TYPE_VOLATILE (record)
= Present (gnat_entity) && Is_Volatile (gnat_entity);
finish_record_type (record, field, 1, 0);
TYPE_ADA_SIZE (record) = same_rm_size ? size : rm_size (type);
if (TYPE_NAME (record) != 0
&& AGGREGATE_TYPE_P (type)
&& (TREE_CODE (TYPE_NAME (type)) != TYPE_DECL
|| ! DECL_IGNORED_P (TYPE_NAME (type))))
{
tree marker = make_node (RECORD_TYPE);
tree name = DECL_NAME (TYPE_NAME (record));
tree orig_name = TYPE_NAME (type);
if (TREE_CODE (orig_name) == TYPE_DECL)
orig_name = DECL_NAME (orig_name);
TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
finish_record_type (marker,
create_field_decl (orig_name, integer_type_node,
marker, 0, NULL_TREE, NULL_TREE,
0),
0, 0);
if (size != 0 && TREE_CODE (size) != INTEGER_CST && definition)
create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
sizetype, TYPE_SIZE (record), 0, 0, 0, 0,
0);
}
type = record;
if (TREE_CODE (orig_size) != INTEGER_CST
&& contains_placeholder_p (orig_size))
orig_size = max_size (orig_size, 1);
if (size != 0 && Present (gnat_entity)
&& ! operand_equal_p (size, orig_size, 0)
&& ! (TREE_CODE (size) == INTEGER_CST
&& TREE_CODE (orig_size) == INTEGER_CST
&& tree_int_cst_lt (size, orig_size)))
{
Node_Id gnat_error_node = Empty;
if (Is_Packed_Array_Type (gnat_entity))
gnat_entity = Associated_Node_For_Itype (gnat_entity);
if ((Ekind (gnat_entity) == E_Component
|| Ekind (gnat_entity) == E_Discriminant)
&& Present (Component_Clause (gnat_entity)))
gnat_error_node = Last_Bit (Component_Clause (gnat_entity));
else if (Present (Size_Clause (gnat_entity)))
gnat_error_node = Expression (Size_Clause (gnat_entity));
if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
gnat_entity,
size_diffop (size, orig_size));
else if (*name_trailer == 'C' && ! Is_Internal (gnat_entity))
post_error_ne_tree ("component of& padded{ by ^ bits}?",
gnat_entity, gnat_entity,
size_diffop (size, orig_size));
}
return type;
}
tree
choices_to_gnu (operand, choices)
tree operand;
Node_Id choices;
{
Node_Id choice;
Node_Id gnat_temp;
tree result = integer_zero_node;
tree this_test, low = 0, high = 0, single = 0;
for (choice = First (choices); Present (choice); choice = Next (choice))
{
switch (Nkind (choice))
{
case N_Range:
low = gnat_to_gnu (Low_Bound (choice));
high = gnat_to_gnu (High_Bound (choice));
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
build_binary_op (GE_EXPR, integer_type_node,
operand, low),
build_binary_op (LE_EXPR, integer_type_node,
operand, high));
break;
case N_Subtype_Indication:
gnat_temp = Range_Expression (Constraint (choice));
low = gnat_to_gnu (Low_Bound (gnat_temp));
high = gnat_to_gnu (High_Bound (gnat_temp));
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
build_binary_op (GE_EXPR, integer_type_node,
operand, low),
build_binary_op (LE_EXPR, integer_type_node,
operand, high));
break;
case N_Identifier:
case N_Expanded_Name:
if (Ekind (Entity (choice)) != E_Enumeration_Literal
&& Ekind (Entity (choice)) != E_Constant)
{
tree type = gnat_to_gnu_type (Entity (choice));
low = TYPE_MIN_VALUE (type);
high = TYPE_MAX_VALUE (type);
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, integer_type_node,
build_binary_op (GE_EXPR, integer_type_node,
operand, low),
build_binary_op (LE_EXPR, integer_type_node,
operand, high));
break;
}
case N_Character_Literal:
case N_Integer_Literal:
single = gnat_to_gnu (choice);
this_test = build_binary_op (EQ_EXPR, integer_type_node, operand,
single);
break;
case N_Others_Choice:
this_test = integer_one_node;
break;
default:
gigi_abort (114);
}
result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
result, this_test);
}
return result;
}
static tree
gnat_to_gnu_field (gnat_field, gnu_record_type, packed, definition)
Entity_Id gnat_field;
tree gnu_record_type;
int packed;
int definition;
{
tree gnu_field_id = get_entity_name (gnat_field);
tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
tree gnu_orig_field_type = gnu_field_type;
tree gnu_pos = 0;
tree gnu_size = 0;
tree gnu_field;
int needs_strict_alignment
= (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
|| Is_Volatile (gnat_field));
if (needs_strict_alignment)
packed = 0;
if (packed == 1)
gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
gnat_field, FIELD_DECL, 0, 1);
if (Known_Static_Esize (gnat_field))
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, 0, 1);
if (packed && TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_MODE (gnu_field_type) == BLKmode
&& host_integerp (TYPE_SIZE (gnu_field_type), 1)
&& compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0)
{
gnu_field_type = make_packable_type (gnu_field_type);
if (gnu_field_type != gnu_orig_field_type && gnu_size == 0)
gnu_size = rm_size (gnu_field_type);
}
if (Present (Component_Clause (gnat_field)))
{
gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, 0, 1);
if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
{
tree gnu_parent
= gnat_to_gnu_type (Parent_Subtype
(Underlying_Type (Scope (gnat_field))));
if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
&& tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
{
post_error_ne_tree
("offset of& must be beyond parent{, minimum allowed is ^}",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_SIZE_UNIT (gnu_parent));
}
}
if (needs_strict_alignment)
{
tree gnu_min_size = round_up (rm_size (gnu_field_type),
TYPE_ALIGN (gnu_field_type));
TYPE_ALIGN (gnu_record_type)
= MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
&& ! operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
{
post_error_ne_tree
("atomic field& must be natural size of type{ (^)}",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_SIZE (gnu_field_type));
gnu_size = 0;
}
else if (Is_Aliased (gnat_field)
&& gnu_size != 0
&& tree_int_cst_lt (gnu_size, gnu_min_size))
{
post_error_ne_tree
("size of aliased field& too small{, minimum required is ^}",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
gnu_min_size);
gnu_size = 0;
}
if (! integer_zerop (size_binop
(TRUNC_MOD_EXPR, gnu_pos,
bitsize_int (TYPE_ALIGN (gnu_field_type)))))
{
if (Is_Aliased (gnat_field))
post_error_ne_num
("position of aliased field& must be multiple of ^ bits",
Component_Clause (gnat_field), gnat_field,
TYPE_ALIGN (gnu_field_type));
else if (Is_Volatile (gnat_field))
post_error_ne_num
("position of volatile field& must be multiple of ^ bits",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
else if (Strict_Alignment (Etype (gnat_field)))
post_error_ne_num
("position of & with aliased or tagged components not multiple of ^ bits",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
else
gigi_abort (124);
gnu_pos = 0;
}
if (gnu_size == 0)
gnu_pos = 0;
}
if (Is_Atomic (gnat_field))
check_ok_for_atomic (gnu_field_type, gnat_field, 0);
if (gnu_pos !=0 && TYPE_MODE (gnu_field_type) == BLKmode
&& (! integer_zerop (size_binop (TRUNC_MOD_EXPR, gnu_pos,
bitsize_unit_node))))
{
if (TREE_CODE (gnu_field_type) == RECORD_TYPE)
gnu_field_type = make_packable_type (gnu_field_type);
if (TYPE_MODE (gnu_field_type) == BLKmode)
{
post_error_ne ("fields of& must start at storage unit boundary",
First_Bit (Component_Clause (gnat_field)),
Etype (gnat_field));
gnu_pos = 0;
}
}
}
else if (Has_Specified_Layout (Scope (gnat_field))
&& Chars (gnat_field) == Name_uTag)
{
gnu_pos = bitsize_zero_node;
gnu_size = TYPE_SIZE (gnu_field_type);
}
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& gnu_size == 0
&& ! TREE_CONSTANT (TYPE_SIZE (gnu_field_type))
&& contains_placeholder_p (TYPE_SIZE (gnu_field_type))
&& ! Is_Constrained (Underlying_Type (Etype (gnat_field))))
gnu_size = max_size (TYPE_SIZE (gnu_field_type), 1);
if (gnu_size == 0)
gnu_pos = 0;
else
{
if (! needs_strict_alignment
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_LEFT_JUSTIFIED_MODULAR_P (gnu_field_type))
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
gnu_field_type
= make_type_from_size (gnu_field_type, gnu_size,
Has_Biased_Representation (gnat_field));
gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0,
gnat_field, "PAD", 0, definition, 1);
}
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
gigi_abort (118);
set_lineno (gnat_field, 0);
gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
packed, gnu_size, gnu_pos,
Is_Aliased (gnat_field));
TREE_THIS_VOLATILE (gnu_field) = Is_Volatile (gnat_field);
if (Ekind (gnat_field) == E_Discriminant)
DECL_DISCRIMINANT_NUMBER (gnu_field)
= UI_To_gnu (Discriminant_Number (gnat_field), sizetype);
return gnu_field;
}
static void
components_to_record (gnu_record_type, component_list, gnu_field_list, packed,
definition, p_gnu_rep_list, cancel_alignment, all_rep)
tree gnu_record_type;
Node_Id component_list;
tree gnu_field_list;
int packed;
int definition;
tree *p_gnu_rep_list;
int cancel_alignment;
int all_rep;
{
Node_Id component_decl;
Entity_Id gnat_field;
Node_Id variant_part;
Node_Id variant;
tree gnu_our_rep_list = NULL_TREE;
tree gnu_field, gnu_last;
int layout_with_rep = 0;
if (Present (Component_Items (component_list)))
for (component_decl = First_Non_Pragma (Component_Items (component_list));
Present (component_decl);
component_decl = Next_Non_Pragma (component_decl))
{
gnat_field = Defining_Entity (component_decl);
if (Chars (gnat_field) == Name_uParent)
gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
else
{
gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
packed, definition);
if (Chars (gnat_field) == Name_uTag)
gnu_field_list = chainon (gnu_field_list, gnu_field);
else
{
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
}
save_gnu_tree (gnat_field, gnu_field, 0);
}
variant_part = Variant_Part (component_list);
if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part))
for (variant = First_Non_Pragma (Variants (variant_part));
Present (variant);
variant = Next_Non_Pragma (variant))
{
component_decl
= First_Non_Pragma (Component_Items (Component_List (variant)));
gnat_field = Defining_Entity (component_decl);
gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
definition);
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
save_gnu_tree (gnat_field, gnu_field, 0);
}
else if (Present (variant_part))
{
tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
Node_Id variant;
tree gnu_union_type = make_node (QUAL_UNION_TYPE);
tree gnu_union_field;
tree gnu_variant_list = NULL_TREE;
tree gnu_name = TYPE_NAME (gnu_record_type);
tree gnu_var_name
= concat_id_with_name
(get_identifier (Get_Name_String (Chars (Name (variant_part)))),
"XVN");
if (TREE_CODE (gnu_name) == TYPE_DECL)
gnu_name = DECL_NAME (gnu_name);
TYPE_NAME (gnu_union_type)
= concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
for (variant = First_Non_Pragma (Variants (variant_part));
Present (variant);
variant = Next_Non_Pragma (variant))
{
tree gnu_variant_type = make_node (RECORD_TYPE);
tree gnu_inner_name;
tree gnu_qual;
Get_Variant_Encoding (variant);
gnu_inner_name = get_identifier (Name_Buffer);
TYPE_NAME (gnu_variant_type)
= concat_id_with_name (TYPE_NAME (gnu_union_type),
IDENTIFIER_POINTER (gnu_inner_name));
TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
&gnu_our_rep_list, 1, all_rep);
gnu_qual = choices_to_gnu (gnu_discriminant,
Discrete_Choices (variant));
Set_Present_Expr (variant, annotate_value (gnu_qual));
gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
gnu_union_type, 0, 0, 0, 1);
DECL_INTERNAL_P (gnu_field) = 1;
DECL_QUALIFIER (gnu_field) = gnu_qual;
TREE_CHAIN (gnu_field) = gnu_variant_list;
gnu_variant_list = gnu_field;
}
while (gnu_variant_list != 0
&& TYPE_FIELDS (TREE_TYPE (gnu_variant_list)) == 0)
gnu_variant_list = TREE_CHAIN (gnu_variant_list);
if (gnu_variant_list != 0)
{
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
0, 0);
gnu_union_field
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
packed,
all_rep ? TYPE_SIZE (gnu_union_type) : 0,
all_rep ? bitsize_zero_node : 0, 1);
DECL_INTERNAL_P (gnu_union_field) = 1;
TREE_CHAIN (gnu_union_field) = gnu_field_list;
gnu_field_list = gnu_union_field;
}
}
for (gnu_field = gnu_field_list, gnu_last = 0; gnu_field; )
{
if (DECL_FIELD_OFFSET (gnu_field) != 0)
{
tree gnu_next = TREE_CHAIN (gnu_field);
if (gnu_last == 0)
gnu_field_list = gnu_next;
else
TREE_CHAIN (gnu_last) = gnu_next;
TREE_CHAIN (gnu_field) = gnu_our_rep_list;
gnu_our_rep_list = gnu_field;
gnu_field = gnu_next;
}
else
{
gnu_last = gnu_field;
gnu_field = TREE_CHAIN (gnu_field);
}
}
if (gnu_our_rep_list != 0 && p_gnu_rep_list != 0 && ! all_rep)
*p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
else if (gnu_our_rep_list != 0)
{
tree gnu_rep_type
= gnu_field_list == 0 ? gnu_record_type : make_node (RECORD_TYPE);
int len = list_length (gnu_our_rep_list);
tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
int i;
for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
gnu_field = TREE_CHAIN (gnu_field), i++)
{
gnu_arr[i] = gnu_field;
DECL_SECTION_NAME (gnu_field) = size_int (i);
}
qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
gnu_our_rep_list = NULL_TREE;
for (i = len - 1; i >= 0; i--)
{
TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
gnu_our_rep_list = gnu_arr[i];
DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
DECL_SECTION_NAME (gnu_arr[i]) = 0;
}
if (gnu_field_list != 0)
{
finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, 0);
gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
gnu_record_type, 0, 0, 0, 1);
DECL_INTERNAL_P (gnu_field) = 1;
gnu_field_list = chainon (gnu_field_list, gnu_field);
}
else
{
layout_with_rep = 1;
gnu_field_list = nreverse (gnu_our_rep_list);
}
}
if (cancel_alignment)
TYPE_ALIGN (gnu_record_type) = 0;
finish_record_type (gnu_record_type, nreverse (gnu_field_list),
layout_with_rep, 0);
}
static int
compare_field_bitpos (rt1, rt2)
const PTR rt1;
const PTR rt2;
{
tree *t1 = (tree *) rt1;
tree *t2 = (tree *) rt2;
if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
return
(tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2))
? -1 : 1);
else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
return -1;
else
return 1;
}
static Uint
annotate_value (gnu_size)
tree gnu_size;
{
int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
TCode tcode;
Node_Ref_Or_Val ops[3];
int i;
int size;
switch (TREE_CODE (gnu_size))
{
case INTEGER_CST:
if (TREE_OVERFLOW (gnu_size))
return No_Uint;
gnu_size = convert (bitsizetype, gnu_size);
if (tree_int_cst_sgn (gnu_size) < 0)
{
tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
int adjust = 0;
tree temp;
if (TREE_CONSTANT_OVERFLOW (negative_size))
{
negative_size
= size_binop (MINUS_EXPR, bitsize_zero_node,
size_binop (PLUS_EXPR, gnu_size,
bitsize_one_node));
adjust = 1;
}
temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
if (adjust)
temp = build (MINUS_EXPR, bitsizetype, temp, bitsize_one_node);
return annotate_value (temp);
}
if (! host_integerp (gnu_size, 1))
return No_Uint;
size = tree_low_cst (gnu_size, 1);
if (tree_low_cst (gnu_size, 1) == size)
return UI_From_Int (size);
else
return No_Uint;
case COMPONENT_REF:
if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR
&& TREE_CODE (TREE_OPERAND (gnu_size, 1)) == FIELD_DECL
&& DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)) != 0)
return Create_Node (Discrim_Val,
annotate_value (DECL_DISCRIMINANT_NUMBER
(TREE_OPERAND (gnu_size, 1))),
No_Uint, No_Uint);
else
return No_Uint;
case NOP_EXPR: case CONVERT_EXPR: case NON_LVALUE_EXPR:
return annotate_value (TREE_OPERAND (gnu_size, 0));
case COND_EXPR: tcode = Cond_Expr; break;
case PLUS_EXPR: tcode = Plus_Expr; break;
case MINUS_EXPR: tcode = Minus_Expr; break;
case MULT_EXPR: tcode = Mult_Expr; break;
case TRUNC_DIV_EXPR: tcode = Trunc_Div_Expr; break;
case CEIL_DIV_EXPR: tcode = Ceil_Div_Expr; break;
case FLOOR_DIV_EXPR: tcode = Floor_Div_Expr; break;
case TRUNC_MOD_EXPR: tcode = Trunc_Mod_Expr; break;
case CEIL_MOD_EXPR: tcode = Ceil_Mod_Expr; break;
case FLOOR_MOD_EXPR: tcode = Floor_Mod_Expr; break;
case EXACT_DIV_EXPR: tcode = Exact_Div_Expr; break;
case NEGATE_EXPR: tcode = Negate_Expr; break;
case MIN_EXPR: tcode = Min_Expr; break;
case MAX_EXPR: tcode = Max_Expr; break;
case ABS_EXPR: tcode = Abs_Expr; break;
case TRUTH_ANDIF_EXPR: tcode = Truth_Andif_Expr; break;
case TRUTH_ORIF_EXPR: tcode = Truth_Orif_Expr; break;
case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
case LT_EXPR: tcode = Lt_Expr; break;
case LE_EXPR: tcode = Le_Expr; break;
case GT_EXPR: tcode = Gt_Expr; break;
case GE_EXPR: tcode = Ge_Expr; break;
case EQ_EXPR: tcode = Eq_Expr; break;
case NE_EXPR: tcode = Ne_Expr; break;
default:
return No_Uint;
}
for (i = 0; i < 3; i++)
ops[i] = No_Uint;
for (i = 0; i < len; i++)
{
ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
if (ops[i] == No_Uint)
return No_Uint;
}
return Create_Node (tcode, ops[0], ops[1], ops[2]);
}
static void
annotate_rep (gnat_entity, gnu_type)
Entity_Id gnat_entity;
tree gnu_type;
{
tree gnu_list;
tree gnu_entry;
Entity_Id gnat_field;
gnu_list = compute_field_positions (gnu_type, NULL_TREE,
size_zero_node, bitsize_zero_node);
for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
gnat_field = Next_Entity (gnat_field))
if ((Ekind (gnat_field) == E_Component
|| (Ekind (gnat_field) == E_Discriminant
&& ! Is_Unchecked_Union (Scope (gnat_field))))
&& 0 != (gnu_entry = purpose_member (gnat_to_gnu_entity (gnat_field,
NULL_TREE, 0),
gnu_list)))
{
Set_Component_Bit_Offset
(gnat_field,
annotate_value (bit_from_pos
(TREE_PURPOSE (TREE_VALUE (gnu_entry)),
TREE_VALUE (TREE_VALUE (gnu_entry)))));
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
}
}
static tree
compute_field_positions (gnu_type, gnu_list, gnu_pos, gnu_bitpos)
tree gnu_type;
tree gnu_list;
tree gnu_pos;
tree gnu_bitpos;
{
tree gnu_field;
tree gnu_result = gnu_list;
for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
gnu_field = TREE_CHAIN (gnu_field))
{
tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
DECL_FIELD_BIT_OFFSET (gnu_field));
tree gnu_our_pos = size_binop (PLUS_EXPR, gnu_pos,
DECL_FIELD_OFFSET (gnu_field));
gnu_result
= tree_cons (gnu_field,
tree_cons (gnu_our_pos, gnu_our_bitpos, NULL_TREE),
gnu_result);
if (DECL_INTERNAL_P (gnu_field))
gnu_result
= compute_field_positions (TREE_TYPE (gnu_field),
gnu_result, gnu_our_pos, gnu_our_bitpos);
}
return gnu_result;
}
static tree
validate_size (uint_size, gnu_type, gnat_object, kind, component_p, zero_ok)
Uint uint_size;
tree gnu_type;
Entity_Id gnat_object;
enum tree_code kind;
int component_p;
int zero_ok;
{
Node_Id gnat_error_node;
tree type_size
= kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
tree size;
if (type_size != 0 && TREE_CODE (type_size) != INTEGER_CST
&& contains_placeholder_p (type_size))
type_size = max_size (type_size, 1);
if (TYPE_FAT_POINTER_P (gnu_type))
type_size = bitsize_int (POINTER_SIZE);
if ((Ekind (gnat_object) == E_Component
|| Ekind (gnat_object) == E_Discriminant)
&& Present (Component_Clause (gnat_object)))
gnat_error_node = Last_Bit (Component_Clause (gnat_object));
else if (Present (Size_Clause (gnat_object)))
gnat_error_node = Expression (Size_Clause (gnat_object));
else
gnat_error_node = gnat_object;
if (Is_Packed_Array_Type (gnat_object))
gnat_error_node = Empty;
if (No (uint_size) || uint_size == No_Uint)
return 0;
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
if (component_p)
post_error_ne ("component size of & is too large",
gnat_error_node, gnat_object);
else
post_error_ne ("size of & is too large", gnat_error_node, gnat_object);
return 0;
}
else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && ! zero_ok))
return 0;
if (kind == VAR_DECL
&& ! integer_zerop (size_binop (TRUNC_MOD_EXPR, size,
bitsize_unit_node)))
{
if (component_p)
post_error_ne ("component size for& is not a multiple of Storage_Unit",
gnat_error_node, gnat_object);
else
post_error_ne ("size for& is not a multiple of Storage_Unit",
gnat_error_node, gnat_object);
return 0;
}
if (INTEGRAL_TYPE_P (gnu_type) && ! TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
&& ! (kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
if (TREE_CODE (type_size) != INTEGER_CST
|| TREE_OVERFLOW (type_size)
|| tree_int_cst_lt (size, type_size))
{
if (component_p)
post_error_ne_tree
("component size for& too small{, minimum allowed is ^}",
gnat_error_node, gnat_object, type_size);
else
post_error_ne_tree ("size for& too small{, minimum allowed is ^}",
gnat_error_node, gnat_object, type_size);
if (kind == VAR_DECL && ! component_p
&& TREE_CODE (rm_size (gnu_type)) == INTEGER_CST
&& ! tree_int_cst_lt (size, rm_size (gnu_type)))
post_error_ne_tree_2
("\\size of ^ is not a multiple of alignment (^ bits)",
gnat_error_node, gnat_object, rm_size (gnu_type),
TYPE_ALIGN (gnu_type));
else if (INTEGRAL_TYPE_P (gnu_type))
post_error_ne ("\\size would be legal if & were not aliased!",
gnat_error_node, gnat_object);
return 0;
}
return size;
}
static void
set_rm_size (uint_size, gnu_type, gnat_entity)
Uint uint_size;
tree gnu_type;
Entity_Id gnat_entity;
{
Node_Id gnat_attr_node
= Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
tree old_size = rm_size (gnu_type);
tree size;
if (No (uint_size) || uint_size == No_Uint)
return;
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
if (Present (gnat_attr_node))
post_error_ne ("Value_Size of & is too large", gnat_attr_node,
gnat_entity);
return;
}
else if (tree_int_cst_sgn (size) < 0
|| (integer_zerop (size) && No (gnat_attr_node)
&& ! Has_Size_Clause (gnat_entity)
&& ! Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
return;
if (TREE_CODE (old_size) != INTEGER_CST
&& contains_placeholder_p (old_size))
old_size = max_size (old_size, 1);
if (TREE_CODE (old_size) != INTEGER_CST
|| TREE_OVERFLOW (old_size)
|| (AGGREGATE_TYPE_P (gnu_type)
&& tree_int_cst_lt (size, old_size)))
{
if (Present (gnat_attr_node))
post_error_ne_tree
("Value_Size for& too small{, minimum allowed is ^}",
gnat_attr_node, gnat_entity, old_size);
return;
}
if (TREE_CODE (gnu_type) == INTEGER_TYPE
&& Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
TYPE_RM_SIZE_INT (gnu_type) = size;
else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
TYPE_RM_SIZE_ENUM (gnu_type) = size;
else if ((TREE_CODE (gnu_type) == RECORD_TYPE
|| TREE_CODE (gnu_type) == UNION_TYPE
|| TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
&& ! TYPE_IS_FAT_POINTER_P (gnu_type))
TYPE_ADA_SIZE (gnu_type) = size;
}
static tree
make_type_from_size (type, size_tree, biased_p)
tree type;
tree size_tree;
int biased_p;
{
tree new_type;
unsigned HOST_WIDE_INT size;
if (size_tree == 0 || ! host_integerp (size_tree, 1))
return type;
size = tree_low_cst (size_tree, 1);
switch (TREE_CODE (type))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
if (TYPE_PACKED_ARRAY_TYPE_P (type)
|| (TYPE_PRECISION (type) == size
&& biased_p == (TREE_CODE (type) == INTEGER_CST
&& TYPE_BIASED_REPRESENTATION_P (type))))
break;
size = MIN (size, LONG_LONG_TYPE_SIZE);
new_type = make_signed_type (size);
TREE_TYPE (new_type)
= TREE_TYPE (type) != 0 ? TREE_TYPE (type) : type;
TYPE_MIN_VALUE (new_type)
= convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
TYPE_MAX_VALUE (new_type)
= convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
TYPE_BIASED_REPRESENTATION_P (new_type)
= ((TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type))
|| biased_p);
TREE_UNSIGNED (new_type)
= TREE_UNSIGNED (type) | TYPE_BIASED_REPRESENTATION_P (new_type);
TYPE_RM_SIZE_INT (new_type) = bitsize_int (size);
return new_type;
case RECORD_TYPE:
if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
return
build_pointer_type
(TYPE_OBJECT_RECORD_TYPE (TYPE_UNCONSTRAINED_ARRAY (type)));
break;
case POINTER_TYPE:
if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
return
build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
break;
default:
break;
}
return type;
}
static unsigned int
validate_alignment (alignment, gnat_entity, align)
Uint alignment;
Entity_Id gnat_entity;
unsigned int align;
{
Node_Id gnat_error_node = gnat_entity;
unsigned int new_align;
#ifndef MAX_OFILE_ALIGNMENT
#define MAX_OFILE_ALIGNMENT BIGGEST_ALIGNMENT
#endif
if (Present (Alignment_Clause (gnat_entity)))
gnat_error_node = Expression (Alignment_Clause (gnat_entity));
if (! UI_Is_In_Int_Range (alignment)
|| ((new_align = UI_To_Int (alignment))
> MAX_OFILE_ALIGNMENT / BITS_PER_UNIT))
post_error_ne_num ("largest supported alignment for& is ^",
gnat_error_node, gnat_entity,
MAX_OFILE_ALIGNMENT / BITS_PER_UNIT);
else if (! (Present (Alignment_Clause (gnat_entity))
&& From_At_Mod (Alignment_Clause (gnat_entity)))
&& new_align * BITS_PER_UNIT < align)
post_error_ne_num ("alignment for& must be at least ^",
gnat_error_node, gnat_entity,
align / BITS_PER_UNIT);
else
align = MAX (align, new_align == 0 ? 1 : new_align * BITS_PER_UNIT);
return align;
}
static void
check_ok_for_atomic (object, gnat_entity, comp_p)
tree object;
Entity_Id gnat_entity;
int comp_p;
{
Node_Id gnat_error_point = gnat_entity;
Node_Id gnat_node;
enum machine_mode mode;
unsigned int align;
tree size;
if (TYPE_P (object))
{
mode = TYPE_MODE (object);
align = TYPE_ALIGN (object);
size = TYPE_SIZE (object);
}
else if (DECL_BY_REF_P (object))
{
mode = TYPE_MODE (TREE_TYPE (TREE_TYPE (object)));
align = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (object)));
size = TYPE_SIZE (TREE_TYPE (TREE_TYPE (object)));
}
else
{
mode = DECL_MODE (object);
align = DECL_ALIGN (object);
size = DECL_SIZE (object);
}
if (GET_MODE_CLASS (mode) == MODE_FLOAT
|| ((GET_MODE_CLASS (mode) == MODE_INT
|| GET_MODE_CLASS (mode) == MODE_PARTIAL_INT)
&& GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
return;
if (TREE_CODE (size) == INTEGER_CST
&& compare_tree_int (size, align) == 0
&& align <= BITS_PER_WORD)
return;
for (gnat_node = First_Rep_Item (gnat_entity); Present (gnat_node);
gnat_node = Next_Rep_Item (gnat_node))
{
if (! comp_p && Nkind (gnat_node) == N_Pragma
&& Get_Pragma_Id (Chars (gnat_node)) == Pragma_Atomic)
gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
else if (comp_p && Nkind (gnat_node) == N_Pragma
&& (Get_Pragma_Id (Chars (gnat_node))
== Pragma_Atomic_Components))
gnat_error_point = First (Pragma_Argument_Associations (gnat_node));
}
if (comp_p)
post_error_ne ("atomic access to component of & cannot be guaranteed",
gnat_error_point, gnat_entity);
else
post_error_ne ("atomic access to & cannot be guaranteed",
gnat_error_point, gnat_entity);
}
tree
gnat_substitute_in_type (t, f, r)
tree t, f, r;
{
tree new = t;
tree tem;
switch (TREE_CODE (t))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
case CHAR_TYPE:
if ((TREE_CODE (TYPE_MIN_VALUE (t)) != INTEGER_CST
&& contains_placeholder_p (TYPE_MIN_VALUE (t)))
|| (TREE_CODE (TYPE_MAX_VALUE (t)) != INTEGER_CST
&& contains_placeholder_p (TYPE_MAX_VALUE (t))))
{
tree low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
tree high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
return t;
new = build_range_type (TREE_TYPE (t), low, high);
if (TYPE_INDEX_TYPE (t))
TYPE_INDEX_TYPE (new)
= gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r);
return new;
}
return t;
case REAL_TYPE:
if ((TYPE_MIN_VALUE (t) != 0
&& TREE_CODE (TYPE_MIN_VALUE (t)) != REAL_CST
&& contains_placeholder_p (TYPE_MIN_VALUE (t)))
|| (TYPE_MAX_VALUE (t) != 0
&& TREE_CODE (TYPE_MAX_VALUE (t)) != REAL_CST
&& contains_placeholder_p (TYPE_MAX_VALUE (t))))
{
tree low = 0, high = 0;
if (TYPE_MIN_VALUE (t))
low = substitute_in_expr (TYPE_MIN_VALUE (t), f, r);
if (TYPE_MAX_VALUE (t))
high = substitute_in_expr (TYPE_MAX_VALUE (t), f, r);
if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
return t;
t = copy_type (t);
TYPE_MIN_VALUE (t) = low;
TYPE_MAX_VALUE (t) = high;
}
return t;
case COMPLEX_TYPE:
tem = gnat_substitute_in_type (TREE_TYPE (t), f, r);
if (tem == TREE_TYPE (t))
return t;
return build_complex_type (tem);
case OFFSET_TYPE:
case METHOD_TYPE:
case FILE_TYPE:
case SET_TYPE:
case FUNCTION_TYPE:
case LANG_TYPE:
abort ();
case ARRAY_TYPE:
{
tree component = gnat_substitute_in_type (TREE_TYPE (t), f, r);
tree domain = gnat_substitute_in_type (TYPE_DOMAIN (t), f, r);
if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
return t;
new = build_array_type (component, domain);
TYPE_SIZE (new) = 0;
TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
layout_type (new);
TYPE_ALIGN (new) = TYPE_ALIGN (t);
return new;
}
case RECORD_TYPE:
case UNION_TYPE:
case QUAL_UNION_TYPE:
{
tree field;
int changed_field
= (f == NULL_TREE && ! TREE_CONSTANT (TYPE_SIZE (t)));
int field_has_rep = 0;
tree last_field = 0;
tree new = copy_type (t);
TYPE_FIELDS (new) = 0;
TYPE_SIZE (new) = 0;
for (field = TYPE_FIELDS (t); field;
field = TREE_CHAIN (field))
{
tree new_field = copy_node (field);
TREE_TYPE (new_field)
= gnat_substitute_in_type (TREE_TYPE (new_field), f, r);
if (DECL_HAS_REP_P (field) && ! DECL_INTERNAL_P (field))
field_has_rep = 1;
else if (TREE_TYPE (new_field) != TREE_TYPE (field))
changed_field = 1;
if (TREE_CODE (t) != QUAL_UNION_TYPE
&& DECL_INTERNAL_P (new_field)
&& (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
|| TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
{
if (TYPE_FIELDS (TREE_TYPE (new_field)) == 0)
continue;
if (TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))) == 0)
{
tree next_new_field
= copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
new_field = next_new_field;
}
}
DECL_CONTEXT (new_field) = new;
DECL_ORIGINAL_FIELD (new_field)
= DECL_ORIGINAL_FIELD (field) != 0
? DECL_ORIGINAL_FIELD (field) : field;
DECL_SIZE (new_field)
= TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
? DECL_SIZE (field) : 0;
DECL_SIZE_UNIT (new_field)
= TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
? DECL_SIZE_UNIT (field) : 0;
if (TREE_CODE (t) == QUAL_UNION_TYPE)
{
tree new_q = substitute_in_expr (DECL_QUALIFIER (field), f, r);
if (new_q != DECL_QUALIFIER (new_field))
changed_field = 1;
DECL_QUALIFIER (new_field) = new_q;
if (integer_zerop (DECL_QUALIFIER (new_field)))
continue;
}
if (last_field == 0)
TYPE_FIELDS (new) = new_field;
else
TREE_CHAIN (last_field) = new_field;
last_field = new_field;
if (TREE_CODE (t) == QUAL_UNION_TYPE
&& integer_onep (DECL_QUALIFIER (new_field)))
break;
}
if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
&& (TYPE_FIELDS (new) == 0
|| integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
TREE_SET_CODE (new, UNION_TYPE);
else if (! changed_field)
return t;
if (field_has_rep)
gigi_abort (117);
layout_type (new);
if (TYPE_SIZE (t) != 0 && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
&& TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
{
TYPE_SIZE (new) = TYPE_SIZE (t);
TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
TYPE_ADA_SIZE (new) = TYPE_ADA_SIZE (t);
}
return new;
}
default:
return t;
}
}
tree
rm_size (gnu_type)
tree gnu_type;
{
if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type) != 0)
return TYPE_RM_SIZE (gnu_type);
else if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
return
size_binop (PLUS_EXPR,
rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
DECL_SIZE (TYPE_FIELDS (gnu_type)));
else if ((TREE_CODE (gnu_type) == RECORD_TYPE
|| TREE_CODE (gnu_type) == UNION_TYPE
|| TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
&& ! TYPE_IS_FAT_POINTER_P (gnu_type)
&& TYPE_ADA_SIZE (gnu_type) != 0)
return TYPE_ADA_SIZE (gnu_type);
else
return TYPE_SIZE (gnu_type);
}
tree
create_concat_name (gnat_entity, suffix)
Entity_Id gnat_entity;
const char *suffix;
{
const char *str = (suffix == 0 ? "" : suffix);
String_Template temp = {1, strlen (str)};
Fat_Pointer fp = {str, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
return get_identifier (Name_Buffer);
}
tree
get_entity_name (gnat_entity)
Entity_Id gnat_entity;
{
Get_Encoded_Name (gnat_entity);
return get_identifier (Name_Buffer);
}
tree
concat_id_with_name (gnu_id, suffix)
tree gnu_id;
const char *suffix;
{
int len = IDENTIFIER_LENGTH (gnu_id);
strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id),
IDENTIFIER_LENGTH (gnu_id));
strncpy (Name_Buffer + len, "___", 3);
len += 3;
strcpy (Name_Buffer + len, suffix);
return get_identifier (Name_Buffer);
}