#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tm.h"
#include "tree.h"
#include "flags.h"
#include "toplev.h"
#include "convert.h"
#include "ggc.h"
#include "obstack.h"
#include "target.h"
#include "expr.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"
#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
#else
#define Has_Stdcall_Convention(E) (0)
#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 int defer_debug_level = 0;
static tree defer_debug_incomplete_list;
static void copy_alias_set (tree, tree);
static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
static bool allocatable_size_p (tree, bool);
static void prepend_attributes (Entity_Id, struct attrib **);
static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
static bool is_variable_size (tree);
static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
bool, bool);
static tree make_packable_type (tree);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
static bool same_discriminant_p (Entity_Id, Entity_Id);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
bool, bool, bool, bool);
static int compare_field_bitpos (const PTR, const PTR);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
static void set_rm_size (Uint, tree, Entity_Id);
static tree make_type_from_size (tree, tree, bool);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static void check_ok_for_atomic (tree, Entity_Id, bool);
static int compatible_signatures_p (tree ftype1, tree ftype2);
tree
gnat_to_gnu_type (Entity_Id gnat_entity)
{
tree gnu_decl;
if (Is_Generic_Type (gnat_entity) && type_annotate_only)
return void_type_node;
gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
return TREE_TYPE (gnu_decl);
}
tree
gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
tree gnu_entity_id;
tree gnu_type = NULL_TREE;
tree gnu_decl = NULL_TREE;
bool saved = false;
bool this_deferred = false;
bool debug_deferred = false;
bool this_global = false;
bool maybe_present = false;
bool this_made_decl = false;
struct attrib *attr_list = NULL;
bool 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)
? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
: IN (kind, Access_Kind) ? POINTER_SIZE * 2
: LONG_LONG_TYPE_SIZE)
: LONG_LONG_TYPE_SIZE);
tree gnu_size = 0;
bool 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
|| 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);
}
}
gcc_unreachable ();
}
gcc_assert (Present (gnat_entity));
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, false);
save_gnu_tree (gnat_entity, gnu_decl, false);
}
return gnu_decl;
}
gcc_assert (!Unknown_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
|| (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
&& (!IN (kind, Access_Kind)
|| kind == E_Access_Protected_Subprogram_Type
|| kind == E_Access_Subtype)));
gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
|| !Unknown_RM_Size (gnat_entity));
gnu_entity_id = get_entity_name (gnat_entity);
Sloc_to_locus (Sloc (gnat_entity), &input_location);
gcc_assert (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)))
|| IN (kind, Type_Kind));
if ((!definition && Is_Public (gnat_entity)
&& !Is_Statically_Allocated (gnat_entity)
&& kind != E_Discriminant && kind != E_Component)
|| (Is_Imported (gnat_entity)
&& (kind == E_Function || kind == E_Procedure)))
force_global++, this_global = true;
if (Has_Gigi_Rep_Item (gnat_entity))
prepend_attributes (gnat_entity, &attr_list);
if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
&& !Is_First_Subtype (gnat_entity)
&& Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
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 = true;
break;
}
if (!definition
&& Present (Expression (Declaration_Node (gnat_entity)))
&& !No_Initialization (Declaration_Node (gnat_entity))
&& (Nkind (Expression (Declaration_Node (gnat_entity)))
!= N_Aggregate))
gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
if (definition && !gnu_expr
&& !No_Initialization (Declaration_Node (gnat_entity))
&& No (Renamed_Object (gnat_entity)))
{
gnu_decl = error_mark_node;
saved = true;
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 = true;
break;
}
goto object;
case E_Exception:
goto object;
case E_Discriminant:
case E_Component:
{
Entity_Id gnat_record = Underlying_Type (Scope (gnat_entity));
if (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 = true;
break;
}
else if (Present (Corresponding_Discriminant (gnat_entity))
&& Is_Tagged_Type (gnat_record))
{
gcc_assert (First_Discriminant (gnat_record)
== First_Stored_Discriminant (gnat_record));
gnu_decl
= gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
gnu_expr, definition);
saved = true;
break;
}
else if (Present (Corresponding_Discriminant (gnat_entity))
&& (First_Discriminant (gnat_record)
!= First_Stored_Discriminant (gnat_record)))
gcc_unreachable ();
else if (!definition && !present_gnu_tree (gnat_record))
{
Entity_Id Scop = Scope (Scope (gnat_entity));
if ((Is_Protected_Type (Scop)
|| (Is_Private_Type (Scop)
&& Present (Full_View (Scop))
&& Is_Protected_Type (Full_View (Scop))))
&& Present (Original_Record_Component (gnat_entity)))
{
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component
(gnat_entity),
gnu_expr, definition);
saved = true;
break;
}
gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
gnu_decl = get_gnu_tree (gnat_entity);
saved = true;
break;
}
else
gcc_unreachable ();
}
case E_Loop_Parameter:
case E_Out_Parameter:
case E_Variable:
object:
{
bool used_by_ref = false;
bool 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))));
bool inner_const_flag = const_flag;
bool static_p = Is_Statically_Allocated (gnat_entity);
bool mutable_p = false;
tree gnu_ext_name = NULL_TREE;
tree renamed_obj = 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)
{
gcc_assert (type_annotate_only);
if (this_global)
force_global--;
return error_mark_node;
}
if (kind != E_Exception && Known_Alignment (gnat_entity))
{
gcc_assert (Present (Alignment (gnat_entity)));
align = validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (gnu_type));
gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align,
gnat_entity, "PAD", 0, definition, 1);
}
if (definition)
gnu_size = validate_size (Esize (gnat_entity), gnu_type,
gnat_entity, VAR_DECL, false,
Has_Size_Clause (gnat_entity));
else if (Has_Size_Clause (gnat_entity))
gnu_size = UI_To_gnu (Esize (gnat_entity), bitsizetype);
if (gnu_size)
{
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 = NULL_TREE;
}
if (No (Renamed_Object (gnat_entity))
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
{
if (gnu_expr && kind == E_Constant)
{
gnu_type
= TREE_TYPE (gnu_expr);
gnu_size
= SUBSTITUTE_PLACEHOLDER_IN_EXPR
(TYPE_SIZE (gnu_type), gnu_expr);
}
else if (kind == E_Constant
&& (Nkind (Declaration_Node (gnat_entity))
== N_Object_Declaration)
&& Present (Expression (Declaration_Node (gnat_entity))))
{
gnu_type
= gnat_to_gnu_type
(Etype (Expression (Declaration_Node (gnat_entity))));
gnu_size
= TYPE_SIZE (gnu_type);
}
else
{
gnu_size = max_size (TYPE_SIZE (gnu_type), true);
mutable_p = true;
}
}
if (((gnu_size && integer_zerop (gnu_size))
|| (TYPE_SIZE (gnu_type) && integer_zerop (TYPE_SIZE (gnu_type))))
&& (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
|| !Is_Array_Type (Etype (gnat_entity)))
&& !Present (Renamed_Object (gnat_entity))
&& !Present (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
if (Is_Atomic (gnat_entity) && !gnu_size && 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));
}
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, true);
}
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, false);
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))));
gnu_type
= build_unc_object_type_from_ptr (gnu_fat, gnu_type,
concat_id_with_name (gnu_entity_id,
"UNC"));
}
#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 ? TREE_CODE (gnu_size) == INTEGER_CST
: TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST))
align = MINIMUM_ATOMIC_ALIGNMENT;
#endif
gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
"PAD", false, definition, true);
if ((Treat_As_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 (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !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_SIDE_EFFECTS (gnu_expr)
&& 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
{
bool stabilized = false;
tree maybe_stable_expr = NULL_TREE;
if (!Materialize_Entity (gnat_entity)
&& (!global_bindings_p ()
|| (staticp (gnu_expr)
&& !TREE_SIDE_EFFECTS (gnu_expr))))
{
maybe_stable_expr
= maybe_stabilize_reference (gnu_expr, true, false,
&stabilized);
if (stabilized)
{
gnu_decl = maybe_stable_expr;
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
break;
}
}
{
bool expr_has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
gnu_type = build_reference_type (gnu_type);
if (maybe_stable_expr)
;
else
{
maybe_stable_expr
= maybe_stabilize_reference (gnu_expr, true, true,
&stabilized);
if (stabilized)
renamed_obj = maybe_stable_expr;
}
gnu_expr
= build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
if (expr_has_side_effects && ! stabilized)
gnu_expr = save_expr (gnu_expr);
gnu_size = NULL_TREE;
used_by_ref = true;
}
}
}
else if (definition && TREE_CODE (gnu_type) == RECORD_TYPE
&& (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
|| (TYPE_IS_PADDING_P (gnu_type)
&& TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P
(TREE_TYPE (TYPE_FIELDS (gnu_type)))))
&& !gnu_expr)
{
tree template_field
= TYPE_IS_PADDING_P (gnu_type)
? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
: TYPE_FIELDS (gnu_type);
gnu_expr
= gnat_build_constructor
(gnu_type,
tree_cons
(template_field,
build_template (TREE_TYPE (template_field),
TREE_TYPE (TREE_CHAIN (template_field)),
NULL_TREE),
NULL_TREE));
}
if (definition
&& (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
&& !Is_Imported (gnat_entity) && !gnu_expr)
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, false);
gnu_size = NULL_TREE;
gnu_type = build_reference_type (gnu_type);
gnu_address = convert (gnu_type, gnu_address);
used_by_ref = true;
const_flag = !Is_Public (gnat_entity);
if (!gnu_expr)
gnu_expr = gnu_address;
else
gnu_expr
= build2 (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)
&& Has_Stdcall_Convention (gnat_entity)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
gnu_expr = NULL_TREE;
used_by_ref = true;
}
if (!allocatable_size_p (TYPE_SIZE_UNIT (gnu_type),
global_bindings_p () || !definition
|| static_p)
|| (gnu_size
&& ! allocatable_size_p (gnu_size,
global_bindings_p () || !definition
|| static_p)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
used_by_ref = true;
const_flag = true;
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)));
if (TREE_CODE (gnu_expr) == CONSTRUCTOR
&& 1 == VEC_length (constructor_elt,
CONSTRUCTOR_ELTS (gnu_expr)))
gnu_expr = 0;
else
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
false);
}
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, gnat_entity, mutable_p);
}
else
{
gnu_expr = NULL_TREE;
const_flag = false;
}
}
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;
gnu_new_var
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, NULL_TREE, false,
false, false, false, NULL, gnat_entity);
if (gnu_expr)
add_stmt_with_node
(build_binary_op (MODIFY_EXPR, NULL_TREE,
build_component_ref
(gnu_new_var, NULL_TREE,
TYPE_FIELDS (gnu_new_type), false),
gnu_expr),
gnat_entity);
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), false));
gnu_size = NULL_TREE;
used_by_ref = true;
const_flag = true;
}
if (const_flag)
gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
| TYPE_QUAL_CONST));
if (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !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 (!Is_VMS_Exception (gnat_entity)
&& ((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_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 = true;
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, gnat_entity);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
{
SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
DECL_RENAMING_GLOBAL_P (gnu_decl) = global_bindings_p ();
}
if (Present (Address_Clause (gnat_entity)) && used_by_ref)
DECL_POINTER_ALIAS_SET (gnu_decl) = 0;
if (definition && DECL_SIZE (gnu_decl)
&& get_block_jmpbuf_decl ()
&& (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))))
add_stmt_with_node (build_call_1_expr
(update_setjmp_buf_decl,
build_unary_op (ADDR_EXPR, NULL_TREE,
get_block_jmpbuf_decl ())),
gnat_entity);
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))))
{
tree gnu_corr_var
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_expr, false, Is_Public (gnat_entity),
false, static_p, NULL, gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
&& Exception_Mechanism != Back_End_Exceptions)
TREE_ADDRESSABLE (gnu_decl) = 1;
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))
{
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), NULL_TREE,
gnu_type, gnu_value, true, false, false,
false, NULL, gnat_literal);
save_gnu_tree (gnat_literal, gnu_literal, false);
gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
gnu_value, gnu_literal_list);
}
TYPE_VALUES (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;
SET_TYPE_MODULUS (gnu_type, gnu_modulus);
gnu_high = fold (build2 (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;
TYPE_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 = true;
break;
}
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
TYPE_UNSIGNED (gnu_type)
= (TYPE_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);
copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
if (Is_Packed_Array_Type (gnat_entity))
{
tree gnu_field_type = gnu_type;
tree gnu_field;
TYPE_RM_SIZE_NUM (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, "JM");
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
NULL, true, debug_info_p, gnat_entity);
gnu_field = create_field_decl (get_identifier ("OBJECT"),
gnu_field_type, gnu_type, 1, 0, 0, 0);
finish_record_type (gnu_type, gnu_field, false, false);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
copy_alias_set (gnu_type, gnu_field_type);
}
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;
SET_TYPE_DIGITS_VALUE (gnu_type,
UI_To_gnu (Digits_Value (gnat_entity),
sizetype));
break;
}
gnu_type = make_node (REAL_TYPE);
TYPE_PRECISION (gnu_type) = fp_size_to_prec (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;
}
{
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 (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
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 = true;
break;
}
layout_type (gnu_type);
copy_alias_set (gnu_type, TREE_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;
TYPE_READONLY (gnu_template_type) = 1;
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
if (!definition)
defer_incomplete_level++, this_deferred = true;
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, false, true);
tem = build3 (COMPONENT_REF, gnu_ptr_template,
build0 (PLACEHOLDER_EXPR, gnu_fat_type),
TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
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;
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);
Sloc_to_locus (Sloc (gnat_entity),
&DECL_SOURCE_LOCATION (gnu_min_field));
Sloc_to_locus (Sloc (gnat_entity),
&DECL_SOURCE_LOCATION (gnu_max_field));
gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
gnu_template_reference, gnu_min_field,
NULL_TREE);
gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
gnu_template_reference, gnu_max_field,
NULL_TREE);
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,
false, false);
TYPE_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),
true, Has_Component_Size_Clause (gnat_entity));
if (Has_Atomic_Components (gnat_entity))
check_ok_for_atomic (tem, gnat_entity, true);
if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
gnu_comp_size = max_size (TYPE_SIZE (tem), true);
if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
{
tem = make_type_from_size (tem, gnu_comp_size, false);
tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
"C_PAD", false, definition, true);
}
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)
= ((TREE_CODE (TREE_TYPE (tem)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (tem))) ? 1
: (!Has_Aliased_Components (gnat_entity)
&& !AGGREGATE_TYPE_P (TREE_TYPE (tem))));
}
if (No (Packed_Array_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
gcc_assert (Present (Alignment (gnat_entity)));
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);
SET_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));
if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_max_size_unit))
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, NULL, !Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
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;
SET_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), NULL,
!Comes_From_Source (gnat_entity), debug_info_p,
gnat_entity);
}
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 = NULL_TREE;
tree gnu_max_size = size_one_node;
tree gnu_max_size_unit;
bool need_index_type_struct = false;
bool max_overflow = false;
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)
|| TYPE_UNSIGNED (gnu_index_subtype)
!= TYPE_UNSIGNED (sizetype))
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
&& (!TREE_OVERFLOW
(fold (build2 (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)
|| TYPE_UNSIGNED (gnu_index_subtype)
!= TYPE_UNSIGNED (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 (TYPE_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))
|| !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))
|| !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 = true;
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 = true;
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)
&& (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 = true;
}
gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
if (present_gnu_tree (gnat_entity))
{
maybe_present = true;
break;
}
gnu_comp_size
= validate_size (Component_Size (gnat_entity), gnu_type,
gnat_entity,
(Is_Bit_Packed_Array (gnat_entity)
? TYPE_DECL : VAR_DECL),
true, Has_Component_Size_Clause (gnat_entity));
if (!gnu_comp_size && TREE_CODE (gnu_type) == RECORD_TYPE
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
if (!Is_Bit_Packed_Array (gnat_entity) && gnu_comp_size)
{
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
gnat_entity, "C_PAD", false,
definition, true);
}
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));
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)
= ((TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type))) ? 1
: (!Has_Aliased_Components (gnat_entity)
&& !AGGREGATE_TYPE_P (TREE_TYPE (gnu_type))));
}
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"))
{
tree eltype = TREE_TYPE (gnu_arr_type);
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)
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
(gnat_entity, gnat_entity,
build_binary_op (EXACT_DIV_EXPR, sizetype,
TYPE_SIZE_UNIT (gnu_arr_type),
size_int (TYPE_ALIGN (eltype)
/ BITS_PER_UNIT)),
concat_id_with_name (gnu_str_name, "A_U"),
definition, 0),
size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
}
}
if (need_index_type_struct && debug_info_p)
{
tree gnu_bound_rec_type = make_node (RECORD_TYPE);
tree gnu_field_list = NULL_TREE;
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,
false, false);
}
TYPE_CONVENTION_FORTRAN_P (gnu_type)
= (Convention (gnat_entity) == Convention_Fortran);
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= Is_Packed_Array_Type (gnat_entity);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& !(TREE_CODE (gnu_max_size) == INTEGER_CST
&& TREE_OVERFLOW (gnu_max_size))
&& !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
&& TREE_OVERFLOW (gnu_max_size_unit))
&& !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));
}
copy_alias_set (gnu_type, gnu_base_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
* Treat_As_Volatile (gnat_entity))));
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
if (!Comes_From_Source (gnat_entity))
DECL_ARTIFICIAL (gnu_decl) = 1;
save_gnu_tree (gnat_entity, gnu_decl, false);
gnu_decl = gnat_to_gnu_entity (Packed_Array_Type (gnat_entity),
NULL_TREE, 0);
this_made_decl = true;
gnu_inner_type = gnu_type = TREE_TYPE (gnu_decl);
save_gnu_tree (gnat_entity, NULL_TREE, false);
while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
&& (TYPE_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))
|| (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);
TYPE_UNSIGNED (gnu_subtype)
= TYPE_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;
}
SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
for (gnat_index = First_Index (gnat_entity);
Present (gnat_index); gnat_index = Next_Index (gnat_index))
SET_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)
SET_TYPE_ACTUAL_BOUNDS
(gnu_inner_type,
nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_type))
TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
}
}
else
gcc_assert (!Is_Packed (gnat_entity));
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
= get_base_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);
copy_alias_set (gnu_type, gnu_string_type);
}
break;
case E_Record_Type:
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)))))))));
break;
}
{
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);
bool has_rep = Has_Specified_Layout (gnat_entity);
bool all_rep = has_rep;
bool 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 = false;
if (is_extension)
{
if (!type_annotate_only
|| Present (Record_Extension_Part (record_definition)))
record_definition = Record_Extension_Part (record_definition);
gcc_assert (type_annotate_only
|| Present (Parent_Subtype (gnat_entity)));
}
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 || has_rep;
if (!definition)
defer_incomplete_level++, this_deferred = true;
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)
= (esize >= BITS_PER_WORD ? BITS_PER_WORD
: 1 << (floor_log2 (esize - 1) + 1));
if (Present (Parent_Subtype (gnat_entity)))
{
Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
tree gnu_parent;
gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
build0 (PLACEHOLDER_EXPR, gnu_type),
build_decl (FIELD_DECL, NULL_TREE,
NULL_TREE),
NULL_TREE);
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
save_gnu_tree
(gnat_field,
build3 (COMPONENT_REF,
get_unpadded_type (Etype (gnat_field)),
gnu_get_parent,
gnat_to_gnu_field_decl (Corresponding_Discriminant
(gnat_field)),
NULL_TREE),
true);
gnu_parent = gnat_to_gnu_type (gnat_parent);
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
{
Entity_Id field = Empty;
for (field = First_Stored_Discriminant (gnat_parent);
Present (field);
field = Next_Stored_Discriminant (field))
if (same_discriminant_p (gnat_field, field))
break;
gcc_assert (Present (field));
TREE_OPERAND (get_gnu_tree (gnat_field), 1)
= gnat_to_gnu_field_decl (field);
}
TREE_TYPE (gnu_get_parent) = gnu_parent;
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_OPERAND (gnu_get_parent, 1) = gnu_field_list;
}
if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_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,
build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
build0 (PLACEHOLDER_EXPR,
DECL_CONTEXT (gnu_field)),
gnu_field, NULL_TREE),
true);
if (!Is_Unchecked_Union (gnat_entity))
{
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, NULL,
false, all_rep, this_deferred,
Is_Unchecked_Union (gnat_entity));
if (this_deferred)
{
debug_deferred = true;
defer_debug_level++;
defer_debug_incomplete_list
= tree_cons (NULL_TREE, gnu_type,
defer_debug_incomplete_list);
}
TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
TYPE_MODE (gnu_type) = BLKmode;
if (Etype (gnat_entity) != gnat_entity
&& !(Is_Private_Type (Etype (gnat_entity))
&& Full_View (Etype (gnat_entity)) == gnat_entity))
copy_alias_set (gnu_type, gnat_to_gnu_type (Etype (gnat_entity)));
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_decl = gnat_to_gnu_entity (Equivalent_Type (gnat_entity),
NULL_TREE, 0);
maybe_present = true;
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 = true;
}
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 = true;
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 = true;
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)
&& Stored_Constraint (gnat_entity) != No_Elist
&& Present (Discriminant_Constraint (gnat_entity)))
{
Entity_Id gnat_field;
tree gnu_field_list = 0;
tree gnu_pos_list
= compute_field_positions (gnu_orig_type, NULL_TREE,
size_zero_node, bitsize_zero_node,
BIGGEST_ALIGNMENT);
tree gnu_subst_list
= substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
definition);
tree gnu_temp;
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= create_type_decl (NULL_TREE, gnu_type, NULL, false, false,
gnat_entity);
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)
&& (Underlying_Type (Scope (Original_Record_Component
(gnat_field)))
== gnat_base_type)
&& (No (Corresponding_Discriminant (gnat_field))
|| !Is_Tagged_Type (gnat_base_type)))
{
tree gnu_old_field
= gnat_to_gnu_field_decl (Original_Record_Component
(gnat_field));
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 (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;
unsigned int offset_align
= tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
1);
tree gnu_field;
if (Present (Component_Clause
(Original_Record_Component (gnat_field)))
|| (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
&& TREE_TYPE (TYPE_FIELDS (gnu_field_type))
== TREE_TYPE (gnu_old_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 (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, offset_align);
DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
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);
SET_DECL_ORIGINAL_FIELD
(gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
? 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, false);
}
for (gnat_field = First_Entity (gnat_entity);
Present (gnat_field); gnat_field = Next_Entity (gnat_field))
if ((Ekind (gnat_field) == E_Discriminant
|| Ekind (gnat_field) == E_Component)
&& !present_gnu_tree (Etype (gnat_field)))
gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
finish_record_type (gnu_type, nreverse (gnu_field_list),
true, false);
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);
SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
copy_alias_set (gnu_type, gnu_base_type);
if (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 (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 (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
for (gnu_temp = gnu_subst_list;
gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
SET_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),
false, false);
}
TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
= create_type_decl (TYPE_NAME (gnu_type), gnu_type,
NULL, true, debug_info_p, gnat_entity);
}
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,
gnat_to_gnu_field_decl
(Original_Record_Component (gnat_temp)), false);
}
break;
case E_Access_Subprogram_Type:
case E_Anonymous_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, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, false);
this_made_decl = saved = true;
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);
bool in_main_unit
= (Present (gnat_desig_full)
? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type));
bool got_fat_p = false;
bool made_dummy = false;
tree gnu_desig_type = NULL_TREE;
enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
if (!targetm.valid_pointer_mode (p_mode))
p_mode = ptr_mode;
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)
&& Ekind (gnat_desig_full) == E_Record_Subtype
&& Ekind (Etype (gnat_desig_full)) == E_Record_Type)
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)))))
|| (No (gnat_desig_full) && !in_main_unit
&& defer_incomplete_level
&& !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 = true;
gnu_type = TYPE_POINTER_TO (gnu_old);
if (!gnu_type)
{
tree gnu_template_type = make_node (ENUMERAL_TYPE);
tree gnu_ptr_template = build_pointer_type (gnu_template_type);
tree gnu_array_type = make_node (ENUMERAL_TYPE);
tree gnu_ptr_array = build_pointer_type (gnu_array_type);
TYPE_NAME (gnu_template_type)
= concat_id_with_name (get_entity_name (gnat_desig_type),
"XUB");
TYPE_DUMMY_P (gnu_template_type) = 1;
TYPE_NAME (gnu_array_type)
= concat_id_with_name (get_entity_name (gnat_desig_type),
"XUA");
TYPE_DUMMY_P (gnu_array_type) = 1;
gnu_type = make_node (RECORD_TYPE);
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_old);
TYPE_POINTER_TO (gnu_old) = gnu_type;
Sloc_to_locus (Sloc (gnat_entity), &input_location);
fields
= chainon (chainon (NULL_TREE,
create_field_decl
(get_identifier ("P_ARRAY"),
gnu_ptr_array,
gnu_type, 0, 0, 0, 0)),
create_field_decl (get_identifier ("P_BOUNDS"),
gnu_ptr_template,
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, false, true);
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 = true;
}
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 = true;
}
else if (gnat_desig_type == gnat_entity)
{
gnu_type
= build_pointer_type_for_mode (make_node (VOID_TYPE),
p_mode,
No_Strict_Aliasing (gnat_entity));
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 = true;
break;
}
if (!gnu_type && gnu_desig_type)
{
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);
if (TYPE_MODE (gnu_desig_type) == VOIDmode)
{
made_dummy = true;
TYPE_NAME (gnu_desig_type)
= create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
}
}
gnu_type
= build_pointer_type_for_mode (gnu_desig_type, p_mode,
No_Strict_Aliasing (gnat_entity));
}
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, gnat_entity);
save_gnu_tree (gnat_entity, gnu_decl, false);
this_made_decl = saved = true;
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:
case E_Anonymous_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 if (IN (Ekind (Base_Type
(Directly_Designated_Type (gnat_entity))),
Incomplete_Or_Private_Kind))
;
else
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
}
maybe_present = true;
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;
tree gnu_builtin_decl = NULL_TREE;
Entity_Id gnat_param;
bool inline_flag = Is_Inlined (gnat_entity);
bool public_flag = Is_Public (gnat_entity);
bool extern_flag
= (Is_Public (gnat_entity) && !definition) || imported_p;
bool pure_flag = Is_Pure (gnat_entity);
bool volatile_flag = No_Return (gnat_entity);
bool returns_by_ref = false;
bool returns_unconstrained = false;
bool returns_by_target_ptr = false;
tree gnu_ext_name = create_concat_name (gnat_entity, 0);
bool has_copy_in_out = false;
int parmnum;
if (kind == E_Subprogram_Type && !definition)
defer_incomplete_level++, this_deferred = true;
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 (Convention (gnat_entity) == Convention_Intrinsic)
gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
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 = true;
gnu_return_type = build_pointer_type (gnu_return_type);
}
else if (kind == E_Function
&& Mechanism (gnat_entity) == By_Reference)
{
gnu_return_type = copy_type (gnu_return_type);
TREE_ADDRESSABLE (gnu_return_type) = 1;
}
else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
{
gnu_return_type = TREE_TYPE (gnu_return_type);
returns_unconstrained = true;
}
else if (Requires_Transient_Scope (Etype (gnat_entity)))
{
gnu_return_type = build_pointer_type (gnu_return_type);
returns_unconstrained = true;
}
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));
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
{
returns_by_target_ptr = true;
gnu_param_list
= create_param_decl (get_identifier ("TARGET"),
build_reference_type (gnu_return_type),
true);
gnu_return_type = void_type_node;
}
if (TYPE_SIZE_UNIT (gnu_return_type)
&& TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
&& TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
{
post_error ("cannot return type whose size overflows",
gnat_entity);
gnu_return_type = copy_node (gnu_return_type);
TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
}
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;
bool by_ref_p = false;
bool by_descr_p = false;
bool by_component_ptr_p = false;
bool copy_in_copy_out_flag = false;
bool req_by_copy = false, req_by_ref = false;
if (gnu_builtin_decl)
req_by_copy = 1;
else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
req_by_copy = true;
else if (Mechanism (gnat_param) == Default)
;
else if (Mechanism (gnat_param) == By_Copy)
req_by_copy = true;
else if (Mechanism (gnat_param) == By_Reference)
req_by_ref = true;
else if (Mechanism (gnat_param) <= By_Descriptor)
by_descr_p = true;
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 = true;
else
req_by_copy = true;
}
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)))
&& (req_by_copy
|| !default_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
&& !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 = true;
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), false);
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 = true;
}
else if (Ekind (gnat_param) != E_In_Parameter)
copy_in_copy_out_flag = true;
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)))
&& !(Is_Array_Type (Etype (gnat_param))
&& Is_Packed (Etype (gnat_param))
&& Is_Composite_Type (Component_Type
(Etype (gnat_param)))))
gnu_param = NULL_TREE;
else
{
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));
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_param));
save_gnu_tree (gnat_param, gnu_param, false);
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 = false;
}
if (copy_in_copy_out_flag)
{
if (!has_copy_in_out)
{
gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
gnu_return_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
has_copy_in_out = true;
}
gnu_field = create_field_decl (gnu_param_name, gnu_param_type,
gnu_return_type, 0, 0, 0, 0);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_field));
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
&& Convention (gnat_entity) != Convention_Stubbed)
{
finish_record_type (gnu_return_type, nreverse (gnu_field_list),
false, defer_incomplete_level);
if (defer_incomplete_level)
{
debug_deferred = true;
defer_debug_level++;
defer_debug_incomplete_list
= tree_cons (NULL_TREE, gnu_return_type,
defer_debug_incomplete_list);
}
}
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
if (Has_Stdcall_Convention (gnat_entity))
{
struct attrib *attr
= (struct attrib *) xmalloc (sizeof (struct attrib));
attr->next = attr_list;
attr->type = ATTR_MACHINE_ATTRIBUTE;
attr->name = get_identifier ("stdcall");
attr->args = 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),
returns_by_target_ptr);
if (TREE_CODE (gnu_return_type) == VOID_TYPE)
pure_flag = false;
gnu_type
= build_qualified_type (gnu_type,
TYPE_QUALS (gnu_type)
| (Exception_Mechanism == Back_End_Exceptions
? TYPE_QUAL_CONST * pure_flag : 0)
| (TYPE_QUAL_VOLATILE * volatile_flag));
Sloc_to_locus (Sloc (gnat_entity), &input_location);
if (gnu_builtin_decl)
{
tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
if (compatible_signatures_p (gnu_type, gnu_builtin_type))
{
gnu_decl = gnu_builtin_decl;
gnu_type = gnu_builtin_type;
break;
}
}
if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_id)
gnu_ext_name = NULL_TREE;
if (Present (Address_Clause (gnat_entity)))
{
tree gnu_address = NULL_TREE;
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, false);
gnu_type = build_reference_type (gnu_type);
if (gnu_address)
gnu_address = convert (gnu_type, gnu_address);
gnu_decl
= create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
gnu_address, false, Is_Public (gnat_entity),
extern_flag, false, NULL, gnat_entity);
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 && !defer_incomplete_level,
gnat_entity);
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,
gnat_entity);
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)
{
if (From_With_Type (gnat_entity)
&& Present (Non_Limited_View (gnat_entity)))
gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
NULL_TREE, 0);
else
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 = true;
}
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 = true;
break;
}
gnu_type = make_dummy_type (gnat_entity);
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
save_gnu_tree (Full_View (gnat_entity), gnu_decl, false);
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 = true;
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 = true;
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 = true;
break;
default:
gcc_unreachable ();
}
if (maybe_present && present_gnu_tree (gnat_entity))
{
gnu_decl = get_gnu_tree (gnat_entity);
saved = true;
}
if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
{
if (Is_Tagged_Type (gnat_entity)
|| Is_Class_Wide_Equivalent_Type (gnat_entity))
TYPE_ALIGN_OK (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 && kind != E_String_Literal_Subtype)
gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
TYPE_DECL, false,
Has_Size_Clause (gnat_entity));
if (gnu_size)
{
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
&& 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
&& 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",
true, definition, false);
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)
&& !TREE_CONSTANT (TYPE_SIZE (gnu_type))
&& !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_SIZE (gnu_type)
= elaborate_expression_1 (gnat_entity, gnat_entity,
TYPE_SIZE (gnu_type),
get_identifier ("SIZE"),
definition, 0);
SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
}
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)
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
(gnat_entity, gnat_entity,
build_binary_op (EXACT_DIV_EXPR, sizetype,
TYPE_SIZE_UNIT (gnu_type),
size_int (TYPE_ALIGN (gnu_type)
/ BITS_PER_UNIT)),
get_identifier ("SIZE_A_UNIT"),
definition, 0),
size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
if (TREE_CODE (gnu_type) == RECORD_TYPE)
SET_TYPE_ADA_SIZE
(gnu_type,
elaborate_expression_1 (gnat_entity,
gnat_entity,
TYPE_ADA_SIZE (gnu_type),
get_identifier ("RM_SIZE"),
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 (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
DECL_FIELD_OFFSET (gnu_field)
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
(gnat_temp, gnat_temp,
build_binary_op (EXACT_DIV_EXPR, sizetype,
DECL_FIELD_OFFSET (gnu_field),
size_int (DECL_OFFSET_ALIGN (gnu_field)
/ BITS_PER_UNIT)),
get_identifier ("OFFSET"),
definition, 0),
size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
}
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
| (TYPE_QUAL_VOLATILE
* Treat_As_Volatile (gnat_entity))));
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, false);
if (Known_Alignment (gnat_entity))
TYPE_USER_ALIGN (gnu_type) = 1;
if (!gnu_decl)
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
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))
{
tree gnu_size = TYPE_SIZE (gnu_type);
if (CONTAINS_PLACEHOLDER_P (gnu_size))
gnu_size = max_size (gnu_size, true);
Set_Esize (gnat_entity, annotate_value (gnu_size));
if (type_annotate_only && Is_Tagged_Type (gnat_entity))
{
int size_offset;
int new_size;
if (Is_Derived_Type (gnat_entity))
{
size_offset
= UI_To_Int (Esize (Etype (Base_Type (gnat_entity))));
Set_Alignment (gnat_entity,
Alignment (Etype (Base_Type (gnat_entity))));
}
else
size_offset = POINTER_SIZE;
new_size = UI_To_Int (Esize (gnat_entity)) + size_offset;
Set_Esize (gnat_entity,
UI_From_Int (((new_size + (POINTER_SIZE - 1))
/ POINTER_SIZE) * POINTER_SIZE));
Set_RM_Size (gnat_entity, Esize (gnat_entity));
}
}
if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
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
&& No (Renamed_Object (gnat_entity)))
DECL_IGNORED_P (gnu_decl) = 1;
if (!saved)
save_gnu_tree (gnat_entity, gnu_decl, false);
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 && 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 (TREE_CODE (gnu_scalar_type) == ENUMERAL_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)
{
struct incomplete *incp = defer_incomplete_list;
struct incomplete *next;
defer_incomplete_list = NULL;
for (; incp; incp = next)
{
next = incp->next;
if (incp->old_type)
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 && incp->full_type == gnat_entity)
{
update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
TREE_TYPE (gnu_decl));
incp->old_type = NULL_TREE;
}
}
if (debug_deferred)
defer_debug_level--;
if (defer_debug_incomplete_list
&& !defer_incomplete_level
&& !defer_debug_level)
{
tree c, n;
defer_debug_incomplete_list = nreverse (defer_debug_incomplete_list);
for (c = defer_debug_incomplete_list; c; c = n)
{
n = TREE_CHAIN (c);
write_record_type_debug_info (TREE_VALUE (c));
}
defer_debug_incomplete_list = 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;
}
tree
gnat_to_gnu_field_decl (Entity_Id gnat_entity)
{
tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
if (TREE_CODE (gnu_field) == COMPONENT_REF)
gnu_field = TREE_OPERAND (gnu_field, 1);
return gnu_field;
}
static
bool same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
{
while (Present (Corresponding_Discriminant (discr1)))
discr1 = Corresponding_Discriminant (discr1);
while (Present (Corresponding_Discriminant (discr2)))
discr2 = Corresponding_Discriminant (discr2);
return
Original_Record_Component (discr1) == Original_Record_Component (discr2);
}
void
elaborate_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 (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, true);
save_gnu_tree (gnat_entity, error_mark_node, true);
}
}
static void
copy_alias_set (tree gnu_new_type, tree gnu_old_type)
{
while (TREE_CODE (gnu_old_type) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
|| TYPE_IS_PADDING_P (gnu_old_type)))
gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_old_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
record_component_aliases (gnu_new_type);
}
static tree
substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
tree gnu_list, bool 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_Stored_Discriminant (gnat_type),
gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
Present (gnat_discrim);
gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
gnat_value = Next_Elmt (gnat_value))
if (!Is_Access_Type (Etype (Node (gnat_value))))
gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
elaborate_expression
(Node (gnat_value), gnat_subtype,
get_entity_name (gnat_discrim), definition,
1, 0),
gnu_list);
return gnu_list;
}
static GTY((length ("max_gnat_nodes"))) tree * dummy_node_table;
void
init_dummy_type (void)
{
Node_Id gnat_node;
dummy_node_table = (tree *) ggc_alloc (max_gnat_nodes * sizeof (tree));
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 (Entity_Id gnat_type)
{
Entity_Id gnat_underlying;
tree gnu_type;
enum tree_code code;
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))
{
Node_Id component_list
= Component_List (Type_Definition
(Declaration_Node
(Implementation_Base_Type (gnat_underlying))));
Node_Id component;
code = UNION_TYPE;
if (!Is_Unchecked_Union (gnat_underlying))
code = RECORD_TYPE;
else
for (component = First_Non_Pragma (Component_Items (component_list));
Present (component); component = Next_Non_Pragma (component))
if (Ekind (Defining_Entity (component)) == E_Component)
code = RECORD_TYPE;
}
else
code = ENUMERAL_TYPE;
gnu_type = make_node (code);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
if (AGGREGATE_TYPE_P (gnu_type))
TYPE_STUB_DECL (gnu_type) = build_decl (TYPE_DECL, NULL_TREE, gnu_type);
dummy_node_table[gnat_underlying] = gnu_type;
return gnu_type;
}
static bool
allocatable_size_p (tree gnu_size, bool static_p)
{
HOST_WIDE_INT our_size;
if (!static_p)
return !(TREE_CODE (gnu_size) == INTEGER_CST
&& TREE_CONSTANT_OVERFLOW (gnu_size));
if (!host_integerp (gnu_size, 1))
return false;
our_size = tree_low_cst (gnu_size, 1);
return (int) our_size == our_size;
}
static void
prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
{
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 = NULL_TREE, gnu_arg1 = NULL_TREE;
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_Linker_Constructor:
etype = ATTR_LINK_CONSTRUCTOR;
break;
case Pragma_Linker_Destructor:
etype = ATTR_LINK_DESTRUCTOR;
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;
if (gnu_arg1 != NULL_TREE)
attr->args = build_tree_list (NULL_TREE, gnu_arg1);
else
attr->args = NULL_TREE;
attr->error_point
= Present (Next (First (gnat_assoc)))
? Expression (Next (First (gnat_assoc))) : gnat_temp;
*attr_list = attr;
}
}
tree
get_unpadded_type (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 (tree gnu_operand)
{
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 (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
{
tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
TREE_TYPE (gnu_operand),
variable_size (TREE_OPERAND (gnu_operand, 0)));
TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
= TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
return gnu_result;
}
else
return variable_size (gnu_operand);
}
static tree
elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
tree gnu_name, bool definition, bool need_value,
bool 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 (!CONTAINS_PLACEHOLDER_P (gnu_expr))
save_gnu_tree (gnat_expr, gnu_expr, true);
return need_value ? gnu_expr : error_mark_node;
}
static tree
elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
tree gnu_expr, tree gnu_name, bool definition,
bool need_debug)
{
tree gnu_decl = NULL_TREE;
tree gnu_inner_expr = remove_conversions (gnu_expr, true);
bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
bool expr_variable;
if (TREE_CODE (gnu_expr) == FIELD_DECL)
gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
gnu_expr, NULL_TREE);
expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
&& !(TREE_CODE (gnu_inner_expr) == VAR_DECL
&& (TREE_READONLY (gnu_inner_expr)
|| DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
&& !CONTAINS_PLACEHOLDER_P (gnu_expr));
if (need_debug
&& (Is_OK_Static_Expression (gnat_expr)
|| CONTAINS_PLACEHOLDER_P (gnu_expr)))
need_debug = false;
if (need_debug || (expr_variable && expr_global))
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
!need_debug, Is_Public (gnat_entity),
!definition, false, NULL, gnat_entity);
if (expr_global && expr_variable)
return gnu_decl;
else if (!expr_variable)
return gnu_expr;
else
return maybe_variable (gnu_expr);
}
tree
make_aligning_type (tree type, int align, tree size)
{
tree record_type = make_node (RECORD_TYPE);
tree place = build0 (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);
finish_record_type (record_type, field, true, false);
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));
copy_alias_set (record_type, type);
return record_type;
}
static tree
make_packable_type (tree type)
{
tree new_type = make_node (TREE_CODE (type));
tree field_list = NULL_TREE;
tree old_field;
TYPE_NAME (new_type) = TYPE_NAME (type);
TYPE_JUSTIFIED_MODULAR_P (new_type)
= TYPE_JUSTIFIED_MODULAR_P (type);
TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
if (TREE_CODE (type) == RECORD_TYPE)
TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
else if (TREE_CODE (type) == QUAL_UNION_TYPE)
{
TYPE_SIZE (new_type) = TYPE_SIZE (type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (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;
old_field = TREE_CHAIN (old_field))
{
tree new_field_type = TREE_TYPE (old_field);
tree new_field;
if (TYPE_MODE (new_field_type) == BLKmode
&& (TREE_CODE (new_field_type) == RECORD_TYPE
|| TREE_CODE (new_field_type) == UNION_TYPE
|| TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
&& host_integerp (TYPE_SIZE (new_field_type), 1))
new_field_type = make_packable_type (new_field_type);
new_field = create_field_decl (DECL_NAME (old_field), new_field_type,
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);
SET_DECL_ORIGINAL_FIELD
(new_field, (DECL_ORIGINAL_FIELD (old_field)
? DECL_ORIGINAL_FIELD (old_field) : old_field));
if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
TREE_CHAIN (new_field) = field_list;
field_list = new_field;
}
finish_record_type (new_type, nreverse (field_list), true, true);
copy_alias_set (new_type, type);
return TYPE_MODE (new_type) == BLKmode ? type : new_type;
}
tree
maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, const char *name_trailer,
bool is_user_type, bool definition, bool 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
|| 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)
size = TYPE_SIZE (type);
if (align == 0)
align = TYPE_ALIGN (type);
type = TREE_TYPE (TYPE_FIELDS (type));
orig_size = TYPE_SIZE (type);
}
if (size
&& (operand_equal_p (size, orig_size, 0)
|| (TREE_CODE (orig_size) == INTEGER_CST
&& tree_int_cst_lt (size, orig_size))))
size = NULL_TREE;
if (align == TYPE_ALIGN (type))
align = 0;
if (align == 0 && !size)
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,
NULL, !Comes_From_Source (gnat_entity),
!(TYPE_NAME (type)
&& TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
&& DECL_IGNORED_P (TYPE_NAME (type))),
gnat_entity);
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
|| (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 ? size : orig_size;
TYPE_SIZE_UNIT (record)
= (size ? convert (sizetype,
size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node))
: TYPE_SIZE_UNIT (type));
TYPE_ALIGN (record) = align;
TYPE_IS_PADDING_P (record) = 1;
TYPE_VOLATILE (record)
= Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
finish_record_type (record, field, true, false);
SET_TYPE_ADA_SIZE (record, same_rm_size ? size : rm_size (type));
if (TYPE_NAME (record) && 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 = (TREE_CODE (TYPE_NAME (record)) == TYPE_DECL
? DECL_NAME (TYPE_NAME (record))
: 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),
false, false);
if (size && TREE_CODE (size) != INTEGER_CST && definition)
create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
bitsizetype, TYPE_SIZE (record), false, false, false,
false, NULL, gnat_entity);
}
type = record;
if (CONTAINS_PLACEHOLDER_P (orig_size))
orig_size = max_size (orig_size, true);
if (size && 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 (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:
gcc_unreachable ();
}
result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
result, this_test);
}
return result;
}
static tree
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
bool definition)
{
tree gnu_field_id = get_entity_name (gnat_field);
tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
tree gnu_pos = 0;
tree gnu_size = 0;
tree gnu_field;
bool needs_strict_alignment
= (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
|| Treat_As_Volatile (gnat_field));
if (needs_strict_alignment || is_variable_size (gnu_field_type))
packed = 0;
if (packed == 1)
gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
if (Known_Static_Esize (gnat_field))
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
if (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
&& (packed == 1
|| (gnu_size
&& tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))
|| (Present (Component_Clause (gnat_field)) && gnu_size != 0)))
{
tree gnu_packable_type = make_packable_type (gnu_field_type);
bool has_byte_aligned_clause
= Present (Component_Clause (gnat_field))
&& (UI_To_Int (Component_Bit_Offset (gnat_field))
% BITS_PER_UNIT == 0);
int reject =
(gnu_packable_type == gnu_field_type
||
(has_byte_aligned_clause
&& value_factor_p (gnu_size, BITS_PER_UNIT))
||
(Is_Aliased (gnat_field)
&& has_byte_aligned_clause
&& ! value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)))
);
if (!reject)
{
gnu_field_type = gnu_packable_type;
if (gnu_size == 0)
gnu_size = rm_size (gnu_field_type);
}
}
if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
gnu_size = round_up (gnu_size, BITS_PER_UNIT);
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, false, true);
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_rounded_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 = NULL_TREE;
}
else if (Is_Aliased (gnat_field)
&& gnu_size
&& ! operand_equal_p (gnu_size, gnu_rounded_size, 0))
{
post_error_ne_tree
("size of aliased field& must be ^ bits",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
gnu_rounded_size);
gnu_size = NULL_TREE;
}
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",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
else if (Treat_As_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
gcc_unreachable ();
gnu_pos = NULL_TREE;
}
}
if (Is_Atomic (gnat_field))
check_ok_for_atomic (gnu_field_type, gnat_field, false);
}
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
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
&& !Is_Constrained (Underlying_Type (Etype (gnat_field))))
{
gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
packed = 0;
}
if (!gnu_size)
gnu_pos = NULL_TREE;
else
{
if (!needs_strict_alignment
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
&& tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
<= 0)
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", false, definition, true);
}
gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
|| !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
packed, gnu_size, gnu_pos,
Is_Aliased (gnat_field));
Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
TREE_THIS_VOLATILE (gnu_field) = Treat_As_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 bool
is_variable_size (tree type)
{
tree field;
if (!STRICT_ALIGNMENT)
return false;
else if (!TREE_CONSTANT (TYPE_SIZE (type)))
return true;
else if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type)
&& !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
return true;
else if (TREE_CODE (type) != RECORD_TYPE
&& TREE_CODE (type) != UNION_TYPE
&& TREE_CODE (type) != QUAL_UNION_TYPE)
return false;
for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
if (is_variable_size (TREE_TYPE (field)))
return true;
return false;
}
static void
components_to_record (tree gnu_record_type, Node_Id component_list,
tree gnu_field_list, int packed, bool definition,
tree *p_gnu_rep_list, bool cancel_alignment,
bool all_rep, bool defer_debug, bool unchecked_union)
{
Node_Id component_decl;
Entity_Id gnat_field;
Node_Id variant_part;
tree gnu_our_rep_list = NULL_TREE;
tree gnu_field, gnu_last;
bool layout_with_rep = false;
bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
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, false);
}
variant_part = Variant_Part (component_list);
if (Present (variant_part))
{
tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
Node_Id variant;
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");
tree gnu_union_type;
tree gnu_union_name;
tree gnu_union_field;
tree gnu_variant_list = NULL_TREE;
if (TREE_CODE (gnu_name) == TYPE_DECL)
gnu_name = DECL_NAME (gnu_name);
gnu_union_name = concat_id_with_name (gnu_name,
IDENTIFIER_POINTER (gnu_var_name));
if (!gnu_field_list && TREE_CODE (gnu_record_type) == UNION_TYPE)
gnu_union_type = gnu_record_type;
else
{
gnu_union_type
= make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
TYPE_NAME (gnu_union_type) = gnu_union_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 (gnu_union_name,
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);
if (all_rep_and_size)
{
TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
TYPE_SIZE_UNIT (gnu_variant_type)
= TYPE_SIZE_UNIT (gnu_record_type);
}
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
&gnu_our_rep_list, !all_rep_and_size, all_rep,
true, unchecked_union);
gnu_qual = choices_to_gnu (gnu_discriminant,
Discrete_Choices (variant));
Set_Present_Expr (variant, annotate_value (gnu_qual));
if (unchecked_union && TYPE_FIELDS (gnu_variant_type)
&& !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
gnu_field = TYPE_FIELDS (gnu_variant_type);
else
{
write_record_type_debug_info (gnu_variant_type);
gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
gnu_union_type, 0,
(all_rep_and_size
? TYPE_SIZE (gnu_record_type)
: 0),
(all_rep_and_size
? bitsize_zero_node : 0),
0);
DECL_INTERNAL_P (gnu_field) = 1;
if (!unchecked_union)
DECL_QUALIFIER (gnu_field) = gnu_qual;
}
TREE_CHAIN (gnu_field) = gnu_variant_list;
gnu_variant_list = gnu_field;
}
if (gnu_variant_list)
{
if (all_rep_and_size)
{
TYPE_SIZE (gnu_union_type) = TYPE_SIZE (gnu_record_type);
TYPE_SIZE_UNIT (gnu_union_type)
= TYPE_SIZE_UNIT (gnu_record_type);
}
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
all_rep_and_size, false);
if (gnu_union_type == gnu_record_type)
{
gcc_assert (!gnu_field_list && unchecked_union);
return;
}
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, 0);
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 = NULL_TREE; gnu_field; )
{
if (DECL_FIELD_OFFSET (gnu_field))
{
tree gnu_next = TREE_CHAIN (gnu_field);
if (!gnu_last)
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 && p_gnu_rep_list && !all_rep)
*p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
else if (gnu_our_rep_list)
{
tree gnu_rep_type
= (gnu_field_list ? make_node (RECORD_TYPE) : gnu_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;
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;
}
if (gnu_field_list)
{
finish_record_type (gnu_rep_type, gnu_our_rep_list, true, false);
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 = true;
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, defer_debug);
}
static int
compare_field_bitpos (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 DECL_UID (*t1) < DECL_UID (*t2) ? -1 : 1;
else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
return -1;
else
return 1;
}
static Uint
annotate_value (tree gnu_size)
{
int len = TREE_CODE_LENGTH (TREE_CODE (gnu_size));
TCode tcode;
Node_Ref_Or_Val ops[3], ret;
int i;
int size;
if (EXPR_P (gnu_size) && TREE_COMPLEXITY (gnu_size))
return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_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);
bool adjust = false;
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 = true;
}
temp = build1 (NEGATE_EXPR, bitsizetype, negative_size);
if (adjust)
temp = build2 (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)))
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 BIT_AND_EXPR: tcode = Bit_And_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;
}
ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
TREE_COMPLEXITY (gnu_size) = ret;
return ret;
}
static void
annotate_rep (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,
BIGGEST_ALIGNMENT);
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)))))
{
tree parent_offset = bitsize_zero_node;
gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
gnu_list);
if (gnu_entry)
{
if (type_annotate_only && Is_Tagged_Type (gnat_entity))
{
if (Is_Derived_Type (gnat_entity)
&& Original_Record_Component (gnat_field) == gnat_field)
parent_offset
= UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
bitsizetype);
else
parent_offset = bitsize_int (POINTER_SIZE);
}
Set_Component_Bit_Offset
(gnat_field,
annotate_value
(size_binop (PLUS_EXPR,
bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
TREE_VALUE (TREE_VALUE
(TREE_VALUE (gnu_entry)))),
parent_offset)));
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
}
else if (Is_Tagged_Type (gnat_entity)
&& Is_Derived_Type (gnat_entity))
{
Set_Component_Bit_Offset
(gnat_field,
Component_Bit_Offset (Original_Record_Component (gnat_field)));
Set_Esize (gnat_field,
Esize (Original_Record_Component (gnat_field)));
}
}
}
static tree
compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
tree gnu_bitpos, unsigned int offset_align)
{
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_offset = size_binop (PLUS_EXPR, gnu_pos,
DECL_FIELD_OFFSET (gnu_field));
unsigned int our_offset_align
= MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
gnu_result
= tree_cons (gnu_field,
tree_cons (gnu_our_offset,
tree_cons (size_int (our_offset_align),
gnu_our_bitpos, NULL_TREE),
NULL_TREE),
gnu_result);
if (DECL_INTERNAL_P (gnu_field))
gnu_result
= compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
gnu_our_offset, gnu_our_bitpos,
our_offset_align);
}
return gnu_result;
}
static tree
validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
enum tree_code kind, bool component_p, bool zero_ok)
{
Node_Id gnat_error_node;
tree type_size
= kind == VAR_DECL ? TYPE_SIZE (gnu_type) : rm_size (gnu_type);
tree 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 (No (uint_size) || uint_size == No_Uint)
return NULL_TREE;
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
post_error_ne (component_p ? "component size of & is too large"
: "size of & is too large",
gnat_error_node, gnat_object);
return NULL_TREE;
}
else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
return NULL_TREE;
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 NULL_TREE;
}
if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_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 (type_size && CONTAINS_PLACEHOLDER_P (type_size))
type_size = max_size (type_size, true);
else if (TYPE_FAT_POINTER_P (gnu_type))
type_size = bitsize_int (POINTER_SIZE);
if (TREE_CODE (gnu_type) == POINTER_TYPE)
{
enum machine_mode p_mode;
for (p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
!targetm.valid_pointer_mode (p_mode);
p_mode = GET_MODE_WIDER_MODE (p_mode))
;
type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
}
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 NULL_TREE;
}
return size;
}
static void
set_rm_size (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 (CONTAINS_PLACEHOLDER_P (old_size))
old_size = max_size (old_size, true);
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_NUM (gnu_type) = size;
else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE)
TYPE_RM_SIZE_NUM (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))
SET_TYPE_ADA_SIZE (gnu_type, size);
}
static tree
make_type_from_size (tree type, tree size_tree, bool biased_p)
{
tree new_type;
unsigned HOST_WIDE_INT size;
bool unsigned_p;
if (!size_tree || !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;
biased_p |= (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type));
unsigned_p = TYPE_UNSIGNED (type) || biased_p;
size = MIN (size, LONG_LONG_TYPE_SIZE);
new_type
= unsigned_p ? make_unsigned_type (size) : make_signed_type (size);
TREE_TYPE (new_type) = TREE_TYPE (type) ? 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) = biased_p;
TYPE_RM_SIZE_NUM (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 (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 (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
return align;
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 (tree object, Entity_Id gnat_entity, bool 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 (size && 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);
}
static int
compatible_signatures_p (tree ftype1, tree ftype2)
{
if (ftype1 == ftype2)
return 1;
return 1;
}
tree
gnat_substitute_in_type (tree t, tree f, tree r)
{
tree new = t;
tree tem;
switch (TREE_CODE (t))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
|| 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))
SET_TYPE_INDEX_TYPE
(new, gnat_substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
return new;
}
return t;
case REAL_TYPE:
if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
|| CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
{
tree low = NULL_TREE, high = NULL_TREE;
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 FUNCTION_TYPE:
case LANG_TYPE:
gcc_unreachable ();
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);
if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
TYPE_SIZE (new)
= size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
TYPE_SIZE (new));
if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
TYPE_SIZE_UNIT (new)
= size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
TYPE_SIZE_UNIT (new));
return new;
}
case RECORD_TYPE:
case UNION_TYPE:
case QUAL_UNION_TYPE:
{
tree field;
bool changed_field
= (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
bool field_has_rep = false;
tree last_field = NULL_TREE;
tree new = copy_type (t);
TYPE_FIELDS (new) = NULL_TREE;
TYPE_SIZE (new) = NULL_TREE;
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 = true;
else if (TREE_TYPE (new_field) != TREE_TYPE (field))
changed_field = true;
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)))
continue;
if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
{
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;
SET_DECL_ORIGINAL_FIELD (new_field,
(DECL_ORIGINAL_FIELD (field)
? DECL_ORIGINAL_FIELD (field) : field));
DECL_SIZE (new_field)
= TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
? DECL_SIZE (field) : NULL_TREE;
DECL_SIZE_UNIT (new_field)
= TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
? DECL_SIZE_UNIT (field) : NULL_TREE;
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 = true;
DECL_QUALIFIER (new_field) = new_q;
if (integer_zerop (DECL_QUALIFIER (new_field)))
continue;
}
if (!last_field)
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)
|| integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
TREE_SET_CODE (new, UNION_TYPE);
else if (!changed_field)
return t;
gcc_assert (!field_has_rep);
layout_type (new);
if (TYPE_SIZE (t) && 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);
SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
}
return new;
}
default:
return t;
}
}
tree
rm_size (tree gnu_type)
{
if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
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))
return TYPE_ADA_SIZE (gnu_type);
else
return TYPE_SIZE (gnu_type);
}
tree
create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
Entity_Kind kind = Ekind (gnat_entity);
const char *str = (!suffix ? "" : suffix);
String_Template temp = {1, strlen (str)};
Fat_Pointer fp = {str, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
if ((kind == E_Variable || kind == E_Constant)
&& Has_Stdcall_Convention (gnat_entity))
{
const char *prefix = "_imp__";
int k, plen = strlen (prefix);
for (k = 0; k <= Name_Len; k++)
Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
strncpy (Name_Buffer, prefix, plen);
}
return get_identifier (Name_Buffer);
}
tree
get_entity_name (Entity_Id gnat_entity)
{
Get_Encoded_Name (gnat_entity);
return get_identifier (Name_Buffer);
}
tree
concat_id_with_name (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);
}
#include "gt-ada-decl.h"