* *
* C Implementation File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2018, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
#include "fold-const.h"
#include "stor-layout.h"
#include "tree-inline.h"
+#include "demangle.h"
#include "ada.h"
#include "types.h"
};
/* These variables are used to defer recursively expanding incomplete types
- while we are processing an array, a record or a subprogram type. */
+ while we are processing a record, an array or a subprogram type. */
static int defer_incomplete_level = 0;
static struct incomplete *defer_incomplete_list;
-/* This variable is used to delay expanding From_Limited_With types until the
- end of the spec. */
-static struct incomplete *defer_limited_with;
+/* This variable is used to delay expanding types coming from a limited with
+ clause and completed Taft Amendment types until the end of the spec. */
+static struct incomplete *defer_limited_with_list;
typedef struct subst_pair_d {
tree discriminant;
/* The type of the variant after transformation. */
tree new_type;
-} variant_desc;
+ /* The auxiliary data. */
+ tree aux;
+} variant_desc;
-/* A hash table used to cache the result of annotate_value. */
+/* A map used to cache the result of annotate_value. */
struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
{
static inline hashval_t
static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
+/* A map used to associate a dummy type with a list of subprogram entities. */
+struct GTY((for_user)) tree_entity_vec_map
+{
+ struct tree_map_base base;
+ vec<Entity_Id, va_gc_atomic> *to;
+};
+
+void
+gt_pch_nx (Entity_Id &)
+{
+}
+
+void
+gt_pch_nx (Entity_Id *x, gt_pointer_operator op, void *cookie)
+{
+ op (x, cookie);
+}
+
+struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
+{
+ static inline hashval_t
+ hash (tree_entity_vec_map *m)
+ {
+ return htab_hash_pointer (m->base.from);
+ }
+
+ static inline bool
+ equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
+ {
+ return a->base.from == b->base.from;
+ }
+
+ static int
+ keep_cache_entry (tree_entity_vec_map *&m)
+ {
+ return ggc_marked_p (m->base.from);
+ }
+};
+
+static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
+
static void prepend_one_attribute (struct attrib **,
- enum attr_type, tree, tree, Node_Id);
+ enum attrib_type, tree, tree, Node_Id);
static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
static void prepend_attributes (struct attrib **, Entity_Id);
static tree elaborate_expression (Node_Id, Entity_Id, const char *, bool, bool,
unsigned int);
static tree elaborate_reference (tree, Entity_Id, bool, tree *);
static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
-static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
- bool *);
+static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
+static int adjust_packed (tree, tree, int);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
-static bool is_from_limited_with_of_main (Entity_Id);
+static tree gnu_ext_name_for_subprog (Entity_Id, tree);
static tree change_qualified_type (tree, int);
+static void set_nonaliased_component_on_array_type (tree);
+static void set_reverse_storage_order_on_array_type (tree);
static bool same_discriminant_p (Entity_Id, Entity_Id);
static bool array_type_has_nonaliased_component (tree, Entity_Id);
static bool compile_time_known_address_p (Node_Id);
static bool allocatable_size_p (tree, bool);
static bool initial_value_needs_conversion (tree, tree);
static int compare_field_bitpos (const PTR, const PTR);
-static bool components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
- bool, bool, bool, bool, bool, tree, tree *);
+static bool components_to_record (Node_Id, Entity_Id, tree, tree, int, bool,
+ bool, bool, bool, bool, bool, bool, tree,
+ tree *);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
static vec<subst_pair> build_subst_list (Entity_Id, Entity_Id, bool);
-static vec<variant_desc> build_variant_list (tree,
- vec<subst_pair> ,
- vec<variant_desc> );
+static vec<variant_desc> build_variant_list (tree, vec<subst_pair>,
+ vec<variant_desc>);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
static void set_rm_size (Uint, tree, Entity_Id);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
+static unsigned int promote_object_alignment (tree, Entity_Id);
static void check_ok_for_atomic_type (tree, Entity_Id, bool);
static tree create_field_decl_from (tree, tree, tree, tree, tree,
- vec<subst_pair> );
+ vec<subst_pair>);
static tree create_rep_part (tree, tree, tree);
static tree get_rep_part (tree);
-static tree create_variant_part_from (tree, vec<variant_desc> , tree,
- tree, vec<subst_pair> );
-static void copy_and_substitute_in_size (tree, tree, vec<subst_pair> );
+static tree create_variant_part_from (tree, vec<variant_desc>, tree,
+ tree, vec<subst_pair>, bool);
+static void copy_and_substitute_in_size (tree, tree, vec<subst_pair>);
+static void copy_and_substitute_in_layout (Entity_Id, Entity_Id, tree, tree,
+ vec<subst_pair>, bool);
static void associate_original_type_to_packed_array (tree, Entity_Id);
static const char *get_entity_char (Entity_Id);
initial value (in GCC tree form). This is optional for a variable. For
a renamed entity, GNU_EXPR gives the object being renamed.
- DEFINITION is nonzero if this call is intended for a definition. This is
- used for separate compilation where it is necessary to know whether an
- external declaration or a definition must be created if the GCC equivalent
- was not created previously. The value of 1 is normally used for a nonzero
- DEFINITION, but a value of 2 is used in special circumstances, defined in
- the code. */
+ DEFINITION is true if this call is intended for a definition. This is used
+ for separate compilation where it is necessary to know whether an external
+ declaration or a definition must be created if the GCC equivalent was not
+ created previously. */
tree
-gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
+gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* Contains the kind of the input GNAT node. */
const Entity_Kind kind = Ekind (gnat_entity);
/* True if this entity is to be considered as imported. */
const bool imported_p
= (Is_Imported (gnat_entity) && No (Address_Clause (gnat_entity)));
+ /* True if this entity has a foreign convention. */
+ const bool foreign = Has_Foreign_Convention (gnat_entity);
/* For a type, contains the equivalent GNAT node to be used in gigi. */
Entity_Id gnat_equiv_type = Empty;
/* Temporary used to walk the GNAT tree. */
/* Contains the list of attributes directly attached to the entity. */
struct attrib *attr_list = NULL;
- /* Since a use of an Itype is a definition, process it as such if it
- is not in a with'ed unit. */
+ /* Since a use of an Itype is a definition, process it as such if it is in
+ the main unit, except for E_Access_Subtype because it's actually a use
+ of its base type, and for E_Record_Subtype with cloned subtype because
+ it's actually a use of the cloned subtype, see below. */
if (!definition
&& is_type
&& Is_Itype (gnat_entity)
+ && !(kind == E_Access_Subtype
+ || (kind == E_Record_Subtype
+ && Present (Cloned_Subtype (gnat_entity))))
&& !present_gnu_tree (gnat_entity)
&& In_Extended_Main_Code_Unit (gnat_entity))
{
gnat_temp
= Corresponding_Spec (Parent (Declaration_Node (gnat_temp)));
- if (IN (Ekind (gnat_temp), Subprogram_Kind)
+ if (Is_Subprogram (gnat_temp)
&& 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)
+ || (Is_Subprogram (gnat_temp)
&& present_gnu_tree (gnat_temp)
&& (current_function_decl
- == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
+ == gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))))
{
process_type (gnat_entity);
return get_gnu_tree (gnat_entity);
|| No (Freeze_Node (Full_View (gnat_entity)))))
{
gnu_decl
- = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
+ = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, false);
save_gnu_tree (gnat_entity, NULL_TREE, false);
save_gnu_tree (gnat_entity, gnu_decl, false);
}
must be specified unless it was specified by the programmer. Exceptions
are for access-to-protected-subprogram types and all access subtypes, as
another GNAT type is used to lay out the GCC type for them. */
- gcc_assert (!Unknown_Esize (gnat_entity)
+ gcc_assert (!is_type
+ || Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
|| (!IN (kind, Numeric_Kind)
&& !IN (kind, Enumeration_Kind)
inherit another source location. */
gnu_entity_name = get_entity_name (gnat_entity);
if (Sloc (gnat_entity) != No_Location
- && !renaming_from_generic_instantiation_p (gnat_entity))
+ && !renaming_from_instantiation_p (gnat_entity))
Sloc_to_locus (Sloc (gnat_entity), &input_location);
/* For cases when we are not defining (i.e., we are referencing from
/* If the entity is a discriminant of an extended tagged type used to
rename a discriminant of the parent type, return the latter. */
- if (Is_Tagged_Type (gnat_record)
- && Present (Corresponding_Discriminant (gnat_entity)))
+ if (kind == E_Discriminant
+ && Present (Corresponding_Discriminant (gnat_entity))
+ && Is_Tagged_Type (gnat_record))
{
gnu_decl
= gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
be a FIELD_DECL. Likewise for discriminants. If the entity is a
non-girder discriminant (in the case of derived untagged record
types), return the stored discriminant it renames. */
- else if (Present (Original_Record_Component (gnat_entity))
- && Original_Record_Component (gnat_entity) != 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;
+ /* GNU_DECL contains a PLACEHOLDER_EXPR for discriminants. */
+ if (kind == E_Discriminant)
+ saved = true;
break;
}
/* Otherwise, if we are not defining this and we have no GCC type
for the containing record, make one for it. Then we should
have made our own equivalent. */
- else if (!definition && !present_gnu_tree (gnat_record))
+ if (!definition && !present_gnu_tree (gnat_record))
{
/* ??? If this is in a record whose scope is a protected
type and we have an Original_Record_Component, use it.
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component
(gnat_entity),
- gnu_expr, 0);
- saved = true;
- break;
+ gnu_expr, false);
+ }
+ else
+ {
+ gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, false);
+ gnu_decl = get_gnu_tree (gnat_entity);
}
- gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
- gnu_decl = get_gnu_tree (gnat_entity);
saved = true;
break;
}
- else
- /* Here we have no GCC type and this is a reference rather than a
- definition. This should never happen. Most likely the cause is
- reference before declaration in the GNAT tree for gnat_entity. */
- gcc_unreachable ();
+ /* Here we have no GCC type and this is a reference rather than a
+ definition. This should never happen. Most likely the cause is
+ reference before declaration in the GNAT tree for gnat_entity. */
+ gcc_unreachable ();
}
case E_Constant:
&& Present (Full_View (gnat_entity)))
{
gnu_decl
- = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
+ = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, false);
saved = true;
break;
}
was defined to represent. This is necessary to avoid generating dumb
elaboration code in simple cases, but we may throw it away later if it
is not a constant. But do not retrieve it if it is an allocator since
- the designated type might still be dummy at this point. */
+ the designated type might still be dummy at this point. Note that we
+ invoke gnat_to_gnu_external and not gnat_to_gnu because the expression
+ may contain N_Expression_With_Actions nodes and thus declarations of
+ objects from other units that we need to discard. */
if (!definition
&& !No_Initialization (Declaration_Node (gnat_entity))
- && Present (Expression (Declaration_Node (gnat_entity)))
- && Nkind (Expression (Declaration_Node (gnat_entity)))
- != N_Allocator)
- {
- bool went_into_elab_proc = false;
- int save_force_global = force_global;
-
- /* The expression may contain N_Expression_With_Actions nodes and
- thus object declarations from other units. In this case, even
- though the expression will eventually be discarded since not a
- constant, the declarations would be stuck either in the global
- varpool or in the current scope. Therefore we force the local
- context and create a fake scope that we'll zap at the end. */
- if (!current_function_decl)
- {
- current_function_decl = get_elaboration_procedure ();
- went_into_elab_proc = true;
- }
- force_global = 0;
- gnat_pushlevel ();
-
- gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
-
- gnat_zaplevel ();
- force_global = save_force_global;
- if (went_into_elab_proc)
- current_function_decl = NULL_TREE;
- }
+ && Present (gnat_temp = Expression (Declaration_Node (gnat_entity)))
+ && Nkind (gnat_temp) != N_Allocator
+ && (!type_annotate_only || Compile_Time_Known_Value (gnat_temp)))
+ gnu_expr = gnat_to_gnu_external (gnat_temp);
/* ... fall through ... */
case E_Out_Parameter:
case E_Variable:
{
+ const Entity_Id gnat_type = Etype (gnat_entity);
/* Always create a variable for volatile objects and variables seen
constant but with a Linker_Section pragma. */
bool const_flag
tree renamed_obj = NULL_TREE;
tree gnu_object_size;
+ /* We need to translate the renamed object even though we are only
+ referencing the renaming. But it may contain a call for which
+ we'll generate a temporary to hold the return value and which
+ is part of the definition of the renaming, so discard it. */
if (Present (Renamed_Object (gnat_entity)) && !definition)
{
if (kind == E_Exception)
gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
else
- gnu_expr = gnat_to_gnu (Renamed_Object (gnat_entity));
+ gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
}
/* Get the type after elaborating the renamed object. */
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
-
- /* If this is a standard exception definition, then use the standard
- exception type. This is necessary to make sure that imported and
- exported views of exceptions are properly merged in LTO mode. */
- if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
- && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
- gnu_type = except_type_node;
+ if (foreign && Is_Descendant_Of_Address (Underlying_Type (gnat_type)))
+ gnu_type = ptr_type_node;
+ else
+ {
+ gnu_type = gnat_to_gnu_type (gnat_type);
+
+ /* If this is a standard exception definition, use the standard
+ exception type. This is necessary to make sure that imported
+ and exported views of exceptions are merged in LTO mode. */
+ if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
+ gnu_type = except_type_node;
+ }
/* For a debug renaming declaration, build a debug-only entity. */
if (Present (Debug_Renaming_Link (gnat_entity)))
VAR_DECL, gnu_entity_name, gnu_type);
SET_DECL_VALUE_EXPR (gnu_decl, value);
DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
+ TREE_STATIC (gnu_decl) = global_bindings_p ();
gnat_pushdecl (gnu_decl, gnat_entity);
break;
}
}
/* If an alignment is specified, use it if valid. Note that exceptions
- are objects but don't have an alignment. We must do this before we
- validate the size, since the alignment can affect the size. */
- 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));
-
- /* No point in changing the type if there is an address clause
- as the final type of the object will be a reference type. */
- if (Present (Address_Clause (gnat_entity)))
- align = 0;
- else
- {
- tree orig_type = gnu_type;
-
- gnu_type
- = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
- false, false, definition, true);
-
- /* If a padding record was made, declare it now since it will
- never be declared otherwise. This is necessary to ensure
- that its subtrees are properly marked. */
- if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
- create_type_decl (TYPE_NAME (gnu_type), gnu_type, true,
- debug_info_p, gnat_entity);
- }
- }
-
- /* If we are defining the object, see if it has a Size and validate it
- if so. If we are not defining the object and a Size clause applies,
- simply retrieve the value. We don't want to ignore the clause and
- it is expected to have been validated already. Then get the new
- type, if any. */
- 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);
+ are objects but don't have an alignment and there is also no point in
+ setting it for an address clause, since the final type of the object
+ will be a reference type. */
+ if (Known_Alignment (gnat_entity)
+ && kind != E_Exception
+ && No (Address_Clause (gnat_entity)))
+ align = validate_alignment (Alignment (gnat_entity), gnat_entity,
+ TYPE_ALIGN (gnu_type));
+ /* Likewise, if a size is specified, use it if valid. */
+ if (Known_Esize (gnat_entity))
+ gnu_size
+ = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
+ VAR_DECL, false, Has_Size_Clause (gnat_entity));
if (gnu_size)
{
gnu_type
mutable_p = true;
}
- /* If we are at global level and the size isn't constant, call
+ /* If the size isn't constant and we are at global level, call
elaborate_expression_1 to make a variable for it rather than
calculating it each time. */
- if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
+ if (!TREE_CONSTANT (gnu_size) && global_bindings_p ())
gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
"SIZE", definition, false);
}
|| (TYPE_SIZE (gnu_type)
&& integer_zerop (TYPE_SIZE (gnu_type))
&& !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
- && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& No (Renamed_Object (gnat_entity))
&& No (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
|| (!Optimize_Alignment_Space (gnat_entity)
&& kind != E_Exception
&& kind != E_Out_Parameter
- && Is_Composite_Type (Etype (gnat_entity))
- && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && Is_Composite_Type (gnat_type)
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& !Is_Exported (gnat_entity)
&& !imported_p
&& No (Renamed_Object (gnat_entity))
&& No (Address_Clause (gnat_entity))))
&& TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
- {
- unsigned int size_cap, align_cap;
-
- /* No point in promoting the alignment if this doesn't prevent
- BLKmode access to the object, in particular block copy, as
- this will for example disable the NRV optimization for it.
- No point in jumping through all the hoops needed in order
- to support BIGGEST_ALIGNMENT if we don't really have to.
- So we cap to the smallest alignment that corresponds to
- a known efficient memory access pattern of the target. */
- if (Is_Atomic_Or_VFA (gnat_entity))
- {
- size_cap = UINT_MAX;
- align_cap = BIGGEST_ALIGNMENT;
- }
- else
- {
- size_cap = MAX_FIXED_MODE_SIZE;
- align_cap = get_mode_alignment (ptr_mode);
- }
-
- if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
- || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
- align = 0;
- else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
- align = align_cap;
- else
- align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
-
- /* But make sure not to under-align the object. */
- if (align <= TYPE_ALIGN (gnu_type))
- align = 0;
-
- /* And honor the minimum valid atomic alignment, if any. */
-#ifdef MINIMUM_ATOMIC_ALIGNMENT
- else if (align < MINIMUM_ATOMIC_ALIGNMENT)
- align = MINIMUM_ATOMIC_ALIGNMENT;
-#endif
- }
+ align = promote_object_alignment (gnu_type, gnat_entity);
/* If the object is set to have atomic components, find the component
type and validate it.
/* If this is an aliased object with an unconstrained array nominal
subtype, make a type that includes the template. We will either
allocate or create a variable of that type, see below. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
- tree gnu_array
- = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+ tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
gnu_type
= build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
gnu_type,
without pessimizing the allocation. This is a kludge necessary
because we don't support dynamic alignment. */
if (align == 0
- && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype
+ && Ekind (gnat_type) == E_Class_Wide_Subtype
&& No (Renamed_Object (gnat_entity))
&& No (Address_Clause (gnat_entity)))
align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
inner = TREE_OPERAND (inner, 0);
/* Expand_Dispatching_Call can prepend a comparison of the tags
before the call to "=". */
- if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR)
+ if (TREE_CODE (inner) == TRUTH_ANDIF_EXPR
+ || TREE_CODE (inner) == COMPOUND_EXPR)
inner = TREE_OPERAND (inner, 1);
if ((TREE_CODE (inner) == CALL_EXPR
&& !call_is_atomic_load (inner))
|| TREE_CODE (inner) == ADDR_EXPR
|| TREE_CODE (inner) == NULL_EXPR
+ || TREE_CODE (inner) == PLUS_EXPR
|| TREE_CODE (inner) == CONSTRUCTOR
- || CONSTANT_CLASS_P (inner))
+ || CONSTANT_CLASS_P (inner)
+ /* We need to detect the case where a temporary is created to
+ hold the return value, since we cannot safely rename it at
+ top level as it lives only in the elaboration routine. */
+ || (TREE_CODE (inner) == VAR_DECL
+ && DECL_RETURN_VALUE_P (inner))
+ /* We also need to detect the case where the front-end creates
+ a dangling 'reference to a function call at top level and
+ substitutes it in the renaming, for example:
+
+ q__b : boolean renames r__f.e (1);
+
+ can be rewritten into:
+
+ q__R1s : constant q__A2s := r__f'reference;
+ [...]
+ q__b : boolean renames q__R1s.all.e (1);
+
+ We cannot safely rename the rewritten expression since the
+ underlying object lives only in the elaboration routine. */
+ || (TREE_CODE (inner) == INDIRECT_REF
+ && (inner
+ = remove_conversions (TREE_OPERAND (inner, 0), true))
+ && TREE_CODE (inner) == VAR_DECL
+ && DECL_RETURN_VALUE_P (inner)))
;
/* Case 2: if the renaming entity need not be materialized, use
means that the caller is responsible for evaluating the address
of the renaming in the correct place for the definition case to
instantiate the SAVE_EXPRs. */
- else if (TREE_CODE (inner) != COMPOUND_EXPR
- && !Materialize_Entity (gnat_entity))
+ else if (!Materialize_Entity (gnat_entity))
{
tree init = NULL_TREE;
&init);
/* We cannot evaluate the first arm of a COMPOUND_EXPR in the
- correct place for this case, hence the above test. */
- gcc_assert (init == NULL_TREE);
+ correct place for this case. */
+ gcc_assert (!init);
/* No DECL_EXPR will be created so the expression needs to be
marked manually because it will likely be shared. */
gcc_assert (ralign >= align);
}
+ /* The expression might not be a DECL so save it manually. */
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
= elaborate_reference (gnu_expr, gnat_entity, definition,
&init);
- /* If we are not defining the entity, the expression will not
- be attached through DECL_INITIAL so it needs to be marked
- manually because it will likely be shared. Likewise for a
- dereference as it will be folded by the ADDR_EXPR below. */
- if ((!definition || TREE_CODE (renamed_obj) == INDIRECT_REF)
- && global_bindings_p ())
+ /* The expression needs to be marked manually because it will
+ likely be shared, even for a definition since the ADDR_EXPR
+ built below can cause the first few nodes to be folded. */
+ if (global_bindings_p ())
MARK_VISITED (renamed_obj);
if (type_annotate_only
if (definition && Present (Address_Clause (gnat_entity)))
{
const Node_Id gnat_clause = Address_Clause (gnat_entity);
- Node_Id gnat_expr = Expression (gnat_clause);
+ Node_Id gnat_address = Expression (gnat_clause);
tree gnu_address
= present_gnu_tree (gnat_entity)
- ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
+ ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_address);
save_gnu_tree (gnat_entity, NULL_TREE, false);
used_by_ref = true;
const_flag
= (!Is_Public (gnat_entity)
- || compile_time_known_address_p (gnat_expr));
+ || compile_time_known_address_p (gnat_address));
volatile_flag = false;
gnu_size = NULL_TREE;
/* If this is an aliased object with an unconstrained array nominal
subtype, then it can overlay only another aliased object with an
unconstrained array nominal subtype and compatible template. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
tree rec_type = TREE_TYPE (gnu_type);
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
if (TREE_CODE (gnu_expr) == CONSTRUCTOR
- && vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr)) == 1)
+ && CONSTRUCTOR_NELTS (gnu_expr) == 1)
gnu_expr = NULL_TREE;
else
gnu_expr
than the largest stack alignment the back-end can honor, resort to
a variable of "aligning type". */
if (definition
- && !global_bindings_p ()
- && !static_flag
+ && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT
&& !imported_p
- && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
+ && !static_flag
+ && !global_bindings_p ())
{
/* Create the new variable. No need for extra room before the
aligned field as this is in automatic storage. */
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
NULL_TREE, gnu_new_type, NULL_TREE,
false, false, false, false, false,
- true, debug_info_p, NULL, gnat_entity);
+ true, debug_info_p && definition, NULL,
+ gnat_entity);
/* Initialize the aligned field if we have an initializer. */
if (gnu_expr)
gnu_size = NULL_TREE;
}
+ /* If this is an aggregate constant initialized to a constant, force it
+ to be statically allocated. This saves an initialization copy. */
+ if (!static_flag
+ && const_flag
+ && gnu_expr
+ && TREE_CONSTANT (gnu_expr)
+ && AGGREGATE_TYPE_P (gnu_type)
+ && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
+ && !(TYPE_IS_PADDING_P (gnu_type)
+ && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
+ (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
+ static_flag = true;
+
/* If this is an aliased object with an unconstrained array nominal
subtype, we make its type a thin reference, i.e. the reference
counterpart of a thin pointer, so it points to the array part.
This is aimed to make it easier for the debugger to decode the
object. Note that we have to do it this late because of the
couple of allocation adjustments that might be made above. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
/* In case the object with the template has already been allocated
NULL_TREE, gnu_type, gnu_expr,
const_flag, Is_Public (gnat_entity),
imported_p || !definition, static_flag,
- volatile_flag, true, debug_info_p,
+ volatile_flag, true,
+ debug_info_p && definition,
NULL, gnat_entity);
gnu_expr = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
TREE_CONSTANT (gnu_expr) = 1;
gnu_size = NULL_TREE;
}
- tree gnu_array
- = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+ tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
gnu_type
= build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
}
- if (const_flag)
- gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
-
/* Convert the expression to the type of the object if need be. */
if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
gnu_expr = convert (gnu_type, gnu_expr);
&& No (Address_Clause (gnat_entity))))
gnu_ext_name = create_concat_name (gnat_entity, NULL);
- /* If this is an aggregate constant initialized to a constant, force it
- to be statically allocated. This saves an initialization copy. */
- if (!static_flag
- && const_flag
- && gnu_expr && TREE_CONSTANT (gnu_expr)
- && AGGREGATE_TYPE_P (gnu_type)
- && tree_fits_uhwi_p (TYPE_SIZE_UNIT (gnu_type))
- && !(TYPE_IS_PADDING_P (gnu_type)
- && !tree_fits_uhwi_p (TYPE_SIZE_UNIT
- (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
- static_flag = true;
-
/* Deal with a pragma Linker_Section on a constant or variable. */
if ((kind == E_Constant || kind == E_Variable)
&& Present (Linker_Section_Pragma (gnat_entity)))
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, const_flag, Is_Public (gnat_entity),
imported_p || !definition, static_flag,
- volatile_flag, artificial_p, debug_info_p,
- attr_list, gnat_entity, !renamed_obj);
+ volatile_flag, artificial_p,
+ debug_info_p && definition, attr_list,
+ gnat_entity, !renamed_obj);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
&& !optimize
&& !flag_generate_lto)
{
- tree param = create_param_decl (gnu_entity_name, gnu_type, false);
+ tree param = create_param_decl (gnu_entity_name, gnu_type);
gnat_pushdecl (param, gnat_entity);
SET_DECL_VALUE_EXPR (param, gnu_decl);
DECL_HAS_VALUE_EXPR_P (param) = 1;
&& No (Address_Clause (gnat_entity)))
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
- || Is_Aliased (Etype (gnat_entity))))
+ || Is_Aliased (gnat_type)))
{
tree gnu_corr_var
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, true, Is_Public (gnat_entity),
!definition, static_flag, volatile_flag,
- artificial_p, debug_info_p, attr_list,
- gnat_entity, false);
+ artificial_p, debug_info_p && definition,
+ attr_list, gnat_entity, false);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
case E_Enumeration_Type:
/* A special case: for the types Character and Wide_Character in
Standard, we do not list all the literals. So if the literals
- are not specified, make this an unsigned integer type. */
+ are not specified, make this an integer type. */
if (No (First_Literal (gnat_entity)))
{
- gnu_type = make_unsigned_type (esize);
+ if (esize == CHAR_TYPE_SIZE && flag_signed_char)
+ gnu_type = make_signed_type (CHAR_TYPE_SIZE);
+ else
+ gnu_type = make_unsigned_type (esize);
TYPE_NAME (gnu_type) = gnu_entity_name;
/* Set TYPE_STRING_FLAG for Character and Wide_Character types.
This is needed by the DWARF-2 back-end to distinguish between
unsigned integer types and character types. */
TYPE_STRING_FLAG (gnu_type) = 1;
+
+ /* This flag is needed by the call just below. */
+ TYPE_ARTIFICIAL (gnu_type) = artificial_p;
+
+ finish_character_type (gnu_type);
}
else
{
tree gnu_list = NULL_TREE;
Entity_Id gnat_literal;
+ /* Boolean types with foreign convention have precision 1. */
+ if (is_boolean && foreign)
+ esize = 1;
+
gnu_type = make_node (is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
TYPE_PRECISION (gnu_type) = esize;
TYPE_UNSIGNED (gnu_type) = is_unsigned;
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));
+ build_int_cst (gnu_type, 1));
}
/* If the upper bound is not maximal, make an extra subtype. */
&& !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, 0);
+ gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
/* Set the precision to the Esize except for bit-packed arrays. */
if (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
esize = UI_To_Int (RM_Size (gnat_entity));
- /* This should be an unsigned type if the base type is unsigned or
+ /* Boolean types with foreign convention have precision 1. */
+ if (Is_Boolean_Type (gnat_entity) && foreign)
+ {
+ gnu_type = make_node (BOOLEAN_TYPE);
+ TYPE_PRECISION (gnu_type) = 1;
+ TYPE_UNSIGNED (gnu_type) = 1;
+ set_min_and_max_values_for_integral_type (gnu_type, 1, UNSIGNED);
+ layout_type (gnu_type);
+ }
+ /* First subtypes of Character are treated as Character; otherwise
+ this should be an unsigned type if the base type is unsigned or
if the lower bound is constant and non-negative or if the type
- is biased. */
- if (Is_Unsigned_Type (Etype (gnat_entity))
- || Is_Unsigned_Type (gnat_entity)
- || Has_Biased_Representation (gnat_entity))
+ is biased. However, even if the lower bound is constant and
+ non-negative, we use a signed type for a subtype with the same
+ size as its signed base type, because this eliminates useless
+ conversions to it and gives more leeway to the optimizer; but
+ this means that we will need to explicitly test for this case
+ when we change the representation based on the RM size. */
+ else if (kind == E_Enumeration_Subtype
+ && No (First_Literal (Etype (gnat_entity)))
+ && Esize (gnat_entity) == RM_Size (gnat_entity)
+ && esize == CHAR_TYPE_SIZE
+ && flag_signed_char)
+ gnu_type = make_signed_type (CHAR_TYPE_SIZE);
+ else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity)))
+ || (Esize (Etype (gnat_entity)) != Esize (gnat_entity)
+ && Is_Unsigned_Type (gnat_entity))
+ || Has_Biased_Representation (gnat_entity))
gnu_type = make_unsigned_type (esize);
else
gnu_type = make_signed_type (esize);
gnat_entity, "U", definition, true,
debug_info_p));
- TYPE_BIASED_REPRESENTATION_P (gnu_type)
- = Has_Biased_Representation (gnat_entity);
+ if (TREE_CODE (gnu_type) == INTEGER_TYPE)
+ TYPE_BIASED_REPRESENTATION_P (gnu_type)
+ = Has_Biased_Representation (gnat_entity);
+
+ /* Do the same processing for Character subtypes as for types. */
+ if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
+ {
+ TYPE_NAME (gnu_type) = gnu_entity_name;
+ TYPE_STRING_FLAG (gnu_type) = 1;
+ TYPE_ARTIFICIAL (gnu_type) = artificial_p;
+ finish_character_type (gnu_type);
+ }
/* Inherit our alias set from what we're a subtype of. Subtypes
are not different types and a pointer can designate any instance
UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
- /* Strip the ___XP suffix for standard DWARF. */
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- gnu_entity_name = TYPE_NAME (gnu_type);
-
/* Create a stripped-down declaration, mainly for debugging. */
create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
gnat_entity);
This means that bit-packed arrays are given "ceil" alignment for
their size by default, which may seem counter-intuitive but makes
it possible to overlay them on modular types easily. */
- TYPE_ALIGN (gnu_type)
- = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
+ SET_TYPE_ALIGN (gnu_type,
+ align > 0 ? align : TYPE_ALIGN (gnu_field_type));
/* Propagate the reverse storage order flag to the record type so
that the required byte swapping is performed when retrieving the
= create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
- /* Do not emit debug info until after the parallel type is added. */
+ /* We will output additional debug info manually below. */
finish_record_type (gnu_type, gnu_field, 2, false);
- compute_record_mode (gnu_type);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
if (debug_info_p)
implementation type, the padded type is its debug type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
-
- rest_of_record_type_compilation (gnu_type);
}
}
/* If the type we are dealing with has got a smaller alignment than the
natural one, we need to wrap it up in a record type and misalign the
- latter; we reuse the padding machinery for this purpose. Note that,
- even if the record type is marked as packed because of misalignment,
- we don't pack the field so as to give it the size of the type. */
+ latter; we reuse the padding machinery for this purpose. */
else if (align > 0)
{
- tree gnu_field_type, gnu_field;
-
- /* Set the RM size before wrapping up the type. */
- SET_TYPE_RM_SIZE (gnu_type,
- UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
+ tree gnu_size = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
- /* Create a stripped-down declaration, mainly for debugging. */
- create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
- gnat_entity);
+ /* Set the RM size before wrapping the type. */
+ SET_TYPE_RM_SIZE (gnu_type, gnu_size);
- /* Now save it and build the enclosing record type. */
- gnu_field_type = gnu_type;
+ gnu_type
+ = maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
+ gnat_entity, false, true, definition, false);
- gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
- TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
- TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
- TYPE_ALIGN (gnu_type) = align;
- relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
-
- /* Don't declare the field as addressable since we won't be taking
- its address and this would prevent create_field_decl from making
- a bitfield. */
- gnu_field
- = create_field_decl (get_identifier ("F"), gnu_field_type,
- gnu_type, TYPE_SIZE (gnu_field_type),
- bitsize_zero_node, 0, 0);
-
- finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
- compute_record_mode (gnu_type);
- TYPE_PADDING_P (gnu_type) = 1;
+ SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
}
break;
&& !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, 0);
+ gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
gnu_type = make_node (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
{
gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
TYPE_NAME (gnu_fat_type) = NULL_TREE;
- /* Save the contents of the dummy type for update_pointer_to. */
- TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
gnu_ptr_template =
- TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
+ TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
gnu_template_type = TREE_TYPE (gnu_ptr_template);
+
+ /* Save the contents of the dummy type for update_pointer_to. */
+ TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
+ TYPE_FIELDS (TYPE_POINTER_TO (gnu_type))
+ = copy_node (TYPE_FIELDS (gnu_fat_type));
+ DECL_CHAIN (TYPE_FIELDS (TYPE_POINTER_TO (gnu_type)))
+ = copy_node (DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)));
}
else
{
/* Build the fat pointer type. Use a "void *" object instead of
a pointer to the array type since we don't have the array type
- yet (it will reference the fat pointer via the bounds). */
- tem
- = create_field_decl (get_identifier ("P_ARRAY"), ptr_type_node,
- gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
- DECL_CHAIN (tem)
- = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
- gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
-
+ yet (it will reference the fat pointer via the bounds). Note
+ that we reuse the existing fields of a dummy type because for:
+
+ type Arr is array (Positive range <>) of Element_Type;
+ type Array_Ref is access Arr;
+ Var : Array_Ref := Null;
+
+ in a declarative part, Arr will be frozen only after Var, which
+ means that the fields used in the CONSTRUCTOR built for Null are
+ those of the dummy type, which in turn means that COMPONENT_REFs
+ of Var may be built with these fields. Now if COMPONENT_REFs of
+ Var are also built later with the fields of the final type, the
+ aliasing machinery may consider that the accesses are distinct
+ if the FIELD_DECLs are distinct as objects. */
if (COMPLETE_TYPE_P (gnu_fat_type))
{
- /* We are going to lay it out again so reset the alias set. */
- alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
- TYPE_ALIAS_SET (gnu_fat_type) = -1;
- finish_fat_pointer_type (gnu_fat_type, tem);
- TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
+ tem = TYPE_FIELDS (gnu_fat_type);
+ TREE_TYPE (tem) = ptr_type_node;
+ TREE_TYPE (DECL_CHAIN (tem)) = gnu_ptr_template;
+ TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (gnu_fat_type)) = 0;
for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
- {
- TYPE_FIELDS (t) = tem;
- SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
- }
+ SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
}
else
{
+ tem
+ = create_field_decl (get_identifier ("P_ARRAY"),
+ ptr_type_node, gnu_fat_type,
+ NULL_TREE, NULL_TREE, 0, 0);
+ DECL_CHAIN (tem)
+ = create_field_decl (get_identifier ("P_BOUNDS"),
+ gnu_ptr_template, gnu_fat_type,
+ NULL_TREE, NULL_TREE, 0, 0);
finish_fat_pointer_type (gnu_fat_type, tem);
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
}
index to the template. */
for (index = (convention_fortran_p ? ndim - 1 : 0),
gnat_index = First_Index (gnat_entity);
- 0 <= index && index < ndim;
+ IN_RANGE (index, 0, ndim - 1);
index += (convention_fortran_p ? - 1 : 1),
gnat_index = Next_Index (gnat_index))
{
char field_name[16];
+ tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_index_base_type
- = get_unpadded_type (Base_Type (Etype (gnat_index)));
+ = maybe_character_type (get_base_type (gnu_index_type));
tree gnu_lb_field, gnu_hb_field, gnu_orig_min, gnu_orig_max;
tree gnu_min, gnu_max, gnu_high;
/* Update the maximum size of the array in elements. */
if (gnu_max_size)
{
- tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
tree gnu_min
= convert (sizetype, TYPE_MIN_VALUE (gnu_index_type));
tree gnu_max
for (index = ndim - 1; index >= 0; index--)
{
tem = build_nonshared_array_type (tem, gnu_index_types[index]);
- if (index == ndim - 1)
- TYPE_REVERSE_STORAGE_ORDER (tem)
- = Reverse_Storage_Order (gnat_entity);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
+ TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
+ if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
+ set_reverse_storage_order_on_array_type (tem);
if (array_type_has_nonaliased_component (tem, gnat_entity))
- TYPE_NONALIASED_COMPONENT (tem) = 1;
+ set_nonaliased_component_on_array_type (tem);
}
/* If an alignment is specified, use it if valid. But ignore it
if (No (Packed_Array_Impl_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
- TYPE_ALIGN (tem)
- = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (tem));
+ SET_TYPE_ALIGN (tem,
+ validate_alignment (Alignment (gnat_entity),
+ gnat_entity,
+ TYPE_ALIGN (tem)));
if (Present (Alignment_Clause (gnat_entity)))
TYPE_USER_ALIGN (tem) = 1;
}
- TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
-
/* Tag top-level ARRAY_TYPE nodes for packed arrays and their
implementation types as such so that the debug information back-end
can output the appropriate description for them. */
TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
SET_TYPE_MODE (gnu_type, BLKmode);
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
/* If the maximum size doesn't overflow, use it. */
if (gnu_max_size
gnat_name = Packed_Array_Impl_Type (gnat_entity);
else
gnat_name = gnat_entity;
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
- gnu_entity_name = create_concat_name (gnat_name, "XUP");
- create_type_decl (gnu_entity_name, gnu_fat_type, artificial_p,
- debug_info_p, gnat_entity);
+ tree xup_name
+ = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? get_entity_name (gnat_name)
+ : create_concat_name (gnat_name, "XUP");
+ create_type_decl (xup_name, gnu_fat_type, artificial_p, debug_info_p,
+ gnat_entity);
/* Create the type to be designated by thin pointers: a record type for
the array and its template. We used to shift the fields to have the
Note that GDB can handle standard DWARF information for them, so we
don't have to name them as a GNAT encoding, except if specifically
asked to. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
- gnu_entity_name = create_concat_name (gnat_name, "XUT");
- else
- gnu_entity_name = get_entity_name (gnat_name);
- tem = build_unc_object_type (gnu_template_type, tem, gnu_entity_name,
+ tree xut_name
+ = (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ ? get_entity_name (gnat_name)
+ : create_concat_name (gnat_name, "XUT");
+ tem = build_unc_object_type (gnu_template_type, tem, xut_name,
debug_info_p);
SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
gnat_index = First_Index (gnat_entity),
gnat_base_index
= First_Index (Implementation_Base_Type (gnat_entity));
- 0 <= index && index < ndim;
+ IN_RANGE (index, 0, ndim - 1);
index += (convention_fortran_p ? - 1 : 1),
gnat_index = Next_Index (gnat_index),
gnat_base_index = Next_Index (gnat_base_index))
{
tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
- tree gnu_index_base_type = get_base_type (gnu_index_type);
+ tree gnu_index_base_type
+ = maybe_character_type (get_base_type (gnu_index_type));
tree gnu_orig_min
= convert (gnu_index_base_type,
TYPE_MIN_VALUE (gnu_index_type));
tree gnu_base_index_type
= get_unpadded_type (Etype (gnat_base_index));
tree gnu_base_index_base_type
- = get_base_type (gnu_base_index_type);
+ = maybe_character_type (get_base_type (gnu_base_index_type));
tree gnu_base_orig_min
= convert (gnu_base_index_base_type,
TYPE_MIN_VALUE (gnu_base_index_type));
{
tree gnu_base_min = convert (sizetype, gnu_base_orig_min);
tree gnu_base_max = convert (sizetype, gnu_base_orig_max);
- tree gnu_base_index_base_type
- = get_base_type (gnu_base_index_type);
tree gnu_base_base_min
= convert (sizetype,
TYPE_MIN_VALUE (gnu_base_index_base_type));
types, are biased or are wider than sizetype. These are GNAT
encodings, so we have to include them only when all encodings
are requested. */
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL
- && (TREE_CODE (gnu_orig_min) != INTEGER_CST
- || TREE_CODE (gnu_orig_max) != INTEGER_CST
- || TREE_CODE (gnu_index_type) != INTEGER_TYPE
- || (TREE_TYPE (gnu_index_type)
- && TREE_CODE (TREE_TYPE (gnu_index_type))
- != INTEGER_TYPE)
- || TYPE_BIASED_REPRESENTATION_P (gnu_index_type)))
+ if ((TREE_CODE (gnu_orig_min) != INTEGER_CST
+ || TREE_CODE (gnu_orig_max) != INTEGER_CST
+ || TREE_CODE (gnu_index_type) != INTEGER_TYPE
+ || (TREE_TYPE (gnu_index_type)
+ && TREE_CODE (TREE_TYPE (gnu_index_type))
+ != INTEGER_TYPE)
+ || TYPE_BIASED_REPRESENTATION_P (gnu_index_type))
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
need_index_type_struct = true;
}
{
gnu_type = build_nonshared_array_type (gnu_type,
gnu_index_types[index]);
- if (index == ndim - 1)
- TYPE_REVERSE_STORAGE_ORDER (gnu_type)
- = Reverse_Storage_Order (gnat_entity);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
+ TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
+ if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
+ set_reverse_storage_order_on_array_type (gnu_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
- TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
- }
-
- /* Strip the ___XP suffix for standard DWARF. */
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL
- && Is_Packed_Array_Impl_Type (gnat_entity))
- {
- Entity_Id gnat_original_array_type
- = Underlying_Type (Original_Array_Type (gnat_entity));
-
- gnu_entity_name
- = get_entity_name (gnat_original_array_type);
+ set_nonaliased_component_on_array_type (gnu_type);
}
/* Attach the TYPE_STUB_DECL in case we have a parallel type. */
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (gnu_entity_name, gnu_type);
- /* If we are at file level and this is a multi-dimensional array,
+ /* If this is a multi-dimensional array and we are at global level,
we need to make a variable corresponding to the stride of the
inner dimensions. */
- if (global_bindings_p () && ndim > 1)
+ if (ndim > 1 && global_bindings_p ())
{
tree gnu_arr_type;
else
{
tree gnu_base_decl
- = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
- if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL
- && !DECL_ARTIFICIAL (gnu_base_decl))
+ = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
+ false);
+ if (!DECL_ARTIFICIAL (gnu_base_decl)
+ && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
add_parallel_type (gnu_type,
TREE_TYPE (TREE_TYPE (gnu_base_decl)));
}
}
- TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
array subtypes the same alias set. */
relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
- /* If this is a packed type, make this type the same as the packed
- array type, but do some adjusting in the type first. */
+ /* If this is a packed type implemented specially, then replace our
+ type with the implementation type. */
if (Present (Packed_Array_Impl_Type (gnat_entity)))
{
- Entity_Id gnat_index;
- tree gnu_inner;
-
/* First finish the type we had been making so that we output
debugging information for it. */
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
That's sort of "morally" true and will make it possible for
the debugger to look it up by name in DWARF, which is needed
in order to decode the packed array type. */
- gnu_decl
+ tree gnu_tmp_decl
= create_type_decl (gnu_entity_name, gnu_type,
!Comes_From_Source (Etype (gnat_entity))
&& artificial_p, debug_info_p,
gnat_entity);
-
/* Save it as our equivalent in case the call below elaborates
this type again. */
- save_gnu_tree (gnat_entity, gnu_decl, false);
-
- gnu_decl
- = gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
- NULL_TREE, 0);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
+ save_gnu_tree (gnat_entity, gnu_tmp_decl, false);
+ gnu_type
+ = gnat_to_gnu_type (Packed_Array_Impl_Type (gnat_entity));
save_gnu_tree (gnat_entity, NULL_TREE, false);
- gnu_inner = gnu_type;
+ /* Set the ___XP suffix for GNAT encodings. */
+ if (gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
+ gnu_entity_name = DECL_NAME (TYPE_NAME (gnu_type));
+
+ tree gnu_inner = gnu_type;
while (TREE_CODE (gnu_inner) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
|| TYPE_PADDING_P (gnu_inner)))
gcc_checking_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
}
- for (gnat_index = First_Index (gnat_entity);
+ for (Entity_Id gnat_index = First_Index (gnat_entity);
Present (gnat_index);
gnat_index = Next_Index (gnat_index))
SET_TYPE_ACTUAL_BOUNDS
TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
}
}
-
- else
- /* Abort if packed array with no Packed_Array_Impl_Type. */
- gcc_assert (!Is_Packed (gnat_entity));
}
break;
/* Create the type for a string literal. */
{
Entity_Id gnat_full_type
- = (IN (Ekind (Etype (gnat_entity)), Private_Kind)
+ = (Is_Private_Type (Etype (gnat_entity))
&& Present (Full_View (Etype (gnat_entity)))
? Full_View (Etype (gnat_entity)) : Etype (gnat_entity));
tree gnu_string_type = get_unpadded_type (gnat_full_type);
(Component_Type (gnat_entity)),
gnu_index_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
- TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
+ set_nonaliased_component_on_array_type (gnu_type);
relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
}
break;
Node_Id full_definition = Declaration_Node (gnat_entity);
Node_Id record_definition = Type_Definition (full_definition);
Node_Id gnat_constr;
- Entity_Id gnat_field;
+ Entity_Id gnat_field, gnat_parent_type;
tree gnu_field, gnu_field_list = NULL_TREE;
tree gnu_get_parent;
/* Set PACKED in keeping with gnat_to_gnu_field. */
/* Always set the alignment on the record type here so that it can
get the proper layout. */
if (has_align)
- TYPE_ALIGN (gnu_type)
- = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
+ SET_TYPE_ALIGN (gnu_type,
+ validate_alignment (Alignment (gnat_entity),
+ gnat_entity, 0));
else
{
- TYPE_ALIGN (gnu_type) = 0;
+ SET_TYPE_ALIGN (gnu_type, 0);
/* If a type needs strict alignment, the minimum size will be the
type size instead of the RM size (see validate_size). Cap the
Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
tree gnu_dummy_parent_type = make_node (RECORD_TYPE);
tree gnu_parent;
+ int parent_packed = 0;
/* A major complexity here is that the parent subtype will
reference our discriminants in its Stored_Constraint list.
if (definition)
gcc_assert (present_gnu_tree (gnat_uview));
else
- gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
+ gnat_to_gnu_entity (gnat_uview, NULL_TREE, false);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
be created with a component clause below, then we need
to apply the same adjustment as in gnat_to_gnu_field. */
if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_parent);
+ {
+ /* ??? For historical reasons, we do it on strict-alignment
+ platforms only, where it is really required. This means
+ that a confirming representation clause will change the
+ behavior of the compiler on the other platforms. */
+ if (STRICT_ALIGNMENT)
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
+ else
+ parent_packed
+ = adjust_packed (gnu_parent, gnu_type, parent_packed);
+ }
/* Finally we fix up both kinds of twisted COMPONENT_REF we have
initially built. The discriminants must reference the fields
if (has_discr)
{
/* The actual parent subtype is the full view. */
- if (IN (Ekind (gnat_parent), Private_Kind))
+ if (Is_Private_Type (gnat_parent))
{
if (Present (Full_View (gnat_parent)))
gnat_parent = Full_View (gnat_parent);
? TYPE_SIZE (gnu_parent) : NULL_TREE,
has_rep
? bitsize_zero_node : NULL_TREE,
- 0, 1);
+ parent_packed, 1);
DECL_INTERNAL_P (gnu_field) = 1;
TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
TYPE_FIELDS (gnu_type) = gnu_field;
{
/* If this is a record extension and this discriminant is the
renaming of another discriminant, we've handled it above. */
- if (Present (Parent_Subtype (gnat_entity))
+ if (is_extension
&& Present (Corresponding_Discriminant (gnat_field)))
continue;
}
/* If we have a derived untagged type that renames discriminants in
- the root type, the (stored) discriminants are a just copy of the
- discriminants of the root type. This means that any constraints
- added by the renaming in the derivation are disregarded as far
- as the layout of the derived type is concerned. To rescue them,
- we change the type of the (stored) discriminants to a subtype
- with the bounds of the type of the visible discriminants. */
+ the parent type, the (stored) discriminants are just a copy of the
+ discriminants of the parent type. This means that any constraints
+ added by the renaming in the derivation are disregarded as far as
+ the layout of the derived type is concerned. To rescue them, we
+ change the type of the (stored) discriminants to a subtype with
+ the bounds of the type of the visible discriminants. */
if (has_discr
&& !is_extension
&& Stored_Constraint (gnat_entity) != No_Elist)
&& Ekind (Entity (Node (gnat_constr))) == E_Discriminant)
{
Entity_Id gnat_discr = Entity (Node (gnat_constr));
- tree gnu_discr_type, gnu_ref;
-
- /* If the scope of the discriminant is not the record type,
- this means that we're processing the implicit full view
- of a type derived from a private discriminated type: in
- this case, the Stored_Constraint list is simply copied
- from the partial view, see Build_Derived_Private_Type.
- So we need to retrieve the corresponding discriminant
- of the implicit full view, otherwise we will abort. */
- if (Scope (gnat_discr) != gnat_entity)
- {
- Entity_Id field;
- for (field = First_Entity (gnat_entity);
- Present (field);
- field = Next_Entity (field))
- if (Ekind (field) == E_Discriminant
- && same_discriminant_p (gnat_discr, field))
- break;
- gcc_assert (Present (field));
- gnat_discr = field;
- }
-
- gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
- gnu_ref
+ tree gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
+ tree gnu_ref
= gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
- NULL_TREE, 0);
+ NULL_TREE, false);
/* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
just above for one of the stored discriminants. */
}
}
- /* Add the fields into the record type and finish it up. */
- components_to_record (gnu_type, Component_List (record_definition),
- gnu_field_list, packed, definition, false,
- all_rep, is_unchecked_union,
- artificial_p, debug_info_p,
- false, OK_To_Reorder_Components (gnat_entity),
- all_rep ? NULL_TREE : bitsize_zero_node, NULL);
+ /* If this is a derived type with discriminants and these discriminants
+ affect the initial shape it has inherited, factor them in. */
+ if (has_discr
+ && !is_extension
+ && !Has_Record_Rep_Clause (gnat_entity)
+ && Stored_Constraint (gnat_entity) != No_Elist
+ && (gnat_parent_type = Underlying_Type (Etype (gnat_entity)))
+ && Is_Record_Type (gnat_parent_type)
+ && Is_Unchecked_Union (gnat_entity)
+ == Is_Unchecked_Union (gnat_parent_type)
+ && No_Reordering (gnat_entity) == No_Reordering (gnat_parent_type))
+ {
+ tree gnu_parent_type
+ = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_parent_type));
+
+ if (TYPE_IS_PADDING_P (gnu_parent_type))
+ gnu_parent_type = TREE_TYPE (TYPE_FIELDS (gnu_parent_type));
+
+ vec<subst_pair> gnu_subst_list
+ = build_subst_list (gnat_entity, gnat_parent_type, definition);
+
+ /* Set the layout of the type to match that of the parent type,
+ doing required substitutions. If we are in minimal GNAT
+ encodings mode, we don't need debug info for the inner record
+ types, as they will be part of the embedding variant record's
+ debug info. */
+ copy_and_substitute_in_layout
+ (gnat_entity, gnat_parent_type, gnu_type, gnu_parent_type,
+ gnu_subst_list,
+ debug_info_p && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL);
+ }
+ else
+ {
+ /* Add the fields into the record type and finish it up. */
+ components_to_record (Component_List (record_definition),
+ gnat_entity, gnu_field_list, gnu_type,
+ packed, definition, false, all_rep,
+ is_unchecked_union, artificial_p,
+ debug_info_p, false,
+ all_rep ? NULL_TREE : bitsize_zero_node,
+ NULL);
+
+ /* Empty classes have the size of a storage unit in C++. */
+ if (TYPE_SIZE (gnu_type) == bitsize_zero_node
+ && Convention (gnat_entity) == Convention_CPP)
+ {
+ TYPE_SIZE (gnu_type) = bitsize_unit_node;
+ TYPE_SIZE_UNIT (gnu_type) = size_one_node;
+ compute_record_mode (gnu_type);
+ }
+
+ /* If there are entities in the chain corresponding to components
+ that we did not elaborate, ensure we elaborate their types if
+ they are Itypes. */
+ 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, false);
+ }
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
- /* If there are any entities in the chain corresponding to components
- that we did not elaborate, ensure we elaborate their types if they
- are Itypes. */
- 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);
-
/* If this is a record type associated with an exception definition,
equate its fields to those of the standard exception type. This
will make it possible to convert between them. */
since it may have constraints. */
if (gnat_equiv_type != gnat_entity)
{
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
}
if (Present (Cloned_Subtype (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
- NULL_TREE, 0);
- maybe_present = true;
+ NULL_TREE, false);
+ saved = true;
break;
}
else
{
Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
- tree gnu_base_type;
if (!definition)
{
this_deferred = true;
}
- gnu_base_type
+ tree gnu_base_type
= TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_base_type));
if (present_gnu_tree (gnat_entity))
/* When the subtype has discriminants and these discriminants affect
the initial shape it has inherited, factor them in. But for an
- Unchecked_Union (it must be an Itype), just return the type.
- We can't just test Is_Constrained because private subtypes without
- discriminants of types with discriminants with default expressions
- are Is_Constrained but aren't constrained! */
- if (IN (Ekind (gnat_base_type), Record_Kind)
- && !Is_Unchecked_Union (gnat_base_type)
+ Unchecked_Union (it must be an Itype), just return the type. */
+ if (Has_Discriminants (gnat_entity)
+ && Stored_Constraint (gnat_entity) != No_Elist
&& !Is_For_Access_Subtype (gnat_entity)
- && Has_Discriminants (gnat_entity)
- && Is_Constrained (gnat_entity)
- && Stored_Constraint (gnat_entity) != No_Elist)
+ && Is_Record_Type (gnat_base_type)
+ && !Is_Unchecked_Union (gnat_base_type))
{
vec<subst_pair> gnu_subst_list
= build_subst_list (gnat_entity, gnat_base_type, definition);
- tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part;
- tree gnu_pos_list, gnu_field_list = NULL_TREE;
- bool selected_variant = false, all_constant_pos = true;
- Entity_Id gnat_field;
- vec<variant_desc> gnu_variant_list;
+ tree gnu_unpad_base_type;
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_name;
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- SET_TYPE_DEBUG_TYPE (gnu_type, gnu_base_type);
+ {
+ /* Use the ultimate base record type as the debug type.
+ Subtypes and derived types bring no useful
+ information. */
+ Entity_Id gnat_debug_type = gnat_entity;
+ while (Etype (gnat_debug_type) != gnat_debug_type)
+ gnat_debug_type = Etype (gnat_debug_type);
+ tree gnu_debug_type
+ = TYPE_MAIN_VARIANT (gnat_to_gnu_type (gnat_debug_type));
+ SET_TYPE_DEBUG_TYPE (gnu_type, gnu_debug_type);
+ }
TYPE_PACKED (gnu_type) = TYPE_PACKED (gnu_base_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_type)
= Reverse_Storage_Order (gnat_entity);
process_attributes (&gnu_type, &attr_list, true, gnat_entity);
- /* Set the size, alignment and alias set of the new type to
- match that of the old one, doing required substitutions. */
+ /* Set the size, alignment and alias set of the type to match
+ those of the base type, doing required substitutions. */
copy_and_substitute_in_size (gnu_type, gnu_base_type,
gnu_subst_list);
else
gnu_unpad_base_type = gnu_base_type;
- /* Look for REP and variant parts in the base type. */
- gnu_rep_part = get_rep_part (gnu_unpad_base_type);
- gnu_variant_part = get_variant_part (gnu_unpad_base_type);
-
- /* If there is a variant part, we must compute whether the
- constraints statically select a particular variant. If
- so, we simply drop the qualified union and flatten the
- list of fields. Otherwise we'll build a new qualified
- union for the variants that are still relevant. */
- if (gnu_variant_part)
- {
- variant_desc *v;
- unsigned int i;
-
- gnu_variant_list
- = build_variant_list (TREE_TYPE (gnu_variant_part),
- gnu_subst_list,
- vNULL);
-
- /* If all the qualifiers are unconditionally true, the
- innermost variant is statically selected. */
- selected_variant = true;
- FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
- if (!integer_onep (v->qual))
- {
- selected_variant = false;
- break;
- }
-
- /* Otherwise, create the new variants. */
- if (!selected_variant)
- FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
- {
- tree old_variant = v->type;
- tree new_variant = make_node (RECORD_TYPE);
- tree suffix
- = concat_name (DECL_NAME (gnu_variant_part),
- IDENTIFIER_POINTER
- (DECL_NAME (v->field)));
- TYPE_NAME (new_variant)
- = concat_name (TYPE_NAME (gnu_type),
- IDENTIFIER_POINTER (suffix));
- TYPE_REVERSE_STORAGE_ORDER (new_variant)
- = TYPE_REVERSE_STORAGE_ORDER (gnu_type);
- copy_and_substitute_in_size (new_variant, old_variant,
- gnu_subst_list);
- v->new_type = new_variant;
- }
- }
- else
- {
- gnu_variant_list.create (0);
- selected_variant = false;
- }
-
- /* Make a list of fields and their position in the base type. */
- gnu_pos_list
- = build_position_list (gnu_unpad_base_type,
- gnu_variant_list.exists ()
- && !selected_variant,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT, NULL_TREE);
-
- /* Now go down every component in the subtype and compute its
- size and position from those of the component in the base
- type and from the constraints of the subtype. */
- 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)
- && !(Present (Corresponding_Discriminant (gnat_field))
- && Is_Tagged_Type (gnat_base_type))
- && Underlying_Type
- (Scope (Original_Record_Component (gnat_field)))
- == gnat_base_type)
- {
- Name_Id gnat_name = Chars (gnat_field);
- Entity_Id gnat_old_field
- = Original_Record_Component (gnat_field);
- tree gnu_old_field
- = gnat_to_gnu_field_decl (gnat_old_field);
- tree gnu_context = DECL_CONTEXT (gnu_old_field);
- tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
- tree gnu_cont_type, gnu_last = NULL_TREE;
-
- /* If the type is the same, retrieve the GCC type from the
- old field to take into account possible adjustments. */
- if (Etype (gnat_field) == Etype (gnat_old_field))
- gnu_field_type = TREE_TYPE (gnu_old_field);
- else
- gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
-
- /* If there was a component clause, the field types must be
- the same for the type and subtype, so copy the data from
- the old field to avoid recomputation here. Also if the
- field is justified modular and the optimization in
- gnat_to_gnu_field was applied. */
- if (Present (Component_Clause (gnat_old_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);
- }
-
- /* If the old field was packed and of constant size, we
- have to get the old size here, as it might differ from
- what the Etype conveys and the latter might overlap
- onto the following field. Try to arrange the type for
- possible better packing along the way. */
- else if (DECL_PACKED (gnu_old_field)
- && TREE_CODE (DECL_SIZE (gnu_old_field))
- == INTEGER_CST)
- {
- gnu_size = DECL_SIZE (gnu_old_field);
- if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
- && !TYPE_FAT_POINTER_P (gnu_field_type)
- && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
- gnu_field_type
- = make_packable_type (gnu_field_type, true);
- }
-
- else
- gnu_size = TYPE_SIZE (gnu_field_type);
-
- /* If the context of the old field is the base type or its
- REP part (if any), put the field directly in the new
- type; otherwise look up the context in the variant list
- and put the field either in the new type if there is a
- selected variant or in one of the new variants. */
- if (gnu_context == gnu_unpad_base_type
- || (gnu_rep_part
- && gnu_context == TREE_TYPE (gnu_rep_part)))
- gnu_cont_type = gnu_type;
- else
- {
- variant_desc *v;
- unsigned int i;
- tree rep_part;
-
- FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
- if (gnu_context == v->type
- || ((rep_part = get_rep_part (v->type))
- && gnu_context == TREE_TYPE (rep_part)))
- break;
- if (v)
- {
- if (selected_variant)
- gnu_cont_type = gnu_type;
- else
- gnu_cont_type = v->new_type;
- }
- else
- /* The front-end may pass us "ghost" components if
- it fails to recognize that a constrained subtype
- is statically constrained. Discard them. */
- continue;
- }
-
- /* Now create the new field modeled on the old one. */
- gnu_field
- = create_field_decl_from (gnu_old_field, gnu_field_type,
- gnu_cont_type, gnu_size,
- gnu_pos_list, gnu_subst_list);
- gnu_pos = DECL_FIELD_OFFSET (gnu_field);
-
- /* Put it in one of the new variants directly. */
- if (gnu_cont_type != gnu_type)
- {
- DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
- TYPE_FIELDS (gnu_cont_type) = gnu_field;
- }
-
- /* To match the layout crafted in components_to_record,
- if this is the _Tag or _Parent field, put it before
- any other fields. */
- else if (gnat_name == Name_uTag
- || gnat_name == Name_uParent)
- gnu_field_list = chainon (gnu_field_list, gnu_field);
-
- /* Similarly, if this is the _Controller field, put
- it before the other fields except for the _Tag or
- _Parent field. */
- else if (gnat_name == Name_uController && gnu_last)
- {
- DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
- DECL_CHAIN (gnu_last) = gnu_field;
- }
-
- /* Otherwise, if this is a regular field, put it after
- the other fields. */
- else
- {
- DECL_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- if (!gnu_last)
- gnu_last = gnu_field;
- if (TREE_CODE (gnu_pos) != INTEGER_CST)
- all_constant_pos = false;
- }
-
- save_gnu_tree (gnat_field, gnu_field, false);
- }
-
- /* If there is a variant list, a selected variant and the fields
- all have a constant position, put them in order of increasing
- position to match that of constant CONSTRUCTORs. Likewise if
- there is no variant list but a REP part, since the latter has
- been flattened in the process. */
- if (((gnu_variant_list.exists () && selected_variant)
- || (!gnu_variant_list.exists () && gnu_rep_part))
- && all_constant_pos)
- {
- const int len = list_length (gnu_field_list);
- tree *field_arr = XALLOCAVEC (tree, len), t;
- int i;
-
- for (t = gnu_field_list, i = 0; t; t = DECL_CHAIN (t), i++)
- field_arr[i] = t;
-
- qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
-
- gnu_field_list = NULL_TREE;
- for (i = 0; i < len; i++)
- {
- DECL_CHAIN (field_arr[i]) = gnu_field_list;
- gnu_field_list = field_arr[i];
- }
- }
-
- /* If there is a variant list and no selected variant, we need
- to create the nest of variant parts from the old nest. */
- else if (gnu_variant_list.exists () && !selected_variant)
- {
- tree new_variant_part
- = create_variant_part_from (gnu_variant_part,
- gnu_variant_list, gnu_type,
- gnu_pos_list, gnu_subst_list);
- DECL_CHAIN (new_variant_part) = gnu_field_list;
- gnu_field_list = new_variant_part;
- }
-
- /* Now go through the entities again looking for Itypes that
- we have not elaborated but should (e.g., Etypes of fields
- that have Original_Components). */
- 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);
-
- /* Do not emit debug info for the type yet since we're going to
- modify it below. */
- finish_record_type (gnu_type, nreverse (gnu_field_list), 2,
- false);
- compute_record_mode (gnu_type);
+ /* Set the layout of the type to match that of the base type,
+ doing required substitutions. We will output debug info
+ manually below so pass false as last argument. */
+ copy_and_substitute_in_layout (gnat_entity, gnat_base_type,
+ gnu_type, gnu_unpad_base_type,
+ gnu_subst_list, false);
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
true, debug_info_p,
NULL, gnat_entity);
}
-
- gnu_variant_list.release ();
- gnu_subst_list.release ();
-
- /* Now we can finalize it. */
- rest_of_record_type_compilation (gnu_type);
}
/* Otherwise, go down all the components in the new type and make
break;
case E_Access_Subprogram_Type:
+ case E_Anonymous_Access_Subprogram_Type:
/* Use the special descriptor type for dispatch tables if needed,
that is to say for the Prim_Ptr of a-tags.ads and its clones.
Note that we are only required to do so for static tables in
/* ... fall through ... */
- case E_Anonymous_Access_Subprogram_Type:
- /* If we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- fill it in later. */
- if (!definition && defer_incomplete_level != 0)
- {
- struct incomplete *p = XNEW (struct incomplete);
-
- gnu_type
- = build_pointer_type
- (make_dummy_type (Directly_Designated_Type (gnat_entity)));
- gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
- artificial_p, debug_info_p,
- gnat_entity);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- 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;
- }
-
- /* ... fall through ... */
-
case E_Allocator_Type:
case E_Access_Type:
case E_Access_Attribute_Type:
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
/* Whether it comes from a limited with. */
- bool is_from_limited_with
- = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
+ const bool is_from_limited_with
+ = (Is_Incomplete_Type (gnat_desig_equiv)
&& From_Limited_With (gnat_desig_equiv));
+ /* Whether it is a completed Taft Amendment type. Such a type is to
+ be treated as coming from a limited with clause if it is not in
+ the main unit, i.e. we break potential circularities here in case
+ the body of an external unit is loaded for inter-unit inlining. */
+ const bool is_completed_taft_type
+ = (Is_Incomplete_Type (gnat_desig_equiv)
+ && Has_Completion_In_Body (gnat_desig_equiv)
+ && Present (Full_View (gnat_desig_equiv)));
/* The "full view" of the designated type. If this is an incomplete
entity from a limited with, treat its non-limited view as the full
view. Otherwise, if this is an incomplete or private type, use the
Entity_Id gnat_desig_full_direct_first
= (is_from_limited_with
? Non_Limited_View (gnat_desig_equiv)
- : (IN (Ekind (gnat_desig_equiv), Incomplete_Or_Private_Kind)
+ : (Is_Incomplete_Or_Private_Type (gnat_desig_equiv)
? Full_View (gnat_desig_equiv) : Empty));
Entity_Id gnat_desig_full_direct
= ((is_from_limited_with
&& Present (gnat_desig_full_direct_first)
- && IN (Ekind (gnat_desig_full_direct_first), Private_Kind))
+ && Is_Private_Type (gnat_desig_full_direct_first))
? Full_View (gnat_desig_full_direct_first)
: gnat_desig_full_direct_first);
Entity_Id gnat_desig_full
/* The type actually used to represent the designated type, either
gnat_desig_full or gnat_desig_equiv. */
Entity_Id gnat_desig_rep;
- /* True if this is a pointer to an unconstrained array. */
- bool is_unconstrained_array;
/* We want to know if we'll be seeing the freeze node for any
incomplete type we may be pointing to. */
- bool in_main_unit
+ const bool in_main_unit
= (Present (gnat_desig_full)
? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type));
/* True if we make a dummy type here. */
bool made_dummy = false;
/* The mode to be used for the pointer type. */
- machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
+ scalar_int_mode p_mode;
/* The GCC type used for the designated type. */
tree gnu_desig_type = NULL_TREE;
- if (!targetm.valid_pointer_mode (p_mode))
+ if (!int_mode_for_size (esize, 0).exists (&p_mode)
+ || !targetm.valid_pointer_mode (p_mode))
p_mode = ptr_mode;
/* If either the designated type or its full view is an unconstrained
&& Ekind (Etype (gnat_desig_full)) == E_Record_Type)))
gnat_desig_full = Etype (gnat_desig_full);
- /* Set the type that's actually the representation of the designated
- type and also flag whether we have a unconstrained array. */
+ /* Set the type that's the representation of the designated type. */
gnat_desig_rep
= Present (gnat_desig_full) ? gnat_desig_full : gnat_desig_equiv;
- is_unconstrained_array
- = Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
-
- /* If we are pointing to an incomplete type whose completion is an
- unconstrained array, make dummy fat and thin pointer types to it.
- Likewise if the type itself is dummy or an unconstrained array. */
- if (is_unconstrained_array
- && (Present (gnat_desig_full)
- || (present_gnu_tree (gnat_desig_equiv)
- && TYPE_IS_DUMMY_P
- (TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
- || (!in_main_unit
- && defer_incomplete_level != 0
- && !present_gnu_tree (gnat_desig_equiv))
- || (in_main_unit
- && is_from_limited_with
- && Present (Freeze_Node (gnat_desig_equiv)))))
- {
- if (present_gnu_tree (gnat_desig_rep))
- gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
- else
- {
- gnu_desig_type = make_dummy_type (gnat_desig_rep);
- made_dummy = true;
- }
-
- /* If the call above got something that has a pointer, the pointer
- is our type. This could have happened either because the type
- was elaborated or because somebody else executed the code. */
- if (!TYPE_POINTER_TO (gnu_desig_type))
- build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
- gnu_type = TYPE_POINTER_TO (gnu_desig_type);
- }
/* If we already know what the full type is, use it. */
- else if (Present (gnat_desig_full)
- && present_gnu_tree (gnat_desig_full))
+ if (Present (gnat_desig_full) && present_gnu_tree (gnat_desig_full))
gnu_desig_type = TREE_TYPE (get_gnu_tree (gnat_desig_full));
/* Get the type of the thing we are to point to and build a pointer to
it. If it is a reference to an incomplete or private type with a
- full view that is a record, make a dummy type node and get the
- actual type later when we have verified it is safe. */
+ full view that is a record, an array or an access, make a dummy type
+ and get the actual type later when we have verified it is safe. */
else if ((!in_main_unit
&& !present_gnu_tree (gnat_desig_equiv)
&& Present (gnat_desig_full)
- && !present_gnu_tree (gnat_desig_full)
- && Is_Record_Type (gnat_desig_full))
- /* Likewise if we are pointing to a record or array and we are
- to defer elaborating incomplete types. We do this as this
- access type may be the full view of a private type. Note
- that the unconstrained array case is handled above. */
+ && (Is_Record_Type (gnat_desig_full)
+ || Is_Array_Type (gnat_desig_full)
+ || Is_Access_Type (gnat_desig_full)))
+ /* Likewise if this is a reference to a record, an array or a
+ subprogram type and we are to defer elaborating incomplete
+ types. We do this because this access type may be the full
+ view of a private type. */
|| ((!in_main_unit || imported_p)
&& defer_incomplete_level != 0
&& !present_gnu_tree (gnat_desig_equiv)
&& (Is_Record_Type (gnat_desig_rep)
- || Is_Array_Type (gnat_desig_rep)))
+ || Is_Array_Type (gnat_desig_rep)
+ || Ekind (gnat_desig_rep) == E_Subprogram_Type))
/* If this is a reference from a limited_with type back to our
main unit and there's a freeze node for it, either we have
already processed the declaration and made the dummy type,
in which case we make the dummy type and it will be reused
when the declaration is finally processed. In both cases,
the pointer eventually created below will be automatically
- adjusted when the freeze node is processed. Note that the
- unconstrained array case is handled above. */
- || (in_main_unit
- && is_from_limited_with
- && Present (Freeze_Node (gnat_desig_rep))))
+ adjusted when the freeze node is processed. */
+ || (in_main_unit
+ && is_from_limited_with
+ && Present (Freeze_Node (gnat_desig_rep))))
{
gnu_desig_type = make_dummy_type (gnat_desig_equiv);
made_dummy = true;
}
/* If expansion is disabled, the equivalent type of a concurrent type
- is absent, so build a dummy pointer type. */
+ is absent, so we use the void pointer type. */
else if (type_annotate_only && No (gnat_desig_equiv))
gnu_type = ptr_type_node;
+ /* If the ultimately designated type is an incomplete type with no full
+ view, we use the void pointer type in LTO mode to avoid emitting a
+ dummy type in the GIMPLE IR. We cannot do that in regular mode as
+ the name of the dummy type in used by GDB for a global lookup. */
+ else if (Ekind (gnat_desig_rep) == E_Incomplete_Type
+ && No (Full_View (gnat_desig_rep))
+ && flag_generate_lto)
+ gnu_type = ptr_type_node;
+
/* Finally, handle the default case where we can just elaborate our
designated type. */
else
break;
}
+ /* Access-to-unconstrained-array types need a special treatment. */
+ if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
+ {
+ /* If the processing above got something that has a pointer, then
+ we are done. This could have happened either because the type
+ was elaborated or because somebody else executed the code. */
+ if (!TYPE_POINTER_TO (gnu_desig_type))
+ build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
+
+ gnu_type = TYPE_POINTER_TO (gnu_desig_type);
+ }
+
/* If we haven't done it yet, build the pointer type the usual way. */
- if (!gnu_type)
+ else if (!gnu_type)
{
/* Modify the designated type if we are pointing only to constant
- objects, but don't do it for unconstrained arrays. */
+ objects, but don't do it for a dummy type. */
if (Is_Access_Constant (gnat_entity)
- && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_desig_type
- = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
-
- /* Some extra processing is required if we are building a
- pointer to an incomplete type (in the GCC sense). We might
- have such a type if we just made a dummy, or directly out
- of the call to gnat_to_gnu_type above if we are processing
- an access type for a record component designating the
- record type itself. */
- if (TYPE_MODE (gnu_desig_type) == VOIDmode)
- {
- /* We must ensure that the pointer to variant we make will
- be processed by update_pointer_to when the initial type
- is completed. Pretend we made a dummy and let further
- processing act as usual. */
- made_dummy = true;
-
- /* We must ensure that update_pointer_to will not retrieve
- the dummy variant when building a properly qualified
- version of the complete type. We take advantage of the
- fact that get_qualified_type is requiring TYPE_NAMEs to
- match to influence build_qualified_type and then also
- update_pointer_to here. */
- TYPE_NAME (gnu_desig_type)
- = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
- }
- }
+ && !TYPE_IS_DUMMY_P (gnu_desig_type))
+ gnu_desig_type
+ = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
gnu_type
= build_pointer_type_for_mode (gnu_desig_type, p_mode,
No_Strict_Aliasing (gnat_entity));
}
- /* If we are not defining this object and we have made a dummy pointer,
- save our current definition, evaluate the actual type, and replace
- the tentative type we made with the actual one. If we are to defer
- actually looking up the actual type, make an entry in the deferred
- list. If this is from a limited with, we may have to defer to the
- end of the current unit. */
- if ((!in_main_unit || is_from_limited_with) && made_dummy)
+ /* If the designated type is not declared in the main unit and we made
+ a dummy node for it, save our definition, elaborate the actual type
+ and replace the dummy type we made with the actual one. But if we
+ are to defer actually looking up the actual type, make an entry in
+ the deferred list instead. If this is from a limited with, we may
+ have to defer until the end of the current unit. */
+ if (!in_main_unit && made_dummy)
{
- tree gnu_old_desig_type;
-
- if (TYPE_IS_FAT_POINTER_P (gnu_type))
- {
- gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
- if (esize == POINTER_SIZE)
- gnu_type = build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
- }
- else
- gnu_old_desig_type = TREE_TYPE (gnu_type);
+ if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
+ gnu_type
+ = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true;
- /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
- update gnu_old_desig_type directly, in which case it will not be
- a dummy type any more when we get into update_pointer_to.
-
- This can happen e.g. when the designated type is a record type,
- because their elaboration starts with an initial node from
- make_dummy_type, which may be the same node as the one we got.
-
- Besides, variants of this non-dummy type might have been created
- along the way. update_pointer_to is expected to properly take
- care of those situations. */
- if (defer_incomplete_level == 0 && !is_from_limited_with)
+ if (defer_incomplete_level == 0
+ && !is_from_limited_with
+ && !is_completed_taft_type)
{
- update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
+ update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
gnat_to_gnu_type (gnat_desig_equiv));
}
else
{
struct incomplete *p = XNEW (struct incomplete);
struct incomplete **head
- = (is_from_limited_with
- ? &defer_limited_with : &defer_incomplete_list);
- p->old_type = gnu_old_desig_type;
+ = (is_from_limited_with || is_completed_taft_type
+ ? &defer_limited_with_list : &defer_incomplete_list);
+
+ p->old_type = gnu_desig_type;
p->full_type = gnat_desig_equiv;
p->next = *head;
*head = p;
case E_Access_Protected_Subprogram_Type:
case E_Anonymous_Access_Protected_Subprogram_Type:
- if (type_annotate_only && No (gnat_equiv_type))
+ /* If we are just annotating types and have no equivalent record type,
+ just use the void pointer type. */
+ if (type_annotate_only && gnat_equiv_type == gnat_entity)
gnu_type = ptr_type_node;
+
+ /* The run-time representation is the equivalent type. */
else
{
- /* The run-time representation is the equivalent type. */
gnu_type = gnat_to_gnu_type (gnat_equiv_type);
maybe_present = true;
}
+ /* The designated subtype must be elaborated as well, if it does
+ not have its own freeze node. */
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);
+ NULL_TREE, false);
break;
case E_Access_Subtype:
-
/* We treat this as identical to its base type; any constraint is
- meaningful only to the front-end.
+ meaningful only to the front-end. */
+ gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
+ saved = true;
- The designated type must be elaborated as well, if it does
- not have its own freeze node. Designated (sub)types created
+ /* The designated subtype must be elaborated as well, if it does
+ not have its own freeze node. But designated subtypes created
for constrained components of records with discriminants are
- not frozen by the front-end and thus not elaborated by gigi,
- because their use may appear before the base type is frozen,
- and because it is not clear that they are needed anywhere in
- gigi. With the current model, there is no correct place where
- they could be elaborated. */
-
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
+ not frozen by the front-end and not elaborated here, because
+ their use may appear before the base type is frozen and it is
+ not clear that they are needed in gigi. With the current model,
+ there is no correct place where they could be elaborated. */
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 we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- elaborate it later. */
- if (!definition && defer_incomplete_level != 0)
+ /* If we are to defer elaborating incomplete types, make a dummy
+ type node and elaborate it later. */
+ if (defer_incomplete_level != 0)
{
struct incomplete *p = XNEW (struct incomplete);
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 if (!Is_Incomplete_Or_Private_Type
+ (Base_Type (Directly_Designated_Type (gnat_entity))))
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
}
-
- maybe_present = true;
break;
/* Subprogram Entities
case E_Function:
case E_Procedure:
{
- /* The type returned by a function or else Standard_Void_Type for a
- procedure. */
- Entity_Id gnat_return_type = Etype (gnat_entity);
- tree gnu_return_type;
- /* The first GCC parameter declaration (a PARM_DECL node). The
- PARM_DECL nodes are chained through the DECL_CHAIN field, so this
- actually is the head of this parameter list. */
- tree gnu_param_list = NULL_TREE;
- /* Non-null for subprograms containing parameters passed by copy-in
- copy-out (Ada In Out or Out parameters not passed by reference),
- in which case it is the list of nodes used to specify the values
- of the In Out/Out parameters that are returned as a record upon
- procedure return. The TREE_PURPOSE of an element of this list is
- a field of the record and the TREE_VALUE is the PARM_DECL
- corresponding to that field. This list will be saved in the
- TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
- tree gnu_cico_list = NULL_TREE;
- /* List of fields in return type of procedure with copy-in copy-out
- parameters. */
- tree gnu_field_list = NULL_TREE;
- /* If an import pragma asks to map this subprogram to a GCC builtin,
- this is the builtin DECL node. */
- tree gnu_builtin_decl = NULL_TREE;
- tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
- Entity_Id gnat_param;
+ tree gnu_ext_name
+ = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name);
enum inline_status_t inline_status
= Has_Pragma_No_Inline (gnat_entity)
? is_suppressed
|| imported_p
|| (Convention (gnat_entity) == Convention_Intrinsic
&& Has_Pragma_Inline_Always (gnat_entity)));
- /* The semantics of "pure" in Ada essentially matches that of "const"
- in the back-end. In particular, both properties are orthogonal to
- the "nothrow" property if the EH circuitry is explicit in the
- internal representation of the back-end. If we are to completely
- hide the EH circuitry from it, we need to declare that calls to pure
- Ada subprograms that can throw have side effects since they can
- trigger an "abnormal" transfer of control flow; thus they can be
- neither "const" nor "pure" in the back-end sense. */
- bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_entity));
- bool volatile_flag = No_Return (gnat_entity);
- bool return_by_direct_ref_p = false;
- bool return_by_invisi_ref_p = false;
- bool return_unconstrained_p = false;
- int parmnum;
+ tree gnu_param_list;
/* A parameter may refer to this type, so defer completion of any
incomplete types. */
const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
- gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
+ false);
- gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
+ gnu_decl
+ = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
/* Elaborate any Itypes in the parameters of this entity. */
for (gnat_temp = First_Formal_With_Extras (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);
+ gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* Materialize renamed subprograms in the debugging information
when the renamed object is compile time known. We can consider
&& Present (gnat_renamed)
&& (Ekind (gnat_renamed) == E_Function
|| Ekind (gnat_renamed) == E_Procedure)
- && gnu_decl != NULL_TREE
+ && gnu_decl
&& TREE_CODE (gnu_decl) == FUNCTION_DECL)
{
tree decl = build_decl (input_location, IMPORTED_DECL,
break;
}
- /* If this subprogram is expectedly bound to a GCC builtin, fetch the
- corresponding DECL node. Proper generation of calls later on need
- proper parameter associations so we don't "break;" here. */
- if (Convention (gnat_entity) == Convention_Intrinsic
- && Present (Interface_Name (gnat_entity)))
- {
- gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
-
- /* Inability to find the builtin decl most often indicates a
- genuine mistake, but imports of unregistered intrinsics are
- sometimes issued on purpose to allow hooking in alternate
- bodies. We post a warning conditioned on Wshadow in this case,
- to let developers be notified on demand without risking false
- positives with common default sets of options. */
-
- if (gnu_builtin_decl == NULL_TREE && warn_shadow)
- post_error ("?gcc intrinsic not found for&!", gnat_entity);
- }
-
- /* ??? What if we don't find the builtin node above ? warn ? err ?
- In the current state we neither warn nor err, and calls will just
- be handled as for regular subprograms. */
-
- /* Look into the return type and get its associated GCC tree. If it
- is not void, compute various flags for the subprogram type. */
- if (Ekind (gnat_return_type) == E_Void)
- gnu_return_type = void_type_node;
- else
- {
- /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
- context may now appear in parameter and result profiles. If
- we are only annotating types, break circularities here. */
- if (type_annotate_only
- && is_from_limited_with_of_main (gnat_return_type))
- gnu_return_type = void_type_node;
- else
- gnu_return_type = gnat_to_gnu_type (gnat_return_type);
-
- /* If this function returns by reference, make the actual return
- type the pointer type and make a note of that. */
- if (Returns_By_Ref (gnat_entity))
- {
- gnu_return_type = build_reference_type (gnu_return_type);
- return_by_direct_ref_p = true;
- }
-
- /* If the return type is an unconstrained array type, the return
- value will be allocated on the secondary stack so the actual
- return type is the fat pointer type. */
- else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_return_type = TREE_TYPE (gnu_return_type);
- return_unconstrained_p = true;
- }
-
- /* Likewise, if the return type requires a transient scope, the
- return value will also be allocated on the secondary stack so
- the actual return type is the pointer type. */
- else if (Requires_Transient_Scope (gnat_return_type))
- {
- gnu_return_type = build_reference_type (gnu_return_type);
- return_unconstrained_p = true;
- }
-
- /* If the Mechanism is By_Reference, ensure this function uses the
- target's by-invisible-reference mechanism, which may not be the
- same as above (e.g. it might be passing an extra parameter). */
- else if (kind == E_Function
- && Mechanism (gnat_entity) == By_Reference)
- return_by_invisi_ref_p = true;
-
- /* Likewise, if the return type is itself By_Reference. */
- else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
- return_by_invisi_ref_p = true;
-
- /* If the type is a padded type and the underlying type would not
- be passed by reference or the function has a foreign convention,
- return the underlying type. */
- else if (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 the return type is unconstrained, that means it must have a
- maximum size. Use the padded type as the effective return type.
- And ensure the function uses the target's by-invisible-reference
- mechanism to avoid copying too much data when it returns. */
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
- {
- tree orig_type = gnu_return_type;
- tree max_return_size
- = max_size (TYPE_SIZE (gnu_return_type), true);
-
- /* If the size overflows to 0, set it to an arbitrary positive
- value so that assignments in the type are preserved. Their
- actual size is independent of this positive value. */
- if (TREE_CODE (max_return_size) == INTEGER_CST
- && TREE_OVERFLOW (max_return_size)
- && integer_zerop (max_return_size))
- {
- max_return_size = copy_node (bitsize_unit_node);
- TREE_OVERFLOW (max_return_size) = 1;
- }
-
- gnu_return_type
- = maybe_pad_type (gnu_return_type, max_return_size, 0,
- gnat_entity, false, false, definition,
- true);
-
- /* Declare it now since it will never be declared otherwise.
- This is necessary to ensure that its subtrees are properly
- marked. */
- if (gnu_return_type != orig_type
- && !DECL_P (TYPE_NAME (gnu_return_type)))
- create_type_decl (TYPE_NAME (gnu_return_type),
- gnu_return_type, true, debug_info_p,
- gnat_entity);
-
- return_by_invisi_ref_p = true;
- }
-
- /* If the return type has a size that overflows, we cannot have
- a function that returns that type. This usage doesn't make
- sense anyway, so give an error here. */
- if (!return_by_invisi_ref_p
- && TYPE_SIZE_UNIT (gnu_return_type)
- && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
- && !valid_constant_size_p (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;
- }
- }
-
- /* Loop over the parameters and get their associated GCC tree. While
- doing this, build a copy-in copy-out structure if we need one. */
- for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
- Present (gnat_param);
- gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
- {
- Entity_Id gnat_param_type = Etype (gnat_param);
- tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type, gnu_param, gnu_field;
- Mechanism_Type mech = Mechanism (gnat_param);
- bool copy_in_copy_out = false, fake_param_type;
-
- /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
- context may now appear in parameter and result profiles. If
- we are only annotating types, break circularities here. */
- if (type_annotate_only
- && is_from_limited_with_of_main (gnat_param_type))
- {
- gnu_param_type = void_type_node;
- fake_param_type = true;
- }
- else
- {
- gnu_param_type = gnat_to_gnu_type (gnat_param_type);
- fake_param_type = false;
- }
-
- /* Builtins are expanded inline and there is no real call sequence
- involved. So the type expected by the underlying expander is
- always the type of each argument "as is". */
- if (gnu_builtin_decl)
- mech = By_Copy;
- /* Handle the first parameter of a valued procedure specially. */
- else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
- mech = By_Copy_Return;
- /* Otherwise, see if a Mechanism was supplied that forced this
- parameter to be passed one way or another. */
- else if (mech == Default
- || mech == By_Copy
- || mech == By_Reference)
- ;
- else if (mech > 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),
- mech))
- mech = By_Reference;
- else
- mech = By_Copy;
- }
- else
- {
- post_error ("unsupported mechanism for&", gnat_param);
- mech = Default;
- }
-
- /* Do not call gnat_to_gnu_param for a fake parameter type since
- it will try to use the real type again. */
- if (fake_param_type)
- {
- if (Ekind (gnat_param) == E_Out_Parameter)
- gnu_param = NULL_TREE;
- else
- {
- gnu_param
- = create_param_decl (gnu_param_name, gnu_param_type,
- false);
- Set_Mechanism (gnat_param,
- mech == Default ? By_Copy : mech);
- if (Ekind (gnat_param) == E_In_Out_Parameter)
- copy_in_copy_out = true;
- }
- }
- else
- gnu_param
- = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
- Has_Foreign_Convention (gnat_entity),
- ©_in_copy_out);
-
- /* We are returned either a PARM_DECL or a type if no parameter
- needs to be passed; in either case, adjust the type. */
- if (DECL_P (gnu_param))
- gnu_param_type = TREE_TYPE (gnu_param);
- else
- {
- gnu_param_type = gnu_param;
- gnu_param = NULL_TREE;
- }
-
- /* The failure of this assertion will very likely come from an
- order of elaboration issue for the type of the parameter. */
- gcc_assert (kind == E_Subprogram_Type
- || !TYPE_IS_DUMMY_P (gnu_param_type)
- || type_annotate_only);
-
- if (gnu_param)
- {
- gnu_param_list = chainon (gnu_param, gnu_param_list);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_param));
- save_gnu_tree (gnat_param, gnu_param, false);
-
- /* If a parameter is a pointer, this function may modify
- memory through it and thus shouldn't be considered
- a const function. Also, the memory may be modified
- between two calls, so they can't be CSE'ed. The latter
- case also handles by-ref parameters. */
- if (POINTER_TYPE_P (gnu_param_type)
- || TYPE_IS_FAT_POINTER_P (gnu_param_type))
- const_flag = false;
- }
-
- if (copy_in_copy_out)
- {
- if (!gnu_cico_list)
- {
- tree gnu_new_ret_type = make_node (RECORD_TYPE);
-
- /* If this is a function, we also need a field for the
- return value to be placed. */
- if (TREE_CODE (gnu_return_type) != VOID_TYPE)
- {
- gnu_field
- = create_field_decl (get_identifier ("RETVAL"),
- gnu_return_type,
- gnu_new_ret_type, NULL_TREE,
- NULL_TREE, 0, 0);
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_field));
- gnu_field_list = gnu_field;
- gnu_cico_list
- = tree_cons (gnu_field, void_type_node, NULL_TREE);
- }
-
- gnu_return_type = gnu_new_ret_type;
- TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
- /* Set a default alignment to speed up accesses. But we
- shouldn't increase the size of the structure too much,
- lest it doesn't fit in return registers anymore. */
- TYPE_ALIGN (gnu_return_type)
- = get_mode_alignment (ptr_mode);
- }
-
- gnu_field
- = create_field_decl (gnu_param_name, gnu_param_type,
- gnu_return_type, NULL_TREE, NULL_TREE,
- 0, 0);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_field));
- DECL_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- gnu_cico_list
- = tree_cons (gnu_field, gnu_param, gnu_cico_list);
- }
- }
-
- if (gnu_cico_list)
+ /* Get the GCC tree for the (underlying) subprogram type. If the
+ entity is an actual subprogram, also get the parameter list. */
+ gnu_type
+ = gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
+ &gnu_param_list);
+ if (DECL_P (gnu_type))
{
- /* If we have a CICO list but it has only one entry, we convert
- this function into a function that returns this object. */
- if (list_length (gnu_cico_list) == 1)
- gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
-
- /* Do not finalize the return type if the subprogram is stubbed
- since structures are incomplete for the back-end. */
- else if (Convention (gnat_entity) != Convention_Stubbed)
- {
- finish_record_type (gnu_return_type, nreverse (gnu_field_list),
- 0, false);
-
- /* Try to promote the mode of the return type if it is passed
- in registers, again to speed up accesses. */
- if (TYPE_MODE (gnu_return_type) == BLKmode
- && !targetm.calls.return_in_memory (gnu_return_type,
- NULL_TREE))
- {
- unsigned int size
- = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
- unsigned int i = BITS_PER_UNIT;
- machine_mode mode;
-
- while (i < size)
- i <<= 1;
- mode = mode_for_size (i, MODE_INT, 0);
- if (mode != BLKmode)
- {
- SET_TYPE_MODE (gnu_return_type, mode);
- TYPE_ALIGN (gnu_return_type)
- = GET_MODE_ALIGNMENT (mode);
- TYPE_SIZE (gnu_return_type)
- = bitsize_int (GET_MODE_BITSIZE (mode));
- TYPE_SIZE_UNIT (gnu_return_type)
- = size_int (GET_MODE_SIZE (mode));
- }
- }
-
- if (debug_info_p)
- rest_of_record_type_compilation (gnu_return_type);
- }
+ gnu_decl = gnu_type;
+ gnu_type = TREE_TYPE (gnu_decl);
+ break;
}
/* Deal with platform-specific calling conventions. */
/* If we should request stack realignment for a foreign convention
subprogram, do so. Note that this applies to task entry points
in particular. */
- if (FOREIGN_FORCE_REALIGN_STACK
- && Has_Foreign_Convention (gnat_entity))
+ if (FOREIGN_FORCE_REALIGN_STACK && foreign)
prepend_one_attribute
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("force_align_arg_pointer"), NULL_TREE,
prepend_one_attribute_pragma (&attr_list,
Linker_Section_Pragma (gnat_entity));
- /* The lists have been built in reverse. */
- gnu_param_list = nreverse (gnu_param_list);
- gnu_cico_list = nreverse (gnu_cico_list);
-
- if (kind == E_Function)
- Set_Mechanism (gnat_entity, return_unconstrained_p
- || return_by_direct_ref_p
- || return_by_invisi_ref_p
- ? By_Reference : By_Copy);
- gnu_type
- = create_subprog_type (gnu_return_type, gnu_param_list,
- gnu_cico_list, return_unconstrained_p,
- return_by_direct_ref_p,
- return_by_invisi_ref_p);
-
- /* A procedure (something that doesn't return anything) shouldn't be
- considered const since there would be no reason for calling such a
- subprogram. Note that procedures with Out (or In Out) parameters
- have already been converted into a function with a return type.
- Similarly, if the function returns an unconstrained type, then the
- function will allocate the return value on the secondary stack and
- thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
- if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
- const_flag = false;
-
- /* If we have a builtin decl for that function, use it. Check if the
- profiles are compatible and warn if they are not. The checker is
- expected to post extra diagnostics in this case. */
- if (gnu_builtin_decl)
- {
- intrin_binding_t inb;
-
- inb.gnat_entity = gnat_entity;
- inb.ada_fntype = gnu_type;
- inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
-
- if (!intrin_profiles_compatible_p (&inb))
- post_error
- ("?profile of& doesn''t match the builtin it binds!",
- gnat_entity);
-
- gnu_decl = gnu_builtin_decl;
- gnu_type = TREE_TYPE (gnu_builtin_decl);
- break;
- }
-
- /* If there was no specified Interface_Name and the external and
- internal names of the subprogram are the same, only use the
- internal name to allow disambiguation of nested subprograms. */
- if (No (Interface_Name (gnat_entity))
- && gnu_ext_name == gnu_entity_name)
- gnu_ext_name = NULL_TREE;
-
/* If we are defining the subprogram and it has an Address clause
we must get the address expression from the saved GCC tree for the
subprogram if it has a Freeze_Node. Otherwise, we elaborate
DECL_BY_REF_P (gnu_decl) = 1;
}
+ /* If this is a mere subprogram type, just create the declaration. */
else if (kind == E_Subprogram_Type)
{
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
- if (const_flag || volatile_flag)
- {
- const int quals
- = (const_flag ? TYPE_QUAL_CONST : 0)
- | (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
- gnu_type = change_qualified_type (gnu_type, quals);
- }
-
gnu_decl
= create_type_decl (gnu_entity_name, gnu_type, artificial_p,
debug_info_p, gnat_entity);
}
+
+ /* Otherwise create the subprogram declaration with the external name,
+ the type and the parameter list. However, if this a reference to
+ the allocation routines, reuse the canonical declaration nodes as
+ they come with special properties. */
else
{
- gnu_decl
- = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
- gnu_param_list, inline_status, const_flag,
- public_flag, extern_flag, volatile_flag,
- artificial_p, debug_info_p,
- attr_list, gnat_entity);
- /* This is unrelated to the stub built right above. */
- DECL_STUBBED_P (gnu_decl)
- = Convention (gnat_entity) == Convention_Stubbed;
+ if (extern_flag && gnu_ext_name == DECL_NAME (malloc_decl))
+ gnu_decl = malloc_decl;
+ else if (extern_flag && gnu_ext_name == DECL_NAME (realloc_decl))
+ gnu_decl = realloc_decl;
+ else
+ {
+ gnu_decl
+ = create_subprog_decl (gnu_entity_name, gnu_ext_name,
+ gnu_type, gnu_param_list,
+ inline_status, public_flag,
+ extern_flag, artificial_p,
+ debug_info_p,
+ definition && imported_p, attr_list,
+ gnat_entity);
+
+ DECL_STUBBED_P (gnu_decl)
+ = (Convention (gnat_entity) == Convention_Stubbed);
+ }
}
}
break;
case E_Record_Type_With_Private:
case E_Record_Subtype_With_Private:
{
- bool is_from_limited_with
+ const bool is_from_limited_with
= (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
/* Get the "full view" of this entity. If this is an incomplete
entity from a limited with, treat its non-limited view as the
full view. Otherwise, use either the full view or the underlying
full view, whichever is present. This is used in all the tests
below. */
- Entity_Id full_view
+ const Entity_Id full_view
= is_from_limited_with
? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity))
: Empty;
/* If this is an incomplete type with no full view, it must be a Taft
- Amendment type, in which case we return a dummy type. Otherwise,
- just get the type from its Etype. */
+ Amendment type or an incomplete type coming from a limited context,
+ in which cases we return a dummy type. Otherwise, we just get the
+ type from its Etype. */
if (No (full_view))
{
if (kind == E_Incomplete_Type)
}
else
{
- gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
- NULL_TREE, 0);
+ gnu_decl
+ = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
maybe_present = true;
}
- break;
}
- /* If we already made a type for the full view, reuse it. */
+ /* Or else, if we already made a type for the full view, reuse it. */
else if (present_gnu_tree (full_view))
- {
- gnu_decl = get_gnu_tree (full_view);
- break;
- }
+ gnu_decl = get_gnu_tree (full_view);
- /* Otherwise, if we are not defining the type now, get the type
- from the full view. But always get the type from the full view
- for define on use types, since otherwise we won't see them.
- Likewise if this is a non-limited view not declared in the main
- unit, which can happen for incomplete formal types instantiated
- on a type coming from a limited_with clause. */
+ /* Or else, if we are not defining the type or there is no freeze
+ node on it, get the type for the full view. Likewise if this is
+ a limited_with'ed type not declared in the main unit, which can
+ happen for incomplete formal types instantiated on a type coming
+ from a limited_with clause. */
else if (!definition
- || (Is_Itype (full_view) && No (Freeze_Node (gnat_entity)))
- || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view)))
+ || No (Freeze_Node (full_view))
|| (is_from_limited_with
&& !In_Extended_Main_Code_Unit (full_view)))
{
- gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
maybe_present = true;
- break;
}
- /* For incomplete types, make a dummy type entry which will be
- replaced later. Save it as the full declaration's type so
- we can do any needed updates when we see it. */
- gnu_type = make_dummy_type (gnat_entity);
- gnu_decl = TYPE_STUB_DECL (gnu_type);
- if (Has_Completion_In_Body (gnat_entity))
- DECL_TAFT_TYPE_P (gnu_decl) = 1;
- save_gnu_tree (full_view, gnu_decl, 0);
- break;
+ /* Otherwise, make a dummy type entry which will be replaced later.
+ Save it as the full declaration's type so we can do any needed
+ updates when we see it. */
+ else
+ {
+ gnu_type = make_dummy_type (gnat_entity);
+ gnu_decl = TYPE_STUB_DECL (gnu_type);
+ if (Has_Completion_In_Body (gnat_entity))
+ DECL_TAFT_TYPE_P (gnu_decl) = 1;
+ save_gnu_tree (full_view, gnu_decl, false);
+ }
}
+ break;
case E_Class_Wide_Type:
/* Class-wide types are always transformed into their root type. */
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
just return void_type, except for root types that have discriminants
because the discriminants will very likely be used in the declarative
part of the associated body so they need to be translated. */
- if (type_annotate_only && No (gnat_equiv_type))
+ if (type_annotate_only && gnat_equiv_type == gnat_entity)
{
if (Has_Discriminants (gnat_entity)
&& Root_Type (gnat_entity) == gnat_entity)
gnu_field_list = gnu_field;
}
- TYPE_FIELDS (gnu_type) = nreverse (gnu_field_list);
+ finish_record_type (gnu_type, nreverse (gnu_field_list), 0,
+ false);
}
else
gnu_type = void_type_node;
/* Concurrent types are always transformed into their record type. */
else
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
handling alignment and possible padding. */
if (is_type && (!gnu_decl || this_made_decl))
{
+ gcc_assert (!TYPE_IS_DUMMY_P (gnu_type));
+
/* Process the attributes, if not already done. Note that the type is
already defined so we cannot pass true for IN_PLACE here. */
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
- /* Tell the middle-end that objects of tagged types are guaranteed to
- be properly aligned. This is necessary because conversions to the
- class-wide type are translated into conversions to the root type,
- which can be less aligned than some of its derived types. */
- if (Is_Tagged_Type (gnat_entity)
- || Is_Class_Wide_Equivalent_Type (gnat_entity))
- TYPE_ALIGN_OK (gnu_type) = 1;
-
- /* Record whether the type is passed by reference. */
- if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
- TYPE_BY_REFERENCE_P (gnu_type) = 1;
-
/* ??? Don't set the size for a String_Literal since it is either
confirming or we don't handle it properly (if the low bound is
non-constant). */
a constant or self-referential, call elaborate_expression_1 to
make a variable for the size rather than calculating it each time.
Handle both the RM size and the actual size. */
- if (global_bindings_p ()
- && TYPE_SIZE (gnu_type)
+ if (TYPE_SIZE (gnu_type)
&& !TREE_CONSTANT (TYPE_SIZE (gnu_type))
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
+ && global_bindings_p ())
{
tree size = TYPE_SIZE (gnu_type);
}
}
- /* If this is a record type or subtype, call elaborate_expression_2 on
- any field position. Do this for both global and local types.
- Skip any fields that we haven't made trees for to avoid problems with
- class wide types. */
- if (IN (kind, Record_Kind))
+ /* Similarly, if this is a record type or subtype at global level, call
+ elaborate_expression_2 on any field position. Skip any fields that
+ we haven't made trees for to avoid problems with class-wide types. */
+ if (IN (kind, Record_Kind) && global_bindings_p ())
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))
/* ??? For now, store the offset as a multiple of the alignment
in bytes so that we can see the alignment from the tree. */
- if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
+ if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field))
+ && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
{
DECL_FIELD_OFFSET (gnu_field)
= elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
/* ??? The context of gnu_field is not necessarily gnu_type
so the MULT_EXPR node built above may not be marked by
the call to create_type_decl below. */
- if (global_bindings_p ())
- MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
+ MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
}
}
/* If this is not an unconstrained array type, set some flags. */
if (TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE)
{
+ /* Tell the middle-end that objects of tagged types are guaranteed to
+ be properly aligned. This is necessary because conversions to the
+ class-wide type are translated into conversions to the root type,
+ which can be less aligned than some of its derived types. */
+ if (Is_Tagged_Type (gnat_entity)
+ || Is_Class_Wide_Equivalent_Type (gnat_entity))
+ TYPE_ALIGN_OK (gnu_type) = 1;
+
+ /* Record whether the type is passed by reference. */
+ if (Is_By_Reference_Type (gnat_entity) && !VOID_TYPE_P (gnu_type))
+ TYPE_BY_REFERENCE_P (gnu_type) = 1;
+
+ /* Record whether an alignment clause was specified. */
if (Present (Alignment_Clause (gnat_entity)))
TYPE_USER_ALIGN (gnu_type) = 1;
- if (Universal_Aliasing (gnat_entity))
+ /* Record whether a pragma Universal_Aliasing was specified. */
+ if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
/* If it is passed by reference, force BLKmode to ensure that
objects of this type will always be put in memory. */
- if (TYPE_MODE (gnu_type) != BLKmode
- && AGGREGATE_TYPE_P (gnu_type)
- && TYPE_BY_REFERENCE_P (gnu_type))
+ if (AGGREGATE_TYPE_P (gnu_type) && TYPE_BY_REFERENCE_P (gnu_type))
SET_TYPE_MODE (gnu_type, BLKmode);
-
- if (Treat_As_Volatile (gnat_entity))
- {
- const int quals
- = TYPE_QUAL_VOLATILE
- | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
- gnu_type = change_qualified_type (gnu_type, quals);
- }
}
- if (!gnu_decl)
- gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
- artificial_p, debug_info_p,
- gnat_entity);
- else
- {
- TREE_TYPE (gnu_decl) = gnu_type;
- TYPE_STUB_DECL (gnu_type) = gnu_decl;
- }
- }
-
- if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
- {
- gnu_type = TREE_TYPE (gnu_decl);
-
/* If this is a derived type, relate its alias set to that of its parent
to avoid troubles when a call to an inherited primitive is inlined in
a context where a derived object is accessed. The inlined code works
? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
}
- /* Back-annotate the Alignment of the type if not already in the
- tree. Likewise for sizes. */
+ /* Finally get to the appropriate variant, except for the implementation
+ type of a packed array because the GNU type might be further adjusted
+ when the original array type is itself processed. */
+ if (Treat_As_Volatile (gnat_entity)
+ && !Is_Packed_Array_Impl_Type (gnat_entity))
+ {
+ const int quals
+ = TYPE_QUAL_VOLATILE
+ | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
+ gnu_type = change_qualified_type (gnu_type, quals);
+ }
+
+ /* If we already made a decl, just set the type, otherwise create it. */
+ if (gnu_decl)
+ {
+ TREE_TYPE (gnu_decl) = gnu_type;
+ TYPE_STUB_DECL (gnu_type) = gnu_decl;
+ }
+ else
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
+ debug_info_p, gnat_entity);
+ }
+
+ /* If we got a type that is not dummy, back-annotate the alignment of the
+ type if not already in the tree. Likewise for the size, if any. */
+ if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
+ {
+ gnu_type = TREE_TYPE (gnu_decl);
+
if (Unknown_Alignment (gnat_entity))
{
unsigned int double_align, align;
/* If we are just annotating types and the type is tagged, the tag
and the parent components are not generated by the front-end so
- sizes must be adjusted if there is no representation clause. */
+ alignment and sizes must be adjusted if there is no rep clause. */
if (type_annotate_only
&& Is_Tagged_Type (gnat_entity)
+ && Unknown_RM_Size (gnat_entity)
&& !VOID_TYPE_P (gnu_type)
&& (!TYPE_FIELDS (gnu_type)
|| integer_zerop (bit_position (TYPE_FIELDS (gnu_type)))))
{
- tree pointer_size = bitsize_int (POINTER_SIZE), offset;
- Uint uint_size;
+ tree offset;
if (Is_Derived_Type (gnat_entity))
{
Set_Alignment (gnat_entity, Alignment (gnat_parent));
}
else
- offset = pointer_size;
+ {
+ unsigned int align
+ = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
+ offset = bitsize_int (POINTER_SIZE);
+ Set_Alignment (gnat_entity, UI_From_Int (align));
+ }
if (TYPE_FIELDS (gnu_type))
offset
gnu_size = size_binop (PLUS_EXPR, gnu_size, offset);
gnu_size = round_up (gnu_size, POINTER_SIZE);
- uint_size = annotate_value (gnu_size);
- Set_Esize (gnat_entity, uint_size);
+ Uint uint_size = annotate_value (gnu_size);
Set_RM_Size (gnat_entity, uint_size);
+ Set_Esize (gnat_entity, uint_size);
+ }
+
+ /* If there is a rep clause, only adjust alignment and Esize. */
+ else if (type_annotate_only && Is_Tagged_Type (gnat_entity))
+ {
+ unsigned int align
+ = MAX (TYPE_ALIGN (gnu_type), POINTER_SIZE) / BITS_PER_UNIT;
+ Set_Alignment (gnat_entity, UI_From_Int (align));
+ gnu_size = round_up (gnu_size, POINTER_SIZE);
+ Set_Esize (gnat_entity, annotate_value (gnu_size));
}
+
+ /* Otherwise no adjustment is needed. */
else
Set_Esize (gnat_entity, annotate_value (gnu_size));
}
- if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
+ if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
}
p->old_type = NULL_TREE;
}
- for (p = defer_limited_with; p; p = p->next)
- if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
+ for (p = defer_limited_with_list; p; p = p->next)
+ if (p->old_type
+ && (Non_Limited_View (p->full_type) == gnat_entity
+ || Full_View (p->full_type) == gnat_entity))
{
update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
TREE_TYPE (gnu_decl));
+ if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
+ update_profiles_with (p->old_type);
p->old_type = NULL_TREE;
}
}
&& Is_Itype (Original_Array_Type (gnat_entity))
&& No (Freeze_Node (Original_Array_Type (gnat_entity)))
&& !present_gnu_tree (Original_Array_Type (gnat_entity)))
- gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
+ gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, false);
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);
+ tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
if (TREE_CODE (gnu_field) == COMPONENT_REF)
gnu_field = TREE_OPERAND (gnu_field, 1);
if (Is_Generic_Type (gnat_entity) && type_annotate_only)
return void_type_node;
- gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
return TREE_TYPE (gnu_decl);
return type;
}
-/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
- type has been changed to that of the parameterless procedure, except if an
- alias is already present, in which case it is returned instead. */
-
-tree
-get_minimal_subprog_decl (Entity_Id gnat_entity)
-{
- tree gnu_entity_name, gnu_ext_name;
- struct attrib *attr_list = NULL;
-
- /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
- of the handling applied here. */
-
- while (Present (Alias (gnat_entity)))
- {
- gnat_entity = Alias (gnat_entity);
- if (present_gnu_tree (gnat_entity))
- return get_gnu_tree (gnat_entity);
- }
-
- gnu_entity_name = get_entity_name (gnat_entity);
- gnu_ext_name = create_concat_name (gnat_entity, NULL);
-
- if (Has_Stdcall_Convention (gnat_entity))
- prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("stdcall"), NULL_TREE,
- gnat_entity);
- else if (Has_Thiscall_Convention (gnat_entity))
- prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("thiscall"), NULL_TREE,
- gnat_entity);
-
- if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
- gnu_ext_name = NULL_TREE;
-
- return
- create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
- is_disabled, false, true, true, false, true, false,
- attr_list, gnat_entity);
-}
-
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent.
bool
is_cplusplus_method (Entity_Id gnat_entity)
{
- /* Check that the subprogram has C++ convention. */
- if (Convention (gnat_entity) != Convention_CPP)
- return false;
-
/* A constructor is a method on the C++ side. We deal with it now because
it is declared without the 'this' parameter in the sources and, although
the front-end will create a version with the 'this' parameter for code
if (Is_Constructor (gnat_entity))
return true;
+ /* Check that the subprogram has C++ convention. */
+ if (Convention (gnat_entity) != Convention_CPP)
+ return false;
+
/* And that the type of the first parameter (indirectly) has it too. */
Entity_Id gnat_first = First_Formal (gnat_entity);
if (No (gnat_first))
if (Convention (gnat_type) != Convention_CPP)
return false;
- /* This is the main case: C++ method imported as a primitive operation.
- Note that a C++ class with no virtual functions can be imported as a
- limited record type so the operation is not necessarily dispatching. */
- if (Is_Primitive (gnat_entity))
+ /* This is the main case: a C++ virtual method imported as a primitive
+ operation of a tagged type. */
+ if (Is_Dispatching_Operation (gnat_entity))
+ return true;
+
+ /* This is set on the E_Subprogram_Type built for a dispatching call. */
+ if (Is_Dispatch_Table_Entity (gnat_entity))
return true;
/* A thunk needs to be handled like its associated primitive operation. */
if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
return true;
- /* This is set on the E_Subprogram_Type built for a dispatching call. */
- if (Is_Dispatch_Table_Entity (gnat_entity))
- return true;
+ /* Now on to the annoying case: a C++ non-virtual method, imported either
+ as a non-primitive operation of a tagged type or as a primitive operation
+ of an untagged type. We cannot reliably differentiate these cases from
+ their static member or regular function equivalents in Ada, so we ask
+ the C++ side through the mangled name of the function, as the implicit
+ 'this' parameter is not encoded in the mangled name of a method. */
+ if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
+ {
+ String_Pointer sp = { NULL, NULL };
+ Get_External_Name (gnat_entity, false, sp);
+
+ void *mem;
+ struct demangle_component *cmp
+ = cplus_demangle_v3_components (Name_Buffer,
+ DMGL_GNU_V3
+ | DMGL_TYPES
+ | DMGL_PARAMS
+ | DMGL_RET_DROP,
+ &mem);
+ if (!cmp)
+ return false;
+
+ /* We need to release MEM once we have a successful demangling. */
+ bool ret = false;
+
+ if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
+ && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
+ && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
+ && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
+ {
+ /* Make sure there is at least one parameter in C++ too. */
+ if (cmp->u.s_binary.left)
+ {
+ unsigned int n_ada_args = 0;
+ do {
+ n_ada_args++;
+ gnat_first = Next_Formal (gnat_first);
+ } while (Present (gnat_first));
+
+ unsigned int n_cpp_args = 0;
+ do {
+ n_cpp_args++;
+ cmp = cmp->u.s_binary.right;
+ } while (cmp);
+
+ if (n_cpp_args < n_ada_args)
+ ret = true;
+ }
+ else
+ ret = true;
+ }
+
+ free (mem);
+
+ return ret;
+ }
return false;
}
{
struct incomplete *p, *next;
- p = defer_limited_with;
- defer_limited_with = NULL;
+ p = defer_limited_with_list;
+ defer_limited_with_list = NULL;
for (; p; p = next)
{
next = p->next;
if (p->old_type)
- update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
- gnat_to_gnu_type (p->full_type));
+ {
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
+ gnat_to_gnu_type (p->full_type));
+ if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
+ update_profiles_with (p->old_type);
+ }
+
free (p);
}
}
-/* Return the equivalent type to be used for GNAT_ENTITY, if it's a
- kind of type (such E_Task_Type) that has a different type which Gigi
- uses for its representation. If the type does not have a special type
- for its representation, return GNAT_ENTITY. If a type is supposed to
- exist, but does not, abort unless annotating types, in which case
- return Empty. If GNAT_ENTITY is Empty, return Empty. */
+/* Return the equivalent type to be used for GNAT_ENTITY, if it's a kind
+ of type (such E_Task_Type) that has a different type which Gigi uses
+ for its representation. If the type does not have a special type for
+ its representation, return GNAT_ENTITY. */
Entity_Id
Gigi_Equivalent_Type (Entity_Id gnat_entity)
case E_Access_Protected_Subprogram_Type:
case E_Anonymous_Access_Protected_Subprogram_Type:
- gnat_equiv = Equivalent_Type (gnat_entity);
+ if (Present (Equivalent_Type (gnat_entity)))
+ gnat_equiv = Equivalent_Type (gnat_entity);
break;
case E_Class_Wide_Type:
gnat_equiv = Root_Type (gnat_entity);
break;
- case E_Task_Type:
- case E_Task_Subtype:
case E_Protected_Type:
case E_Protected_Subtype:
- gnat_equiv = Corresponding_Record_Type (gnat_entity);
+ case E_Task_Type:
+ case E_Task_Subtype:
+ if (Present (Corresponding_Record_Type (gnat_entity)))
+ gnat_equiv = Corresponding_Record_Type (gnat_entity);
break;
default:
break;
}
- gcc_assert (Present (gnat_equiv) || type_annotate_only);
-
return gnat_equiv;
}
const Entity_Id gnat_type = Component_Type (gnat_array);
tree gnu_type = gnat_to_gnu_type (gnat_type);
tree gnu_comp_size;
+ unsigned int max_align;
+
+ /* If an alignment is specified, use it as a cap on the component type
+ so that it can be honored for the whole type. But ignore it for the
+ original type of packed array types. */
+ if (No (Packed_Array_Impl_Type (gnat_array))
+ && Known_Alignment (gnat_array))
+ max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
+ else
+ max_align = 0;
/* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_array)
- || Has_Component_Size_Clause (gnat_array))
+ if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
&& !Is_Bit_Packed_Array (gnat_array)
&& !Has_Aliased_Components (gnat_array)
&& !Strict_Alignment (gnat_type)
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
- gnu_type = make_packable_type (gnu_type, false);
-
- if (Has_Atomic_Components (gnat_array))
- check_ok_for_atomic_type (gnu_type, gnat_array, true);
+ gnu_type = make_packable_type (gnu_type, false, max_align);
/* Get and validate any specified Component_Size. */
gnu_comp_size
Is_Bit_Packed_Array (gnat_array) ? TYPE_DECL : VAR_DECL,
true, Has_Component_Size_Clause (gnat_array));
- /* If the array has aliased components and the component size can be zero,
- force at least unit size to ensure that the components have distinct
- addresses. */
- if (!gnu_comp_size
- && Has_Aliased_Components (gnat_array)
- && (integer_zerop (TYPE_SIZE (gnu_type))
- || (TREE_CODE (gnu_type) == ARRAY_TYPE
- && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))))
- gnu_comp_size
- = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
-
/* If the component type is a RECORD_TYPE that has a self-referential size,
then use the maximum size for the component size. */
if (!gnu_comp_size
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
+ /* If the array has aliased components and the component size is zero, force
+ the unit size to ensure that the components have distinct addresses. */
+ if (!gnu_comp_size
+ && Has_Aliased_Components (gnat_array)
+ && integer_zerop (TYPE_SIZE (gnu_type)))
+ gnu_comp_size = bitsize_unit_node;
+
/* Honor the component size. This is not needed for bit-packed arrays. */
if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
{
tree orig_type = gnu_type;
- unsigned int max_align;
-
- /* If an alignment is specified, use it as a cap on the component type
- so that it can be honored for the whole type. But ignore it for the
- original type of packed array types. */
- if (No (Packed_Array_Impl_Type (gnat_array))
- && Known_Alignment (gnat_array))
- max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
- else
- max_align = 0;
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
gnat_array);
}
+ /* This is a very special case where the array has aliased components and the
+ component size might be zero at run time. As explained above, we force at
+ least the unit size but we don't want to build a distinct padding type for
+ each invocation (they are not canonicalized if they have variable size) so
+ we cache this special padding type as TYPE_PADDING_FOR_COMPONENT. */
+ else if (Has_Aliased_Components (gnat_array)
+ && TREE_CODE (gnu_type) == ARRAY_TYPE
+ && !TREE_CONSTANT (TYPE_SIZE (gnu_type)))
+ {
+ if (TYPE_PADDING_FOR_COMPONENT (gnu_type))
+ gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
+ else
+ {
+ gnu_comp_size
+ = size_binop (MAX_EXPR, TYPE_SIZE (gnu_type), bitsize_unit_node);
+ TYPE_PADDING_FOR_COMPONENT (gnu_type)
+ = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
+ true, false, definition, true);
+ gnu_type = TYPE_PADDING_FOR_COMPONENT (gnu_type);
+ create_type_decl (TYPE_NAME (gnu_type), gnu_type, true, debug_info_p,
+ gnat_array);
+ }
+ }
+
+ if (Has_Atomic_Components (gnat_array) || Is_Atomic_Or_VFA (gnat_type))
+ check_ok_for_atomic_type (gnu_type, gnat_array, true);
+
/* If the component type is a padded type made for a non-bit-packed array
of scalars with reverse storage order, we need to propagate the reverse
storage order to the padding type since it is the innermost enclosing
return gnu_type;
}
-/* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
- using MECH as its passing mechanism, to be placed in the parameter
- list built for GNAT_SUBPROG. Assume a foreign convention for the
- latter if FOREIGN is true. Also set CICO to true if the parameter
- must use the copy-in copy-out implementation mechanism.
+/* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
+ in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
+ the type of the parameter. FIRST is true if this is the first parameter in
+ the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
+ the copy-in copy-out implementation mechanism.
- The returned tree is a PARM_DECL, except for those cases where no
- parameter needs to be actually passed to the subprogram; the type
- of this "shadow" parameter is then returned instead. */
+ The returned tree is a PARM_DECL, except for the cases where no parameter
+ needs to be actually passed to the subprogram; the type of this "shadow"
+ parameter is then returned instead. */
static tree
-gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
- Entity_Id gnat_subprog, bool foreign, bool *cico)
+gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
+ Entity_Id gnat_subprog, bool *cico)
{
+ Entity_Id gnat_param_type = Etype (gnat_param);
+ Mechanism_Type mech = Mechanism (gnat_param);
tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
+ bool foreign = Has_Foreign_Convention (gnat_subprog);
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
bool by_return = false, by_component_ptr = false;
bool by_ref = false;
bool restricted_aliasing_p = false;
+ location_t saved_location = input_location;
tree gnu_param;
- /* Copy-return is used only for the first parameter of a valued procedure.
- It's a copy mechanism for which a parameter is never allocated. */
- if (mech == By_Copy_Return)
+ /* Make sure to use the proper SLOC for vector ABI warnings. */
+ if (VECTOR_TYPE_P (gnu_param_type))
+ Sloc_to_locus (Sloc (gnat_subprog), &input_location);
+
+ /* Builtins are expanded inline and there is no real call sequence involved.
+ So the type expected by the underlying expander is always the type of the
+ argument "as is". */
+ if (Convention (gnat_subprog) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_subprog)))
+ mech = By_Copy;
+
+ /* Handle the first parameter of a valued procedure specially: it's a copy
+ mechanism for which the parameter is never allocated. */
+ else if (first && Is_Valued_Procedure (gnat_subprog))
{
gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
mech = By_Copy;
by_return = true;
}
+ /* Or else, see if a Mechanism was supplied that forced this parameter
+ to be passed one way or another. */
+ else if (mech == Default || mech == By_Copy || mech == By_Reference)
+ ;
+
+ /* Positive mechanism means by copy for sufficiently small parameters. */
+ else if (mech > 0)
+ {
+ if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
+ || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
+ || compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
+ mech = By_Reference;
+ else
+ mech = By_Copy;
+ }
+
+ /* Otherwise, it's an unsupported mechanism so error out. */
+ else
+ {
+ post_error ("unsupported mechanism for&", gnat_param);
+ mech = Default;
+ }
+
/* If this is either a foreign function or if the underlying type won't
be passed by reference and is as aligned as the original type, strip
off possible padding type. */
}
/* If this is a read-only parameter, make a variant of the type that is
- read-only. ??? However, if this is an unconstrained array, that type
- can be very complex, so skip it for now. Likewise for any other
- self-referential type. */
- if (ro_param
- && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
+ read-only. ??? However, if this is a self-referential type, the type
+ can be very complex, so skip it for now. */
+ if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
/* For foreign conventions, pass arrays as pointers to the element type.
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
- /* For GCC builtins, pass Address integer types as (void *) */
- if (Convention (gnat_subprog) == Convention_Intrinsic
- && Present (Interface_Name (gnat_subprog))
- && Is_Descendent_Of_Address (Etype (gnat_param)))
- gnu_param_type = ptr_type_node;
-
/* Arrays are passed as pointers to element type for foreign conventions. */
if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{
gnu_param_type
= make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
- /* If we must pass or were requested to pass by reference, do so.
+ /* If we were requested or muss pass by reference, do so.
If we were requested to pass by copy, do so.
Otherwise, for foreign conventions, pass In Out or Out parameters
or aggregates by reference. For COBOL and Fortran, pass all
integer and FP types that way too. For Convention Ada, use
the standard Ada default. */
- else if (must_pass_by_ref (gnu_param_type)
- || mech == By_Reference
+ else if (mech == By_Reference
+ || must_pass_by_ref (gnu_param_type)
|| (mech != By_Copy
&& ((foreign
&& (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
|| (!foreign
&& default_pass_by_ref (gnu_param_type)))))
{
- gnu_param_type = build_reference_type (gnu_param_type);
/* We take advantage of 6.2(12) by considering that references built for
parameters whose type isn't by-ref and for which the mechanism hasn't
been forced to by-ref allow only a restricted form of aliasing. */
restricted_aliasing_p
= !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
+ gnu_param_type = build_reference_type (gnu_param_type);
by_ref = true;
}
else if (!in_param)
*cico = true;
+ input_location = saved_location;
+
if (mech == By_Copy && (by_ref || by_component_ptr))
post_error ("?cannot pass & by copy", gnat_param);
&& (by_return
|| (!POINTER_TYPE_P (gnu_param_type)
&& !AGGREGATE_TYPE_P (gnu_param_type)
- && !Has_Default_Aspect (Etype (gnat_param))))
- && !(Is_Array_Type (Etype (gnat_param))
- && Is_Packed (Etype (gnat_param))
- && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
+ && !Has_Default_Aspect (gnat_param_type)))
+ && !(Is_Array_Type (gnat_param_type)
+ && Is_Packed (gnat_param_type)
+ && Is_Composite_Type (Component_Type (gnat_param_type))))
return gnu_param_type;
- gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
- ro_param || by_ref || by_component_ptr);
+ gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
+ TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
+ Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */
return gnu_param;
}
-/* Return true if GNAT_ENTITY is an incomplete entity coming from a limited
- with of the main unit and whose full view has not been elaborated yet. */
+/* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
+ GNAT_SUBPROG is updated when GNU_TYPE is completed.
-static bool
-is_from_limited_with_of_main (Entity_Id gnat_entity)
+ Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
+ the corresponding profile, which means that, by the time the freeze node
+ of the subprogram is encountered, types involved in its profile may still
+ be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
+ the freeze node of types involved in its profile, either types of formal
+ parameters or the return type. */
+
+static void
+associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
{
- /* Class-wide types are always transformed into their root type. */
- if (Ekind (gnat_entity) == E_Class_Wide_Type)
- gnat_entity = Root_Type (gnat_entity);
+ gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
- if (IN (Ekind (gnat_entity), Incomplete_Kind)
- && From_Limited_With (gnat_entity))
+ struct tree_entity_vec_map in;
+ in.base.from = gnu_type;
+ struct tree_entity_vec_map **slot
+ = dummy_to_subprog_map->find_slot (&in, INSERT);
+ if (!*slot)
{
- Entity_Id gnat_full_view = Non_Limited_View (gnat_entity);
+ tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
+ e->base.from = gnu_type;
+ e->to = NULL;
+ *slot = e;
+ }
- if (present_gnu_tree (gnat_full_view))
- return false;
+ /* Even if there is already a slot for GNU_TYPE, we need to set the flag
+ because the vector might have been just emptied by update_profiles_with.
+ This can happen when there are 2 freeze nodes associated with different
+ views of the same type; the type will be really complete only after the
+ second freeze node is encountered. */
+ TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
+
+ vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
+
+ /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
+ since this would mean updating twice its profile. */
+ if (v)
+ {
+ const unsigned len = v->length ();
+ unsigned int l = 0, u = len;
+
+ /* Entity_Id is a simple integer so we can implement a stable order on
+ the vector with an ordered insertion scheme and binary search. */
+ while (l < u)
+ {
+ unsigned int m = (l + u) / 2;
+ int diff = (int) (*v)[m] - (int) gnat_subprog;
+ if (diff > 0)
+ u = m;
+ else if (diff < 0)
+ l = m + 1;
+ else
+ return;
+ }
- return In_Extended_Main_Code_Unit (gnat_full_view);
+ /* l == u and therefore is the insertion point. */
+ vec_safe_insert (v, l, gnat_subprog);
}
+ else
+ vec_safe_push (v, gnat_subprog);
- return false;
+ (*slot)->to = v;
+}
+
+/* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
+
+static void
+update_profile (Entity_Id gnat_subprog)
+{
+ tree gnu_param_list;
+ tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
+ Needs_Debug_Info (gnat_subprog),
+ &gnu_param_list);
+ if (DECL_P (gnu_type))
+ {
+ /* Builtins cannot have their address taken so we can reset them. */
+ gcc_assert (DECL_BUILT_IN (gnu_type));
+ save_gnu_tree (gnat_subprog, NULL_TREE, false);
+ save_gnu_tree (gnat_subprog, gnu_type, false);
+ return;
+ }
+
+ tree gnu_subprog = get_gnu_tree (gnat_subprog);
+
+ TREE_TYPE (gnu_subprog) = gnu_type;
+
+ /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
+ and needs to be adjusted too. */
+ if (Ekind (gnat_subprog) != E_Subprogram_Type)
+ {
+ tree gnu_entity_name = get_entity_name (gnat_subprog);
+ tree gnu_ext_name
+ = gnu_ext_name_for_subprog (gnat_subprog, gnu_entity_name);
+
+ DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
+ finish_subprog_decl (gnu_subprog, gnu_ext_name, gnu_type);
+ }
+}
+
+/* Update the GCC trees previously built for the profiles involving GNU_TYPE,
+ a dummy type which appears in profiles. */
+
+void
+update_profiles_with (tree gnu_type)
+{
+ struct tree_entity_vec_map in;
+ in.base.from = gnu_type;
+ struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
+ gcc_assert (e);
+ vec<Entity_Id, va_gc_atomic> *v = e->to;
+ e->to = NULL;
+
+ /* The flag needs to be reset before calling update_profile, in case
+ associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
+ TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
+
+ unsigned int i;
+ Entity_Id *iter;
+ FOR_EACH_VEC_ELT (*v, i, iter)
+ update_profile (*iter);
+
+ vec_free (v);
+}
+
+/* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
+
+ Ada 2012 (AI05-0151) says that incomplete types coming from a limited
+ context may now appear as parameter and result types. As a consequence,
+ we may need to defer their translation until after a freeze node is seen
+ or to the end of the current unit. We also aim at handling temporarily
+ incomplete types created by the usual delayed elaboration scheme. */
+
+static tree
+gnat_to_gnu_profile_type (Entity_Id gnat_type)
+{
+ /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
+ so the rationale is exposed in that place. These processings probably
+ ought to be merged at some point. */
+ Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
+ const bool is_from_limited_with
+ = (Is_Incomplete_Type (gnat_equiv)
+ && From_Limited_With (gnat_equiv));
+ Entity_Id gnat_full_direct_first
+ = (is_from_limited_with
+ ? Non_Limited_View (gnat_equiv)
+ : (Is_Incomplete_Or_Private_Type (gnat_equiv)
+ ? Full_View (gnat_equiv) : Empty));
+ Entity_Id gnat_full_direct
+ = ((is_from_limited_with
+ && Present (gnat_full_direct_first)
+ && Is_Private_Type (gnat_full_direct_first))
+ ? Full_View (gnat_full_direct_first)
+ : gnat_full_direct_first);
+ Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
+ Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
+ const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
+ tree gnu_type;
+
+ if (Present (gnat_full) && present_gnu_tree (gnat_full))
+ gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
+
+ else if (is_from_limited_with
+ && ((!in_main_unit
+ && !present_gnu_tree (gnat_equiv)
+ && Present (gnat_full)
+ && (Is_Record_Type (gnat_full)
+ || Is_Array_Type (gnat_full)
+ || Is_Access_Type (gnat_full)))
+ || (in_main_unit && Present (Freeze_Node (gnat_rep)))))
+ {
+ gnu_type = make_dummy_type (gnat_equiv);
+
+ if (!in_main_unit)
+ {
+ struct incomplete *p = XNEW (struct incomplete);
+
+ p->old_type = gnu_type;
+ p->full_type = gnat_equiv;
+ p->next = defer_limited_with_list;
+ defer_limited_with_list = p;
+ }
+ }
+
+ else if (type_annotate_only && No (gnat_equiv))
+ gnu_type = void_type_node;
+
+ else
+ gnu_type = gnat_to_gnu_type (gnat_equiv);
+
+ /* Access-to-unconstrained-array types need a special treatment. */
+ if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
+ {
+ if (!TYPE_POINTER_TO (gnu_type))
+ build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
+ }
+
+ return gnu_type;
+}
+
+/* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
+ DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
+ is true if we need to write debug information for other types that we may
+ create in the process. Also set PARAM_LIST to the list of parameters.
+ If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
+ directly instead of its type. */
+
+static tree
+gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
+ bool debug_info_p, tree *param_list)
+{
+ const Entity_Kind kind = Ekind (gnat_subprog);
+ Entity_Id gnat_return_type = Etype (gnat_subprog);
+ Entity_Id gnat_param;
+ tree gnu_type = present_gnu_tree (gnat_subprog)
+ ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
+ tree gnu_return_type;
+ tree gnu_param_type_list = NULL_TREE;
+ tree gnu_param_list = NULL_TREE;
+ /* Non-null for subprograms containing parameters passed by copy-in copy-out
+ (In Out or Out parameters not passed by reference), in which case it is
+ the list of nodes used to specify the values of the In Out/Out parameters
+ that are returned as a record upon procedure return. The TREE_PURPOSE of
+ an element of this list is a FIELD_DECL of the record and the TREE_VALUE
+ is the PARM_DECL corresponding to that field. This list will be saved in
+ the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
+ tree gnu_cico_list = NULL_TREE;
+ tree gnu_cico_return_type = NULL_TREE;
+ /* Fields in return type of procedure with copy-in copy-out parameters. */
+ tree gnu_field_list = NULL_TREE;
+ /* The semantics of "pure" in Ada essentially matches that of "const"
+ in the back-end. In particular, both properties are orthogonal to
+ the "nothrow" property if the EH circuitry is explicit in the
+ internal representation of the back-end. If we are to completely
+ hide the EH circuitry from it, we need to declare that calls to pure
+ Ada subprograms that can throw have side effects since they can
+ trigger an "abnormal" transfer of control flow; thus they can be
+ neither "const" nor "pure" in the back-end sense. */
+ bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
+ bool return_by_direct_ref_p = false;
+ bool return_by_invisi_ref_p = false;
+ bool return_unconstrained_p = false;
+ bool incomplete_profile_p = false;
+ unsigned int num;
+
+ /* Look into the return type and get its associated GCC tree if it is not
+ void, and then compute various flags for the subprogram type. But make
+ sure not to do this processing multiple times. */
+ if (Ekind (gnat_return_type) == E_Void)
+ gnu_return_type = void_type_node;
+
+ else if (gnu_type
+ && TREE_CODE (gnu_type) == FUNCTION_TYPE
+ && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
+ {
+ gnu_return_type = TREE_TYPE (gnu_type);
+ return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
+ return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
+ return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
+ }
+
+ else
+ {
+ /* For foreign convention subprograms, return System.Address as void *
+ or equivalent. Note that this comprises GCC builtins. */
+ if (Has_Foreign_Convention (gnat_subprog)
+ && Is_Descendant_Of_Address (Underlying_Type (gnat_return_type)))
+ gnu_return_type = ptr_type_node;
+ else
+ gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
+
+ /* If this function returns by reference, make the actual return type
+ the reference type and make a note of that. */
+ if (Returns_By_Ref (gnat_subprog))
+ {
+ gnu_return_type = build_reference_type (gnu_return_type);
+ return_by_direct_ref_p = true;
+ }
+
+ /* If the return type is an unconstrained array type, the return value
+ will be allocated on the secondary stack so the actual return type
+ is the fat pointer type. */
+ else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* This is the same unconstrained array case, but for a dummy type. */
+ else if (TYPE_REFERENCE_TO (gnu_return_type)
+ && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
+ {
+ gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* Likewise, if the return type requires a transient scope, the return
+ value will also be allocated on the secondary stack so the actual
+ return type is the reference type. */
+ else if (Requires_Transient_Scope (gnat_return_type))
+ {
+ gnu_return_type = build_reference_type (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* If the Mechanism is By_Reference, ensure this function uses the
+ target's by-invisible-reference mechanism, which may not be the
+ same as above (e.g. it might be passing an extra parameter). */
+ else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
+ return_by_invisi_ref_p = true;
+
+ /* Likewise, if the return type is itself By_Reference. */
+ else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
+ return_by_invisi_ref_p = true;
+
+ /* If the type is a padded type and the underlying type would not be
+ passed by reference or the function has a foreign convention, return
+ the underlying type. */
+ else if (TYPE_IS_PADDING_P (gnu_return_type)
+ && (!default_pass_by_ref
+ (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
+ || Has_Foreign_Convention (gnat_subprog)))
+ gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
+
+ /* If the return type is unconstrained, it must have a maximum size.
+ Use the padded type as the effective return type. And ensure the
+ function uses the target's by-invisible-reference mechanism to
+ avoid copying too much data when it returns. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
+ {
+ tree orig_type = gnu_return_type;
+ tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
+
+ /* If the size overflows to 0, set it to an arbitrary positive
+ value so that assignments in the type are preserved. Their
+ actual size is independent of this positive value. */
+ if (TREE_CODE (max_return_size) == INTEGER_CST
+ && TREE_OVERFLOW (max_return_size)
+ && integer_zerop (max_return_size))
+ {
+ max_return_size = copy_node (bitsize_unit_node);
+ TREE_OVERFLOW (max_return_size) = 1;
+ }
+
+ gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
+ 0, gnat_subprog, false, false,
+ definition, true);
+
+ /* Declare it now since it will never be declared otherwise. This
+ is necessary to ensure that its subtrees are properly marked. */
+ if (gnu_return_type != orig_type
+ && !DECL_P (TYPE_NAME (gnu_return_type)))
+ create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
+ true, debug_info_p, gnat_subprog);
+
+ return_by_invisi_ref_p = true;
+ }
+
+ /* If the return type has a size that overflows, we usually cannot have
+ a function that returns that type. This usage doesn't really make
+ sense anyway, so issue an error here. */
+ if (!return_by_invisi_ref_p
+ && TYPE_SIZE_UNIT (gnu_return_type)
+ && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
+ && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
+ {
+ post_error ("cannot return type whose size overflows", gnat_subprog);
+ gnu_return_type = copy_type (gnu_return_type);
+ TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
+ }
+
+ /* If the return type is incomplete, there are 2 cases: if the function
+ returns by reference, then the return type is only linked indirectly
+ in the profile, so the profile can be seen as complete since it need
+ not be further modified, only the reference types need be adjusted;
+ otherwise the profile is incomplete and need be adjusted too. */
+ if (TYPE_IS_DUMMY_P (gnu_return_type))
+ {
+ associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
+ incomplete_profile_p = true;
+ }
+
+ if (kind == E_Function)
+ Set_Mechanism (gnat_subprog, return_unconstrained_p
+ || return_by_direct_ref_p
+ || return_by_invisi_ref_p
+ ? By_Reference : By_Copy);
+ }
+
+ /* A procedure (something that doesn't return anything) shouldn't be
+ considered const since there would be no reason for calling such a
+ subprogram. Note that procedures with Out (or In Out) parameters
+ have already been converted into a function with a return type.
+ Similarly, if the function returns an unconstrained type, then the
+ function will allocate the return value on the secondary stack and
+ thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
+ if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
+ const_flag = false;
+
+ /* Loop over the parameters and get their associated GCC tree. While doing
+ this, build a copy-in copy-out structure if we need one. */
+ for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
+ Present (gnat_param);
+ gnat_param = Next_Formal_With_Extras (gnat_param), num++)
+ {
+ const bool mech_is_by_ref
+ = Mechanism (gnat_param) == By_Reference
+ && !(num == 0 && Is_Valued_Procedure (gnat_subprog));
+ tree gnu_param_name = get_entity_name (gnat_param);
+ tree gnu_param, gnu_param_type;
+ bool cico = false;
+
+ /* Fetch an existing parameter with complete type and reuse it. But we
+ didn't save the CICO property so we can only do it for In parameters
+ or parameters passed by reference. */
+ if ((Ekind (gnat_param) == E_In_Parameter || mech_is_by_ref)
+ && present_gnu_tree (gnat_param)
+ && (gnu_param = get_gnu_tree (gnat_param))
+ && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param)))
+ {
+ DECL_CHAIN (gnu_param) = NULL_TREE;
+ gnu_param_type = TREE_TYPE (gnu_param);
+ }
+
+ /* Otherwise translate the parameter type and act accordingly. */
+ else
+ {
+ Entity_Id gnat_param_type = Etype (gnat_param);
+
+ /* For foreign convention subprograms, pass System.Address as void *
+ or equivalent. Note that this comprises GCC builtins. */
+ if (Has_Foreign_Convention (gnat_subprog)
+ && Is_Descendant_Of_Address (Underlying_Type (gnat_param_type)))
+ gnu_param_type = ptr_type_node;
+ else
+ gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
+
+ /* If the parameter type is incomplete, there are 2 cases: if it is
+ passed by reference, then the type is only linked indirectly in
+ the profile, so the profile can be seen as complete since it need
+ not be further modified, only the reference type need be adjusted;
+ otherwise the profile is incomplete and need be adjusted too. */
+ if (TYPE_IS_DUMMY_P (gnu_param_type))
+ {
+ Node_Id gnat_decl;
+
+ if (mech_is_by_ref
+ || (TYPE_REFERENCE_TO (gnu_param_type)
+ && TYPE_IS_FAT_POINTER_P
+ (TYPE_REFERENCE_TO (gnu_param_type)))
+ || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
+ {
+ gnu_param_type = build_reference_type (gnu_param_type);
+ gnu_param
+ = create_param_decl (gnu_param_name, gnu_param_type);
+ TREE_READONLY (gnu_param) = 1;
+ DECL_BY_REF_P (gnu_param) = 1;
+ DECL_POINTS_TO_READONLY_P (gnu_param)
+ = (Ekind (gnat_param) == E_In_Parameter
+ && !Address_Taken (gnat_param));
+ Set_Mechanism (gnat_param, By_Reference);
+ Sloc_to_locus (Sloc (gnat_param),
+ &DECL_SOURCE_LOCATION (gnu_param));
+ }
+
+ /* ??? This is a kludge to support null procedures in spec taking
+ a parameter with an untagged incomplete type coming from a
+ limited context. The front-end creates a body without knowing
+ anything about the non-limited view, which is illegal Ada and
+ cannot be supported. Create a parameter with a fake type. */
+ else if (kind == E_Procedure
+ && (gnat_decl = Parent (gnat_subprog))
+ && Nkind (gnat_decl) == N_Procedure_Specification
+ && Null_Present (gnat_decl)
+ && Is_Incomplete_Type (gnat_param_type))
+ gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
+
+ else
+ {
+ /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
+ Call_to_gnu will stop if it encounters the PARM_DECL. */
+ gnu_param
+ = build_decl (input_location, PARM_DECL, gnu_param_name,
+ gnu_param_type);
+ associate_subprog_with_dummy_type (gnat_subprog,
+ gnu_param_type);
+ incomplete_profile_p = true;
+ }
+ }
+
+ /* Otherwise build the parameter declaration normally. */
+ else
+ {
+ gnu_param
+ = gnat_to_gnu_param (gnat_param, gnu_param_type, num == 0,
+ gnat_subprog, &cico);
+
+ /* We are returned either a PARM_DECL or a type if no parameter
+ needs to be passed; in either case, adjust the type. */
+ if (DECL_P (gnu_param))
+ gnu_param_type = TREE_TYPE (gnu_param);
+ else
+ {
+ gnu_param_type = gnu_param;
+ gnu_param = NULL_TREE;
+ }
+ }
+ }
+
+ /* If we have a GCC tree for the parameter, register it. */
+ save_gnu_tree (gnat_param, NULL_TREE, false);
+ if (gnu_param)
+ {
+ gnu_param_type_list
+ = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
+ gnu_param_list = chainon (gnu_param, gnu_param_list);
+ save_gnu_tree (gnat_param, gnu_param, false);
+
+ /* If a parameter is a pointer, a function may modify memory through
+ it and thus shouldn't be considered a const function. Also, the
+ memory may be modified between two calls, so they can't be CSE'ed.
+ The latter case also handles by-ref parameters. */
+ if (POINTER_TYPE_P (gnu_param_type)
+ || TYPE_IS_FAT_POINTER_P (gnu_param_type))
+ const_flag = false;
+ }
+
+ /* If the parameter uses the copy-in copy-out mechanism, allocate a field
+ for it in the return type and register the association. */
+ if (cico && !incomplete_profile_p)
+ {
+ if (!gnu_cico_list)
+ {
+ gnu_cico_return_type = make_node (RECORD_TYPE);
+
+ /* If this is a function, we also need a field for the
+ return value to be placed. */
+ if (!VOID_TYPE_P (gnu_return_type))
+ {
+ tree gnu_field
+ = create_field_decl (get_identifier ("RETVAL"),
+ gnu_return_type,
+ gnu_cico_return_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+ Sloc_to_locus (Sloc (gnat_subprog),
+ &DECL_SOURCE_LOCATION (gnu_field));
+ gnu_field_list = gnu_field;
+ gnu_cico_list
+ = tree_cons (gnu_field, void_type_node, NULL_TREE);
+ }
+
+ TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN");
+ /* Set a default alignment to speed up accesses. But we should
+ not increase the size of the structure too much, lest it does
+ not fit in return registers anymore. */
+ SET_TYPE_ALIGN (gnu_cico_return_type,
+ get_mode_alignment (ptr_mode));
+ }
+
+ tree gnu_field
+ = create_field_decl (gnu_param_name, gnu_param_type,
+ gnu_cico_return_type, NULL_TREE, NULL_TREE,
+ 0, 0);
+ Sloc_to_locus (Sloc (gnat_param),
+ &DECL_SOURCE_LOCATION (gnu_field));
+ DECL_CHAIN (gnu_field) = gnu_field_list;
+ gnu_field_list = gnu_field;
+ gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
+ }
+ }
+
+ /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
+ and finish up the return type. */
+ if (gnu_cico_list && !incomplete_profile_p)
+ {
+ /* If we have a CICO list but it has only one entry, we convert
+ this function into a function that returns this object. */
+ if (list_length (gnu_cico_list) == 1)
+ gnu_cico_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
+
+ /* Do not finalize the return type if the subprogram is stubbed
+ since structures are incomplete for the back-end. */
+ else if (Convention (gnat_subprog) != Convention_Stubbed)
+ {
+ finish_record_type (gnu_cico_return_type, nreverse (gnu_field_list),
+ 0, false);
+
+ /* Try to promote the mode of the return type if it is passed
+ in registers, again to speed up accesses. */
+ if (TYPE_MODE (gnu_cico_return_type) == BLKmode
+ && !targetm.calls.return_in_memory (gnu_cico_return_type,
+ NULL_TREE))
+ {
+ unsigned int size
+ = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type));
+ unsigned int i = BITS_PER_UNIT;
+ scalar_int_mode mode;
+
+ while (i < size)
+ i <<= 1;
+ if (int_mode_for_size (i, 0).exists (&mode))
+ {
+ SET_TYPE_MODE (gnu_cico_return_type, mode);
+ SET_TYPE_ALIGN (gnu_cico_return_type,
+ GET_MODE_ALIGNMENT (mode));
+ TYPE_SIZE (gnu_cico_return_type)
+ = bitsize_int (GET_MODE_BITSIZE (mode));
+ TYPE_SIZE_UNIT (gnu_cico_return_type)
+ = size_int (GET_MODE_SIZE (mode));
+ }
+ }
+
+ if (debug_info_p)
+ rest_of_record_type_compilation (gnu_cico_return_type);
+ }
+
+ gnu_return_type = gnu_cico_return_type;
+ }
+
+ /* The lists have been built in reverse. */
+ gnu_param_type_list = nreverse (gnu_param_type_list);
+ gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
+ *param_list = nreverse (gnu_param_list);
+ gnu_cico_list = nreverse (gnu_cico_list);
+
+ /* If the profile is incomplete, we only set the (temporary) return and
+ parameter types; otherwise, we build the full type. In either case,
+ we reuse an already existing GCC tree that we built previously here. */
+ if (incomplete_profile_p)
+ {
+ if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
+ ;
+ else
+ gnu_type = make_node (FUNCTION_TYPE);
+ TREE_TYPE (gnu_type) = gnu_return_type;
+ TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ }
+ else
+ {
+ if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
+ {
+ TREE_TYPE (gnu_type) = gnu_return_type;
+ TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
+ TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ TYPE_CANONICAL (gnu_type) = gnu_type;
+ layout_type (gnu_type);
+ }
+ else
+ {
+ gnu_type
+ = build_function_type (gnu_return_type, gnu_param_type_list);
+
+ /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
+ has a different TYPE_CI_CO_LIST or flags. */
+ if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
+ return_unconstrained_p,
+ return_by_direct_ref_p,
+ return_by_invisi_ref_p))
+ {
+ gnu_type = copy_type (gnu_type);
+ TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ }
+ }
+
+ if (const_flag)
+ gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
+
+ if (No_Return (gnat_subprog))
+ gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
+
+ /* If this subprogram is expectedly bound to a GCC builtin, fetch the
+ corresponding DECL node and check the parameter association. */
+ if (Convention (gnat_subprog) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_subprog)))
+ {
+ tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
+ tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
+
+ /* If we have a builtin DECL for that function, use it. Check if
+ the profiles are compatible and warn if they are not. Note that
+ the checker is expected to post diagnostics in this case. */
+ if (gnu_builtin_decl)
+ {
+ intrin_binding_t inb
+ = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) };
+
+ if (!intrin_profiles_compatible_p (&inb))
+ post_error
+ ("?profile of& doesn''t match the builtin it binds!",
+ gnat_subprog);
+
+ return gnu_builtin_decl;
+ }
+
+ /* Inability to find the builtin DECL most often indicates a genuine
+ mistake, but imports of unregistered intrinsics are sometimes used
+ on purpose to allow hooking in alternate bodies; we post a warning
+ conditioned on Wshadow in this case, to let developers be notified
+ on demand without risking false positives with common default sets
+ of options. */
+ if (warn_shadow)
+ post_error ("?gcc intrinsic not found for&!", gnat_subprog);
+ }
+ }
+
+ return gnu_type;
+}
+
+/* Return the external name for GNAT_SUBPROG given its entity name. */
+
+static tree
+gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name)
+{
+ tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
+
+ /* If there was no specified Interface_Name and the external and
+ internal names of the subprogram are the same, only use the
+ internal name to allow disambiguation of nested subprograms. */
+ if (No (Interface_Name (gnat_subprog)) && gnu_ext_name == gnu_entity_name)
+ gnu_ext_name = NULL_TREE;
+
+ return gnu_ext_name;
}
/* Like build_qualified_type, but TYPE_QUALS is added to the existing
static tree
change_qualified_type (tree type, int type_quals)
{
+ /* Qualifiers must be put on the associated array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ return type;
+
return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
}
+/* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
+ build_nonshared_array_type. */
+
+static void
+set_nonaliased_component_on_array_type (tree type)
+{
+ TYPE_NONALIASED_COMPONENT (type) = 1;
+ TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1;
+}
+
+/* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
+ build_nonshared_array_type. */
+
+static void
+set_reverse_storage_order_on_array_type (tree type)
+{
+ TYPE_REVERSE_STORAGE_ORDER (type) = 1;
+ TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
+}
+
/* Return true if DISCR1 and DISCR2 represent the same discriminant. */
static bool
return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
}
+ /* Consider that an array of pointers has an aliased component, which is
+ sort of logical and helps with Taft Amendment types in LTO mode. */
+ if (POINTER_TYPE_P (TREE_TYPE (gnu_type)))
+ return false;
+
/* Otherwise, rely exclusively on properties of the element type. */
return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
}
static bool
compile_time_known_address_p (Node_Id gnat_address)
{
+ /* Handle reference to a constant. */
+ if (Is_Entity_Name (gnat_address)
+ && Ekind (Entity (gnat_address)) == E_Constant)
+ {
+ gnat_address = Constant_Value (Entity (gnat_address));
+ if (No (gnat_address))
+ return false;
+ }
+
/* Catch System'To_Address. */
if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
gnat_address = Expression (gnat_address);
without one, to keep the object simpler. */
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
- && get_variant_part (gnu_type) != NULL_TREE
- && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE)
+ && get_variant_part (gnu_type)
+ && !get_variant_part (TREE_TYPE (gnu_expr)))
return false;
/* In all the other cases, convert the expression to the object's type. */
static void
prepend_one_attribute (struct attrib **attr_list,
- enum attr_type attr_type,
+ enum attrib_type attrib_type,
tree attr_name,
tree attr_args,
Node_Id attr_error_point)
{
struct attrib * attr = (struct attrib *) xmalloc (sizeof (struct attrib));
- attr->type = attr_type;
+ attr->type = attrib_type;
attr->name = attr_name;
attr->args = attr_args;
attr->error_point = attr_error_point;
{
const Node_Id gnat_arg = Pragma_Argument_Associations (gnat_pragma);
tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
- enum attr_type etype;
+ enum attrib_type etype;
/* Map the pragma at hand. Skip if this isn't one we know how to handle. */
switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_pragma))))
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
return build3 (COMPONENT_REF, TREE_TYPE (ref),
elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
- TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2));
+ TREE_OPERAND (ref, 1), NULL_TREE);
sprintf (suffix, "EXP%d", ++er->n);
return
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
-tree
+static tree
choices_to_gnu (tree operand, Node_Id choices)
{
Node_Id choice;
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
case N_Identifier:
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
}
case N_Integer_Literal:
single = gnat_to_gnu (choice);
this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
- single);
+ single, true);
break;
case N_Others_Choice:
gcc_unreachable ();
}
- result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
- this_test);
+ if (result == boolean_false_node)
+ result = this_test;
+ else
+ result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
+ this_test, true);
}
return result;
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
bool definition, bool debug_info_p)
{
+ const Entity_Id gnat_record_type = Underlying_Type (Scope (gnat_field));
const Entity_Id gnat_field_type = Etype (gnat_field);
- const bool is_aliased
- = Is_Aliased (gnat_field);
const bool is_atomic
= (Is_Atomic_Or_VFA (gnat_field) || Is_Atomic_Or_VFA (gnat_field_type));
+ const bool is_aliased = Is_Aliased (gnat_field);
const bool is_independent
= (Is_Independent (gnat_field) || Is_Independent (gnat_field_type));
const bool is_volatile
= (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
+ const bool is_strict_alignment = Strict_Alignment (gnat_field_type);
+ /* We used to consider that volatile fields also require strict alignment,
+ but that was an interpolation and would cause us to reject a pragma
+ volatile on a packed record type containing boolean components, while
+ there is no basis to do so in the RM. In such cases, the writes will
+ involve load-modify-store sequences, but that's OK for volatile. The
+ only constraint is the implementation advice whereby only the bits of
+ the components should be accessed if they both start and end on byte
+ boundaries, but that should be guaranteed by the GCC memory model. */
const bool needs_strict_alignment
- = (is_aliased
- || is_independent
- || is_volatile
- || Strict_Alignment (gnat_field_type));
+ = (is_atomic || is_aliased || is_independent || is_strict_alignment);
tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
tree gnu_field_id = get_entity_name (gnat_field);
tree gnu_field, gnu_size, gnu_pos;
}
if (Is_Atomic_Or_VFA (gnat_field))
- check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
+ {
+ const unsigned int align
+ = promote_object_alignment (gnu_field_type, gnat_field);
+ if (align > 0)
+ gnu_field_type
+ = maybe_pad_type (gnu_field_type, NULL_TREE, align, gnat_field,
+ false, false, definition, true);
+ check_ok_for_atomic_type (gnu_field_type, gnat_field, false);
+ }
if (Present (Component_Clause (gnat_field)))
{
Node_Id gnat_clause = Component_Clause (gnat_field);
- Entity_Id gnat_parent
- = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
+ Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
{
const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
- if (TYPE_ALIGN (gnu_record_type) < type_align)
- TYPE_ALIGN (gnu_record_type) = type_align;
+ if (TYPE_ALIGN (gnu_record_type)
+ && TYPE_ALIGN (gnu_record_type) < type_align)
+ SET_TYPE_ALIGN (gnu_record_type, type_align);
/* If the position is not a multiple of the alignment of the type,
then error out and reset the position. */
s = "position of aliased field& must be multiple of ^ bits";
else if (is_independent)
s = "position of independent field& must be multiple of ^ bits";
- else if (is_volatile)
- s = "position of volatile field& must be multiple of ^ bits";
- else if (Strict_Alignment (gnat_field_type))
+ else if (is_strict_alignment)
s = "position of & with aliased or tagged part must be"
" multiple of ^ bits";
else
s = "size of aliased field& must be ^ bits";
else if (is_independent)
s = "size of independent field& must be at least ^ bits";
- else if (is_volatile)
- s = "size of volatile field& must be at least ^ bits";
- else if (Strict_Alignment (gnat_field_type))
+ else if (is_strict_alignment)
s = "size of & with aliased or tagged part must be"
" at least ^ bits";
else
if (is_independent)
s = "size of independent field& must be multiple of"
" Storage_Unit";
- else if (is_volatile)
- s = "size of volatile field& must be multiple of"
- " Storage_Unit";
- else if (Strict_Alignment (gnat_field_type))
+ else if (is_strict_alignment)
s = "size of & with aliased or tagged part must be"
" multiple of Storage_Unit";
else
/* If the record has rep clauses and this is the tag field, make a rep
clause for it as well. */
- else if (Has_Specified_Layout (Scope (gnat_field))
+ else if (Has_Specified_Layout (gnat_record_type)
&& Chars (gnat_field) == Name_uTag)
{
gnu_pos = bitsize_zero_node;
/* If the field's type is justified modular, we would need to remove
the wrapper to (better) meet the layout requirements. However we
can do so only if the field is not aliased to preserve the unique
- layout and if the prescribed size is not greater than that of the
- packed array to preserve the justification. */
+ layout, if it has the same storage order as the enclosing record
+ and if the prescribed size is not greater than that of the packed
+ array to preserve the justification. */
if (!needs_strict_alignment
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
+ && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type)
+ == Reverse_Storage_Order (gnat_record_type)
&& tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
<= 0)
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
/* Now create the decl for the field. */
gnu_field
= create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
- gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
+ gnu_size, gnu_pos, packed, is_aliased);
Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
- DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field);
+ DECL_ALIASED_P (gnu_field) = is_aliased;
TREE_SIDE_EFFECTS (gnu_field) = TREE_THIS_VOLATILE (gnu_field) = is_volatile;
if (Ekind (gnat_field) == E_Discriminant)
return false;
}
-/* Return true if FIELD is a non-artificial aliased field. */
-
-static bool
-field_is_aliased (tree field)
-{
- if (field_is_artificial (field))
- return false;
-
- return DECL_ALIASED_P (field);
-}
-
/* Return true if FIELD is a non-artificial field with self-referential
size. */
return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
}
-/* qsort comparer for the bit positions of two record components. */
+/* qsort comparer for the bit positions of two record components. */
+
+static int
+compare_field_bitpos (const PTR rt1, const PTR rt2)
+{
+ const_tree const field1 = * (const_tree const *) rt1;
+ const_tree const field2 = * (const_tree const *) rt2;
+ const int ret
+ = tree_int_cst_compare (bit_position (field1), bit_position (field2));
+
+ return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
+}
+
+/* Sort the LIST of fields in reverse order of increasing position. */
+
+static tree
+reverse_sort_field_list (tree list)
+{
+ const int len = list_length (list);
+ tree *field_arr = XALLOCAVEC (tree, len);
+
+ for (int i = 0; list; list = DECL_CHAIN (list), i++)
+ field_arr[i] = list;
+
+ qsort (field_arr, len, sizeof (tree), compare_field_bitpos);
+
+ for (int i = 0; i < len; i++)
+ {
+ DECL_CHAIN (field_arr[i]) = list;
+ list = field_arr[i];
+ }
+
+ return list;
+}
+
+/* Reverse function from gnat_to_gnu_field: return the GNAT field present in
+ either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE, and
+ corresponding to the GNU tree GNU_FIELD. */
+
+static Entity_Id
+gnu_field_to_gnat (tree gnu_field, Node_Id gnat_component_list,
+ Entity_Id gnat_record_type)
+{
+ Entity_Id gnat_component_decl, gnat_field;
+
+ if (Present (Component_Items (gnat_component_list)))
+ for (gnat_component_decl
+ = First_Non_Pragma (Component_Items (gnat_component_list));
+ Present (gnat_component_decl);
+ gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
+ {
+ gnat_field = Defining_Entity (gnat_component_decl);
+ if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
+ return gnat_field;
+ }
+
+ if (Has_Discriminants (gnat_record_type))
+ for (gnat_field = First_Stored_Discriminant (gnat_record_type);
+ Present (gnat_field);
+ gnat_field = Next_Stored_Discriminant (gnat_field))
+ if (gnat_to_gnu_field_decl (gnat_field) == gnu_field)
+ return gnat_field;
+
+ return Empty;
+}
+
+/* Issue a warning for the problematic placement of GNU_FIELD present in
+ either GNAT_COMPONENT_LIST or the discriminants of GNAT_RECORD_TYPE.
+ IN_VARIANT is true if GNAT_COMPONENT_LIST is the list of a variant.
+ DO_REORDER is true if fields of GNAT_RECORD_TYPE are being reordered. */
-static int
-compare_field_bitpos (const PTR rt1, const PTR rt2)
+static void
+warn_on_field_placement (tree gnu_field, Node_Id gnat_component_list,
+ Entity_Id gnat_record_type, bool in_variant,
+ bool do_reorder)
{
- const_tree const field1 = * (const_tree const *) rt1;
- const_tree const field2 = * (const_tree const *) rt2;
- const int ret
- = tree_int_cst_compare (bit_position (field1), bit_position (field2));
+ if (!Comes_From_Source (gnat_record_type))
+ return;
- return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
+ const char *msg1
+ = in_variant
+ ? "?variant layout may cause performance issues"
+ : "?record layout may cause performance issues";
+ const char *msg2
+ = field_has_self_size (gnu_field)
+ ? "?component & whose length depends on a discriminant"
+ : field_has_variable_size (gnu_field)
+ ? "?component & whose length is not fixed"
+ : "?component & whose length is not multiple of a byte";
+ const char *msg3
+ = do_reorder
+ ? "?comes too early and was moved down"
+ : "?comes too early and ought to be moved down";
+
+ Entity_Id gnat_field
+ = gnu_field_to_gnat (gnu_field, gnat_component_list, gnat_record_type);
+
+ gcc_assert (Present (gnat_field));
+
+ post_error (msg1, gnat_field);
+ post_error_ne (msg2, gnat_field, gnat_field);
+ post_error (msg3, gnat_field);
}
/* Structure holding information for a given variant. */
} vinfo_t;
-/* Translate and chain the GNAT_COMPONENT_LIST to the GNU_FIELD_LIST, set the
- result as the field list of GNU_RECORD_TYPE and finish it up. Return true
- if GNU_RECORD_TYPE has a rep clause which affects the layout (see below).
- When called from gnat_to_gnu_entity during the processing of a record type
- definition, the GCC node for the parent, if any, will be the single field
- of GNU_RECORD_TYPE and the GCC nodes for the discriminants will be on the
- GNU_FIELD_LIST. The other calls to this function are recursive calls for
- the component list of a variant and, in this case, GNU_FIELD_LIST is empty.
+/* Translate and chain GNAT_COMPONENT_LIST present in GNAT_RECORD_TYPE to
+ GNU_FIELD_LIST, set the result as the field list of GNU_RECORD_TYPE and
+ finish it up. Return true if GNU_RECORD_TYPE has a rep clause that affects
+ the layout (see below). When called from gnat_to_gnu_entity during the
+ processing of a record definition, the GCC node for the parent, if any,
+ will be the single field of GNU_RECORD_TYPE and the GCC nodes for the
+ discriminants will be on GNU_FIELD_LIST. The other call to this function
+ is a recursive call for the component list of a variant and, in this case,
+ GNU_FIELD_LIST is empty.
PACKED is 1 if this is for a packed record or -1 if this is for a record
with Component_Alignment of Storage_Unit.
MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
mean that its contents may be unused as well, only the container itself.
- REORDER is true if we are permitted to reorder components of this type.
-
FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
the outer record type down to this variant level. It is nonzero only if
all the fields down to this level have a rep clause and ALL_REP is false.
be done with such fields and the return value will be false. */
static bool
-components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
- tree gnu_field_list, int packed, bool definition,
- bool cancel_alignment, bool all_rep,
- bool unchecked_union, bool artificial,
- bool debug_info, bool maybe_unused, bool reorder,
- tree first_free_pos, tree *p_gnu_rep_list)
+components_to_record (Node_Id gnat_component_list, Entity_Id gnat_record_type,
+ tree gnu_field_list, tree gnu_record_type, int packed,
+ bool definition, bool cancel_alignment, bool all_rep,
+ bool unchecked_union, bool artificial, bool debug_info,
+ bool maybe_unused, tree first_free_pos,
+ tree *p_gnu_rep_list)
{
const bool needs_xv_encodings
= debug_info && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL;
bool layout_with_rep = false;
bool has_self_field = false;
bool has_aliased_after_self_field = false;
- Node_Id component_decl, variant_part;
+ Entity_Id gnat_component_decl, gnat_variant_part;
tree gnu_field, gnu_next, gnu_last;
tree gnu_variant_part = NULL_TREE;
tree gnu_rep_list = NULL_TREE;
- tree gnu_var_list = NULL_TREE;
- tree gnu_self_list = NULL_TREE;
- tree gnu_zero_list = NULL_TREE;
/* For each component referenced in a component declaration create a GCC
field and add it to the list, skipping pragmas in the GNAT list. */
gnu_last = tree_last (gnu_field_list);
if (Present (Component_Items (gnat_component_list)))
- for (component_decl
+ for (gnat_component_decl
= First_Non_Pragma (Component_Items (gnat_component_list));
- Present (component_decl);
- component_decl = Next_Non_Pragma (component_decl))
+ Present (gnat_component_decl);
+ gnat_component_decl = Next_Non_Pragma (gnat_component_decl))
{
- Entity_Id gnat_field = Defining_Entity (component_decl);
+ Entity_Id gnat_field = Defining_Entity (gnat_component_decl);
Name_Id gnat_name = Chars (gnat_field);
/* If present, the _Parent field must have been created as the single
/* And record information for the final layout. */
if (field_has_self_size (gnu_field))
has_self_field = true;
- else if (has_self_field && field_is_aliased (gnu_field))
+ else if (has_self_field && DECL_ALIASED_P (gnu_field))
has_aliased_after_self_field = true;
}
}
}
/* At the end of the component list there may be a variant part. */
- variant_part = Variant_Part (gnat_component_list);
+ gnat_variant_part = Variant_Part (gnat_component_list);
/* We create a QUAL_UNION_TYPE for the variant part since the variants are
mutually exclusive and should go in the same memory. To do this we need
lists for the variants and put them all into the QUAL_UNION_TYPE.
If this is an Unchecked_Union, we make a UNION_TYPE instead or
use GNU_RECORD_TYPE if there are no fields so far. */
- if (Present (variant_part))
+ if (Present (gnat_variant_part))
{
- Node_Id gnat_discr = Name (variant_part), variant;
+ Node_Id gnat_discr = Name (gnat_variant_part), variant;
tree gnu_discr = gnat_to_gnu (gnat_discr);
tree gnu_name = TYPE_IDENTIFIER (gnu_record_type);
tree gnu_var_name
= make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
TYPE_NAME (gnu_union_type) = gnu_union_name;
- TYPE_ALIGN (gnu_union_type) = 0;
+ SET_TYPE_ALIGN (gnu_union_type, 0);
TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
= TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
the container types and computing the associated properties. However
we cannot finish up the container types during this pass because we
don't know where the variant part will be placed until the end. */
- for (variant = First_Non_Pragma (Variants (variant_part));
+ for (variant = First_Non_Pragma (Variants (gnat_variant_part));
Present (variant);
variant = Next_Non_Pragma (variant))
{
/* Set the alignment of the inner type in case we need to make
inner objects into bitfields, but then clear it out so the
record actually gets only the alignment required. */
- TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
+ SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
= TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
/* Add the fields into the record type for the variant. Note that
we aren't sure to really use it at this point, see below. */
has_rep
- = components_to_record (gnu_variant_type, Component_List (variant),
- NULL_TREE, packed, definition,
- !all_rep_and_size, all_rep,
- unchecked_union,
- true, needs_xv_encodings, true, reorder,
- this_first_free_pos,
+ = components_to_record (Component_List (variant), gnat_record_type,
+ NULL_TREE, gnu_variant_type, packed,
+ definition, !all_rep_and_size, all_rep,
+ unchecked_union, true, needs_xv_encodings,
+ true, this_first_free_pos,
all_rep || this_first_free_pos
? NULL : &gnu_rep_list);
}
}
- /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
- permitted to reorder components, self-referential sizes or variable sizes.
- If they do, pull them out and put them onto the appropriate list. We have
- to do this in a separate pass since we want to handle the discriminants
- but can't play with them until we've used them in debugging data above.
+ /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they do,
+ pull them out and put them onto the appropriate list.
Similarly, pull out the fields with zero size and no rep clause, as they
would otherwise modify the layout and thus very likely run afoul of the
Ada semantics, which are different from those of C here.
- ??? If we reorder them, debugging information will be wrong but there is
- nothing that can be done about this at the moment. */
- gnu_last = NULL_TREE;
+ Finally, if there is an aliased field placed in the list after fields
+ with self-referential size, pull out the latter in the same way.
+
+ Optionally, if the reordering mechanism is enabled, pull out the fields
+ with self-referential size, variable size and fixed size not a multiple
+ of a byte, so that they don't cause the regular fields to be either at
+ self-referential/variable offset or misaligned. Note, in the latter
+ case, that this can only happen in packed record types so the alignment
+ is effectively capped to the byte for the whole record. But we don't
+ do it for non-packed record types if pragma Optimize_Alignment (Space)
+ is specified because this can prevent alignment gaps from being filled.
+
+ Optionally, if the layout warning is enabled, keep track of the above 4
+ different kinds of fields and issue a warning if some of them would be
+ (or are being) reordered by the reordering mechanism.
+
+ ??? If we reorder fields, the debugging information will be affected and
+ the debugger print fields in a different order from the source code. */
+ const bool do_reorder
+ = (Convention (gnat_record_type) == Convention_Ada
+ && !No_Reordering (gnat_record_type)
+ && (!Optimize_Alignment_Space (gnat_record_type)
+ || Is_Packed (gnat_record_type))
+ && !debug__debug_flag_dot_r);
+ const bool w_reorder
+ = (Convention (gnat_record_type) == Convention_Ada
+ && Warn_On_Questionable_Layout
+ && !(No_Reordering (gnat_record_type) && GNAT_Mode));
+ const bool in_variant = (p_gnu_rep_list != NULL);
+ tree gnu_zero_list = NULL_TREE;
+ tree gnu_self_list = NULL_TREE;
+ tree gnu_var_list = NULL_TREE;
+ tree gnu_bitp_list = NULL_TREE;
+ tree gnu_tmp_bitp_list = NULL_TREE;
+ unsigned int tmp_bitp_size = 0;
+ unsigned int last_reorder_field_type = -1;
+ unsigned int tmp_last_reorder_field_type = -1;
#define MOVE_FROM_FIELD_LIST_TO(LIST) \
do { \
(LIST) = gnu_field; \
} while (0)
+ gnu_last = NULL_TREE;
for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
{
gnu_next = DECL_CHAIN (gnu_field);
continue;
}
- if ((reorder || has_aliased_after_self_field)
- && field_has_self_size (gnu_field))
+ if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
{
- MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
+ DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
+ SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
+ DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
+ if (DECL_ALIASED_P (gnu_field))
+ SET_TYPE_ALIGN (gnu_record_type,
+ MAX (TYPE_ALIGN (gnu_record_type),
+ TYPE_ALIGN (TREE_TYPE (gnu_field))));
+ MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
continue;
}
- if (reorder && field_has_variable_size (gnu_field))
+ if (has_aliased_after_self_field && field_has_self_size (gnu_field))
{
- MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
+ MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
continue;
}
- if (DECL_SIZE (gnu_field) && integer_zerop (DECL_SIZE (gnu_field)))
+ /* We don't need further processing in default mode. */
+ if (!w_reorder && !do_reorder)
{
- DECL_FIELD_OFFSET (gnu_field) = size_zero_node;
- SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
- DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
- if (field_is_aliased (gnu_field))
- TYPE_ALIGN (gnu_record_type)
- = MAX (TYPE_ALIGN (gnu_record_type),
- TYPE_ALIGN (TREE_TYPE (gnu_field)));
- MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
+ gnu_last = gnu_field;
continue;
}
+ if (field_has_self_size (gnu_field))
+ {
+ if (w_reorder)
+ {
+ if (last_reorder_field_type < 4)
+ warn_on_field_placement (gnu_field, gnat_component_list,
+ gnat_record_type, in_variant,
+ do_reorder);
+ else
+ last_reorder_field_type = 4;
+ }
+
+ if (do_reorder)
+ {
+ MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
+ continue;
+ }
+ }
+
+ else if (field_has_variable_size (gnu_field))
+ {
+ if (w_reorder)
+ {
+ if (last_reorder_field_type < 3)
+ warn_on_field_placement (gnu_field, gnat_component_list,
+ gnat_record_type, in_variant,
+ do_reorder);
+ else
+ last_reorder_field_type = 3;
+ }
+
+ if (do_reorder)
+ {
+ MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
+ continue;
+ }
+ }
+
+ else
+ {
+ /* If the field has no size, then it cannot be bit-packed. */
+ const unsigned int bitp_size
+ = DECL_SIZE (gnu_field)
+ ? TREE_INT_CST_LOW (DECL_SIZE (gnu_field)) % BITS_PER_UNIT
+ : 0;
+
+ /* If the field is bit-packed, we move it to a temporary list that
+ contains the contiguously preceding bit-packed fields, because
+ we want to be able to put them back if the misalignment happens
+ to cancel itself after several bit-packed fields. */
+ if (bitp_size != 0)
+ {
+ tmp_bitp_size = (tmp_bitp_size + bitp_size) % BITS_PER_UNIT;
+
+ if (last_reorder_field_type != 2)
+ {
+ tmp_last_reorder_field_type = last_reorder_field_type;
+ last_reorder_field_type = 2;
+ }
+
+ if (do_reorder)
+ {
+ MOVE_FROM_FIELD_LIST_TO (gnu_tmp_bitp_list);
+ continue;
+ }
+ }
+
+ /* No more bit-packed fields, move the existing ones to the end or
+ put them back at their original location. */
+ else if (last_reorder_field_type == 2 || gnu_tmp_bitp_list)
+ {
+ last_reorder_field_type = 1;
+
+ if (tmp_bitp_size != 0)
+ {
+ if (w_reorder && tmp_last_reorder_field_type < 2)
+ warn_on_field_placement (gnu_tmp_bitp_list
+ ? gnu_tmp_bitp_list : gnu_last,
+ gnat_component_list,
+ gnat_record_type, in_variant,
+ do_reorder);
+
+ if (do_reorder)
+ gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
+
+ gnu_tmp_bitp_list = NULL_TREE;
+ tmp_bitp_size = 0;
+ }
+ else
+ {
+ /* Rechain the temporary list in front of GNU_FIELD. */
+ tree gnu_bitp_field = gnu_field;
+ while (gnu_tmp_bitp_list)
+ {
+ tree gnu_bitp_next = DECL_CHAIN (gnu_tmp_bitp_list);
+ DECL_CHAIN (gnu_tmp_bitp_list) = gnu_bitp_field;
+ if (gnu_last)
+ DECL_CHAIN (gnu_last) = gnu_tmp_bitp_list;
+ else
+ gnu_field_list = gnu_tmp_bitp_list;
+ gnu_bitp_field = gnu_tmp_bitp_list;
+ gnu_tmp_bitp_list = gnu_bitp_next;
+ }
+ }
+ }
+
+ else
+ last_reorder_field_type = 1;
+ }
+
gnu_last = gnu_field;
}
/* If permitted, we reorder the fields as follows:
- 1) all fixed length fields,
- 2) all fields whose length doesn't depend on discriminants,
- 3) all fields whose length depends on discriminants,
- 4) the variant part,
+ 1) all (groups of) fields whose length is fixed and multiple of a byte,
+ 2) the remaining fields whose length is fixed and not multiple of a byte,
+ 3) the remaining fields whose length doesn't depend on discriminants,
+ 4) all fields whose length depends on discriminants,
+ 5) the variant part,
within the record and within each variant recursively. */
- if (reorder)
- gnu_field_list
- = chainon (gnu_field_list, chainon (gnu_var_list, gnu_self_list));
+
+ if (w_reorder)
+ {
+ /* If we have pending bit-packed fields, warn if they would be moved
+ to after regular fields. */
+ if (last_reorder_field_type == 2
+ && tmp_bitp_size != 0
+ && tmp_last_reorder_field_type < 2)
+ warn_on_field_placement (gnu_tmp_bitp_list
+ ? gnu_tmp_bitp_list : gnu_field_list,
+ gnat_component_list, gnat_record_type,
+ in_variant, do_reorder);
+ }
+
+ if (do_reorder)
+ {
+ /* If we have pending bit-packed fields on the temporary list, we put
+ them either on the bit-packed list or back on the regular list. */
+ if (gnu_tmp_bitp_list)
+ {
+ if (tmp_bitp_size != 0)
+ gnu_bitp_list = chainon (gnu_tmp_bitp_list, gnu_bitp_list);
+ else
+ gnu_field_list = chainon (gnu_tmp_bitp_list, gnu_field_list);
+ }
+
+ gnu_field_list
+ = chainon (gnu_field_list,
+ chainon (gnu_bitp_list,
+ chainon (gnu_var_list, gnu_self_list)));
+ }
/* Otherwise, if there is an aliased field placed after a field whose length
depends on discriminants, we put all the fields of the latter sort, last.
if (p_gnu_rep_list && gnu_rep_list)
*p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
+ /* Deal with the annoying case of an extension of a record with variable size
+ and partial rep clause, for which the _Parent field is forced at offset 0
+ and has variable size, which we do not support below. Note that we cannot
+ do it if the field has fixed size because we rely on the presence of the
+ REP part built below to trigger the reordering of the fields in a derived
+ record type when all the fields have a fixed position. */
+ else if (gnu_rep_list
+ && !DECL_CHAIN (gnu_rep_list)
+ && TREE_CODE (DECL_SIZE (gnu_rep_list)) != INTEGER_CST
+ && !variants_have_rep
+ && first_free_pos
+ && integer_zerop (first_free_pos)
+ && integer_zerop (bit_position (gnu_rep_list)))
+ {
+ DECL_CHAIN (gnu_rep_list) = gnu_field_list;
+ gnu_field_list = gnu_rep_list;
+ gnu_rep_list = NULL_TREE;
+ }
+
/* Otherwise, sort the fields by bit position and put them into their own
record, before the others, if we also have fields without rep clause. */
else if (gnu_rep_list)
/* Chain the variant part at the end of the field list. */
if (gnu_variant_part)
- gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
+ {
+ /* We make an exception if the variant part is at offset 0, has a fixed
+ size, and there is a single rep'ed field placed after it because, in
+ this case, there is an obvious order of increasing position. */
+ if (variants_have_rep
+ && TREE_CODE (DECL_SIZE_UNIT (gnu_variant_part)) == INTEGER_CST
+ && gnu_rep_list
+ && gnu_field_list == gnu_rep_list
+ && !tree_int_cst_lt (DECL_FIELD_OFFSET (gnu_rep_list),
+ DECL_SIZE_UNIT (gnu_variant_part)))
+ {
+ DECL_CHAIN (gnu_variant_part) = gnu_field_list;
+ gnu_field_list = gnu_variant_part;
+ }
+ else
+ gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
+ }
if (cancel_alignment)
- TYPE_ALIGN (gnu_record_type) = 0;
+ SET_TYPE_ALIGN (gnu_record_type, 0);
TYPE_ARTIFICIAL (gnu_record_type) = artificial;
static Uint
annotate_value (tree gnu_size)
{
+ static int var_count = 0;
TCode tcode;
- Node_Ref_Or_Val ops[3], ret, pre_op1 = No_Uint;
+ Node_Ref_Or_Val ops[3] = { No_Uint, No_Uint, No_Uint };
struct tree_int_map in;
- int i;
/* See if we've already saved the value for this node. */
- if (EXPR_P (gnu_size))
+ if (EXPR_P (gnu_size) || DECL_P (gnu_size))
{
struct tree_int_map *e;
in.base.from = NULL_TREE;
/* If we do not return inside this switch, TCODE will be set to the
- code to use for a Create_Node operand and LEN (set above) will be
- the number of recursive calls for us to make. */
-
+ code to be used in a call to Create_Node. */
switch (TREE_CODE (gnu_size))
{
case INTEGER_CST:
- return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
+ /* For negative values, build NEGATE_EXPR of the opposite. Such values
+ can appear for discriminants in expressions for variants. */
+ if (tree_int_cst_sgn (gnu_size) < 0)
+ {
+ tree t = wide_int_to_tree (sizetype, -wi::to_wide (gnu_size));
+ tcode = Negate_Expr;
+ ops[0] = UI_From_gnu (t);
+ }
+ else
+ return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
+ break;
case COMPONENT_REF:
/* The only case we handle here is a simple discriminant reference. */
if (DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1)))
{
- tree n = DECL_DISCRIMINANT_NUMBER (TREE_OPERAND (gnu_size, 1));
+ tree ref = gnu_size;
+ gnu_size = TREE_OPERAND (ref, 1);
/* Climb up the chain of successive extensions, if any. */
- while (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == COMPONENT_REF
- && DECL_NAME (TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 1))
+ while (TREE_CODE (TREE_OPERAND (ref, 0)) == COMPONENT_REF
+ && DECL_NAME (TREE_OPERAND (TREE_OPERAND (ref, 0), 1))
== parent_name_id)
- gnu_size = TREE_OPERAND (gnu_size, 0);
+ ref = TREE_OPERAND (ref, 0);
- if (TREE_CODE (TREE_OPERAND (gnu_size, 0)) == PLACEHOLDER_EXPR)
- return
- Create_Node (Discrim_Val, annotate_value (n), No_Uint, No_Uint);
+ if (TREE_CODE (TREE_OPERAND (ref, 0)) == PLACEHOLDER_EXPR)
+ {
+ /* Fall through to common processing as a FIELD_DECL. */
+ tcode = Discrim_Val;
+ ops[0] = UI_From_gnu (DECL_DISCRIMINANT_NUMBER (gnu_size));
+ }
+ else
+ return No_Uint;
}
+ else
+ return No_Uint;
+ break;
- return No_Uint;
+ case VAR_DECL:
+ tcode = Dynamic_Val;
+ ops[0] = UI_From_Int (++var_count);
+ break;
- CASE_CONVERT: case NON_LVALUE_EXPR:
+ CASE_CONVERT:
+ case NON_LVALUE_EXPR:
return annotate_value (TREE_OPERAND (gnu_size, 0));
/* Now just list the operations we handle. */
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 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_ANDIF_EXPR:
case TRUTH_AND_EXPR: tcode = Truth_And_Expr; break;
+ case TRUTH_ORIF_EXPR:
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 EQ_EXPR: tcode = Eq_Expr; break;
case NE_EXPR: tcode = Ne_Expr; break;
+ case MULT_EXPR:
+ case PLUS_EXPR:
+ tcode = (TREE_CODE (gnu_size) == MULT_EXPR ? Mult_Expr : Plus_Expr);
+ /* Fold conversions from bytes to bits into inner operations. */
+ if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST
+ && CONVERT_EXPR_P (TREE_OPERAND (gnu_size, 0)))
+ {
+ tree inner_op = TREE_OPERAND (TREE_OPERAND (gnu_size, 0), 0);
+ if (TREE_CODE (inner_op) == TREE_CODE (gnu_size)
+ && TREE_CODE (TREE_OPERAND (inner_op, 1)) == INTEGER_CST)
+ {
+ tree inner_op_op1 = TREE_OPERAND (inner_op, 1);
+ tree gnu_size_op1 = TREE_OPERAND (gnu_size, 1);
+ widest_int op1;
+ if (TREE_CODE (gnu_size) == MULT_EXPR)
+ op1 = (wi::to_widest (inner_op_op1)
+ * wi::to_widest (gnu_size_op1));
+ else
+ op1 = (wi::to_widest (inner_op_op1)
+ + wi::to_widest (gnu_size_op1));
+ ops[1] = UI_From_gnu (wide_int_to_tree (sizetype, op1));
+ ops[0] = annotate_value (TREE_OPERAND (inner_op, 0));
+ }
+ }
+ break;
+
case BIT_AND_EXPR:
tcode = Bit_And_Expr;
/* For negative values in sizetype, build NEGATE_EXPR of the opposite.
if (TREE_CODE (TREE_OPERAND (gnu_size, 1)) == INTEGER_CST)
{
tree op1 = TREE_OPERAND (gnu_size, 1);
- wide_int signed_op1 = wi::sext (op1, TYPE_PRECISION (sizetype));
+ wide_int signed_op1 = wi::sext (wi::to_wide (op1),
+ TYPE_PRECISION (sizetype));
if (wi::neg_p (signed_op1))
{
op1 = wide_int_to_tree (sizetype, wi::neg (signed_op1));
- pre_op1 = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
+ ops[1] = annotate_value (build1 (NEGATE_EXPR, sizetype, op1));
}
}
break;
if (List_Representation_Info == 3 || type_annotate_only)
{
tree t = maybe_inline_call_in_expr (gnu_size);
- if (t)
- return annotate_value (t);
+ return t ? annotate_value (t) : No_Uint;
}
else
return Uint_Minus_1;
- /* Fall through... */
-
default:
return No_Uint;
}
/* Now get each of the operands that's relevant for this code. If any
cannot be expressed as a repinfo node, say we can't. */
- for (i = 0; i < 3; i++)
- ops[i] = No_Uint;
-
- for (i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
- {
- if (i == 1 && pre_op1 != No_Uint)
- ops[i] = pre_op1;
- else
+ for (int i = 0; i < TREE_CODE_LENGTH (TREE_CODE (gnu_size)); i++)
+ if (ops[i] == No_Uint)
+ {
ops[i] = annotate_value (TREE_OPERAND (gnu_size, i));
- if (ops[i] == No_Uint)
- return No_Uint;
- }
+ if (ops[i] == No_Uint)
+ return No_Uint;
+ }
- ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
+ Node_Ref_Or_Val ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
/* Save the result in the cache. */
if (in.base.from)
h = annotate_value_cache->find_slot (&in, INSERT);
gcc_assert (!*h);
*h = ggc_alloc<tree_int_map> ();
- (*h)->base.from = gnu_size;
+ (*h)->base.from = in.base.from;
(*h)->to = ret;
}
static void
annotate_rep (Entity_Id gnat_entity, tree gnu_type)
{
- Entity_Id gnat_field;
- tree gnu_list;
+ /* For an extension, the inherited components have not been translated because
+ they are fetched from the _Parent component on the fly. */
+ const bool is_extension
+ = Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity);
/* We operate by first making a list of all fields and their position (we
can get the size easily) and then update all the sizes in the tree. */
- gnu_list
+ tree gnu_list
= build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
BIGGEST_ALIGNMENT, NULL_TREE);
- for (gnat_field = First_Entity (gnat_entity);
+ for (Entity_Id gnat_field = First_Entity (gnat_entity);
Present (gnat_field);
gnat_field = Next_Entity (gnat_field))
- if (Ekind (gnat_field) == E_Component
+ if ((Ekind (gnat_field) == E_Component
+ && (is_extension || present_gnu_tree (gnat_field)))
|| (Ekind (gnat_field) == E_Discriminant
&& !Is_Unchecked_Union (Scope (gnat_field))))
{
gnu_list);
if (t)
{
- tree parent_offset;
+ tree offset = TREE_VEC_ELT (TREE_VALUE (t), 0);
+ tree bit_offset = TREE_VEC_ELT (TREE_VALUE (t), 2);
/* If we are just annotating types and the type is tagged, the tag
and the parent components are not generated by the front-end so
&& Is_Tagged_Type (gnat_entity)
&& No (Component_Clause (gnat_field)))
{
+ tree parent_bit_offset;
+
/* For a component appearing in the current extension, the
offset is the size of the parent. */
if (Is_Derived_Type (gnat_entity)
&& Original_Record_Component (gnat_field) == gnat_field)
- parent_offset
+ parent_bit_offset
= UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
bitsizetype);
else
- parent_offset = bitsize_int (POINTER_SIZE);
+ parent_bit_offset = bitsize_int (POINTER_SIZE);
if (TYPE_FIELDS (gnu_type))
- parent_offset
- = round_up (parent_offset,
+ parent_bit_offset
+ = round_up (parent_bit_offset,
DECL_ALIGN (TYPE_FIELDS (gnu_type)));
+
+ offset
+ = size_binop (PLUS_EXPR, offset,
+ fold_convert (sizetype,
+ size_binop (TRUNC_DIV_EXPR,
+ parent_bit_offset,
+ bitsize_unit_node)));
+ }
+
+ /* If the field has a variable offset, also compute the normalized
+ position since it's easier to do on trees here than to deduce
+ it from the annotated expression of Component_Bit_Offset. */
+ if (TREE_CODE (offset) != INTEGER_CST)
+ {
+ normalize_offset (&offset, &bit_offset, BITS_PER_UNIT);
+ Set_Normalized_Position (gnat_field,
+ annotate_value (offset));
+ Set_Normalized_First_Bit (gnat_field,
+ annotate_value (bit_offset));
}
- else
- parent_offset = bitsize_zero_node;
Set_Component_Bit_Offset
(gnat_field,
- annotate_value
- (size_binop (PLUS_EXPR,
- bit_from_pos (TREE_VEC_ELT (TREE_VALUE (t), 0),
- TREE_VEC_ELT (TREE_VALUE (t), 2)),
- parent_offset)));
+ annotate_value (bit_from_pos (offset, bit_offset)));
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
}
- else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
+ else if (is_extension)
{
/* If there is no entry, this is an inherited component whose
position is the same as in the parent type. */
- Set_Component_Bit_Offset
- (gnat_field,
- Component_Bit_Offset (Original_Record_Component (gnat_field)));
+ Entity_Id gnat_orig = Original_Record_Component (gnat_field);
- Set_Esize (gnat_field,
- Esize (Original_Record_Component (gnat_field)));
+ /* If we are just annotating types, discriminants renaming those of
+ the parent have no entry so deal with them specifically. */
+ if (type_annotate_only
+ && gnat_orig == gnat_field
+ && Ekind (gnat_field) == E_Discriminant)
+ gnat_orig = Corresponding_Discriminant (gnat_field);
+
+ if (Known_Normalized_Position (gnat_orig))
+ {
+ Set_Normalized_Position (gnat_field,
+ Normalized_Position (gnat_orig));
+ Set_Normalized_First_Bit (gnat_field,
+ Normalized_First_Bit (gnat_orig));
+ }
+
+ Set_Component_Bit_Offset (gnat_field,
+ Component_Bit_Offset (gnat_orig));
+
+ Set_Esize (gnat_field, Esize (gnat_orig));
}
}
}
(Node (gnat_constr), gnat_subtype,
get_entity_char (gnat_discrim),
definition, true, false));
- subst_pair s = {gnu_field, replacement};
+ subst_pair s = { gnu_field, replacement };
gnu_list.safe_push (s);
}
if (!integer_zerop (qual))
{
tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
- variant_desc v = {variant_type, gnu_field, qual, NULL_TREE};
+ variant_desc v
+ = { variant_type, gnu_field, qual, NULL_TREE, NULL_TREE };
gnu_list.safe_push (v);
by the smallest integral mode that's valid for pointers. */
if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
{
- machine_mode p_mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
+ scalar_int_mode p_mode = NARROWEST_INT_MODE;
while (!targetm.valid_pointer_mode (p_mode))
- p_mode = GET_MODE_WIDER_MODE (p_mode);
+ p_mode = GET_MODE_WIDER_MODE (p_mode).require ();
type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
}
return align;
}
\f
+/* Promote the alignment of GNU_TYPE corresponding to GNAT_ENTITY. Return
+ a positive value on success or zero on failure. */
+
+static unsigned int
+promote_object_alignment (tree gnu_type, Entity_Id gnat_entity)
+{
+ unsigned int align, size_cap, align_cap;
+
+ /* No point in promoting the alignment if this doesn't prevent BLKmode access
+ to the object, in particular block copy, as this will for example disable
+ the NRV optimization for it. No point in jumping through all the hoops
+ needed in order to support BIGGEST_ALIGNMENT if we don't really have to.
+ So we cap to the smallest alignment that corresponds to a known efficient
+ memory access pattern, except for Atomic and Volatile_Full_Access. */
+ if (Is_Atomic_Or_VFA (gnat_entity))
+ {
+ size_cap = UINT_MAX;
+ align_cap = BIGGEST_ALIGNMENT;
+ }
+ else
+ {
+ size_cap = MAX_FIXED_MODE_SIZE;
+ align_cap = get_mode_alignment (ptr_mode);
+ }
+
+ /* Do the promotion within the above limits. */
+ if (!tree_fits_uhwi_p (TYPE_SIZE (gnu_type))
+ || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
+ align = 0;
+ else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
+ align = align_cap;
+ else
+ align = ceil_pow2 (tree_to_uhwi (TYPE_SIZE (gnu_type)));
+
+ /* But make sure not to under-align the object. */
+ if (align <= TYPE_ALIGN (gnu_type))
+ align = 0;
+
+ /* And honor the minimum valid atomic alignment, if any. */
+#ifdef MINIMUM_ATOMIC_ALIGNMENT
+ else if (align < MINIMUM_ATOMIC_ALIGNMENT)
+ align = MINIMUM_ATOMIC_ALIGNMENT;
+#endif
+
+ return align;
+}
+\f
/* Verify that TYPE is something we can implement atomically. If not, issue
an error for GNAT_ENTITY. COMPONENT_P is true if we are being called to
process a component type. */
/* Consider all aligned floating-point types atomic and any aligned types
that are represented by integers no wider than a machine word. */
+ scalar_int_mode int_mode;
if ((mclass == MODE_FLOAT
- || ((mclass == MODE_INT || mclass == MODE_PARTIAL_INT)
- && GET_MODE_BITSIZE (mode) <= BITS_PER_WORD))
+ || (is_a <scalar_int_mode> (mode, &int_mode)
+ && GET_MODE_BITSIZE (int_mode) <= BITS_PER_WORD))
&& align >= GET_MODE_ALIGNMENT (mode))
return;
/* Sequence position of the last argument we checked. */
int argpos = 0;
- while (1)
+ while (true)
{
tree ada_type = function_args_iter_cond (&ada_iter);
tree btin_type = function_args_iter_cond (&btin_iter);
/* If we've exhausted both lists simultaneously, we're done. */
- if (ada_type == NULL_TREE && btin_type == NULL_TREE)
+ if (!ada_type && !btin_type)
break;
/* If one list is shorter than the other, they fail to match. */
- if (ada_type == NULL_TREE || btin_type == NULL_TREE)
+ if (!ada_type || !btin_type)
return false;
/* If we're done with the Ada args and not with the internal builtin
&& !VOID_TYPE_P (btin_return_type))
return true;
- /* If return type is Address (integer type), map it to void *. */
- if (Is_Descendent_Of_Address (Etype (inb->gnat_entity)))
- ada_return_type = ptr_type_node;
-
/* Check return types compatibility otherwise. Note that this
handles void/void as well. */
if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
the list of variants to be used and RECORD_TYPE is the type of the parent.
POS_LIST is a position list describing the layout of fields present in
OLD_VARIANT_PART and SUBST_LIST a substitution list to be applied to this
- layout. */
+ layout. DEBUG_INFO_P is true if we need to write debug information. */
static tree
create_variant_part_from (tree old_variant_part,
vec<variant_desc> variant_list,
tree record_type, tree pos_list,
- vec<subst_pair> subst_list)
+ vec<subst_pair> subst_list,
+ bool debug_info_p)
{
tree offset = DECL_FIELD_OFFSET (old_variant_part);
tree old_union_type = TREE_TYPE (old_variant_part);
/* If the position of the variant part is constant, subtract it from the
size of the type of the parent to get the new size. This manual CSE
reduces the code size when not optimizing. */
- if (TREE_CODE (offset) == INTEGER_CST)
+ if (TREE_CODE (offset) == INTEGER_CST
+ && TYPE_SIZE (record_type)
+ && TYPE_SIZE_UNIT (record_type))
{
tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
tree first_bit = bit_from_pos (offset, bitpos);
SET_TYPE_ADA_SIZE (new_union_type,
size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
first_bit));
- TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
+ SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
}
else
{
tree new_variant_subpart
= create_variant_part_from (old_variant_subpart, variant_list,
- new_variant, pos_list, subst_list);
+ new_variant, pos_list, subst_list,
+ debug_info_p);
DECL_CHAIN (new_variant_subpart) = field_list;
field_list = new_variant_subpart;
}
- /* Finish up the new variant and create the field. No need for debug
- info thanks to the XVS type. */
- finish_record_type (new_variant, nreverse (field_list), 2, false);
- compute_record_mode (new_variant);
- create_type_decl (TYPE_NAME (new_variant), new_variant, true, false,
- Empty);
+ /* Finish up the new variant and create the field. */
+ finish_record_type (new_variant, nreverse (field_list), 2, debug_info_p);
+ create_type_decl (TYPE_NAME (new_variant), new_variant, true,
+ debug_info_p, Empty);
new_field
= create_field_decl_from (old_field, new_variant, new_union_type,
union_field_list = new_field;
}
- /* Finish up the union type and create the variant part. No need for debug
- info thanks to the XVS type. Note that we don't reverse the field list
- because VARIANT_LIST has been traversed in reverse order. */
- finish_record_type (new_union_type, union_field_list, 2, false);
- compute_record_mode (new_union_type);
- create_type_decl (TYPE_NAME (new_union_type), new_union_type, true, false,
- Empty);
+ /* Finish up the union type and create the variant part. Note that we don't
+ reverse the field list because VARIANT_LIST has been traversed in reverse
+ order. */
+ finish_record_type (new_union_type, union_field_list, 2, debug_info_p);
+ create_type_decl (TYPE_NAME (new_union_type), new_union_type, true,
+ debug_info_p, Empty);
new_variant_part
= create_field_decl_from (old_variant_part, new_union_type, record_type,
TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
- TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
+ SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_type));
}
+/* Return true if DISC is a stored discriminant of RECORD_TYPE. */
+
+static inline bool
+is_stored_discriminant (Entity_Id discr, Entity_Id record_type)
+{
+ if (Is_Unchecked_Union (record_type))
+ return false;
+ else if (Is_Tagged_Type (record_type))
+ return No (Corresponding_Discriminant (discr));
+ else if (Ekind (record_type) == E_Record_Type)
+ return Original_Record_Component (discr) == discr;
+ else
+ return true;
+}
+
+/* Copy the layout from {GNAT,GNU}_OLD_TYPE to {GNAT,GNU}_NEW_TYPE, which are
+ both record types, after applying the substitutions described in SUBST_LIST.
+ DEBUG_INFO_P is true if we need to write debug information for NEW_TYPE. */
+
+static void
+copy_and_substitute_in_layout (Entity_Id gnat_new_type,
+ Entity_Id gnat_old_type,
+ tree gnu_new_type,
+ tree gnu_old_type,
+ vec<subst_pair> gnu_subst_list,
+ bool debug_info_p)
+{
+ const bool is_subtype = (Ekind (gnat_new_type) == E_Record_Subtype);
+ tree gnu_field_list = NULL_TREE;
+ tree gnu_variable_field_list = NULL_TREE;
+ bool selected_variant;
+ vec<variant_desc> gnu_variant_list;
+
+ /* Look for REP and variant parts in the old type. */
+ tree gnu_rep_part = get_rep_part (gnu_old_type);
+ tree gnu_variant_part = get_variant_part (gnu_old_type);
+
+ /* If there is a variant part, we must compute whether the constraints
+ statically select a particular variant. If so, we simply drop the
+ qualified union and flatten the list of fields. Otherwise we will
+ build a new qualified union for the variants that are still relevant. */
+ if (gnu_variant_part)
+ {
+ variant_desc *v;
+ unsigned int i;
+
+ gnu_variant_list = build_variant_list (TREE_TYPE (gnu_variant_part),
+ gnu_subst_list, vNULL);
+
+ /* If all the qualifiers are unconditionally true, the innermost variant
+ is statically selected. */
+ selected_variant = true;
+ FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
+ if (!integer_onep (v->qual))
+ {
+ selected_variant = false;
+ break;
+ }
+
+ /* Otherwise, create the new variants. */
+ if (!selected_variant)
+ FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
+ {
+ tree old_variant = v->type;
+ tree new_variant = make_node (RECORD_TYPE);
+ tree suffix
+ = concat_name (DECL_NAME (gnu_variant_part),
+ IDENTIFIER_POINTER (DECL_NAME (v->field)));
+ TYPE_NAME (new_variant)
+ = concat_name (TYPE_NAME (gnu_new_type),
+ IDENTIFIER_POINTER (suffix));
+ TYPE_REVERSE_STORAGE_ORDER (new_variant)
+ = TYPE_REVERSE_STORAGE_ORDER (gnu_new_type);
+ copy_and_substitute_in_size (new_variant, old_variant,
+ gnu_subst_list);
+ v->new_type = new_variant;
+ }
+ }
+ else
+ {
+ gnu_variant_list.create (0);
+ selected_variant = false;
+ }
+
+ /* Make a list of fields and their position in the old type. */
+ tree gnu_pos_list
+ = build_position_list (gnu_old_type,
+ gnu_variant_list.exists () && !selected_variant,
+ size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, NULL_TREE);
+
+ /* Now go down every component in the new type and compute its size and
+ position from those of the component in the old type and the stored
+ constraints of the new type. */
+ Entity_Id gnat_field, gnat_old_field;
+ for (gnat_field = First_Entity (gnat_new_type);
+ Present (gnat_field);
+ gnat_field = Next_Entity (gnat_field))
+ if ((Ekind (gnat_field) == E_Component
+ || (Ekind (gnat_field) == E_Discriminant
+ && is_stored_discriminant (gnat_field, gnat_new_type)))
+ && (gnat_old_field = is_subtype
+ ? Original_Record_Component (gnat_field)
+ : Corresponding_Record_Component (gnat_field))
+ && Underlying_Type (Scope (gnat_old_field)) == gnat_old_type
+ && present_gnu_tree (gnat_old_field))
+ {
+ Name_Id gnat_name = Chars (gnat_field);
+ tree gnu_old_field = get_gnu_tree (gnat_old_field);
+ if (TREE_CODE (gnu_old_field) == COMPONENT_REF)
+ gnu_old_field = TREE_OPERAND (gnu_old_field, 1);
+ tree gnu_context = DECL_CONTEXT (gnu_old_field);
+ tree gnu_field, gnu_field_type, gnu_size, gnu_pos;
+ tree gnu_cont_type, gnu_last = NULL_TREE;
+ variant_desc *v = NULL;
+
+ /* If the type is the same, retrieve the GCC type from the
+ old field to take into account possible adjustments. */
+ if (Etype (gnat_field) == Etype (gnat_old_field))
+ gnu_field_type = TREE_TYPE (gnu_old_field);
+ else
+ gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
+
+ /* If there was a component clause, the field types must be the same
+ for the old and new types, so copy the data from the old field to
+ avoid recomputation here. Also if the field is justified modular
+ and the optimization in gnat_to_gnu_field was applied. */
+ if (Present (Component_Clause (gnat_old_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);
+ }
+
+ /* If the old field was packed and of constant size, we have to get the
+ old size here as it might differ from what the Etype conveys and the
+ latter might overlap with the following field. Try to arrange the
+ type for possible better packing along the way. */
+ else if (DECL_PACKED (gnu_old_field)
+ && TREE_CODE (DECL_SIZE (gnu_old_field)) == INTEGER_CST)
+ {
+ gnu_size = DECL_SIZE (gnu_old_field);
+ if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
+ && !TYPE_FAT_POINTER_P (gnu_field_type)
+ && tree_fits_uhwi_p (TYPE_SIZE (gnu_field_type)))
+ gnu_field_type = make_packable_type (gnu_field_type, true);
+ }
+
+ else
+ gnu_size = TYPE_SIZE (gnu_field_type);
+
+ /* If the context of the old field is the old type or its REP part,
+ put the field directly in the new type; otherwise look up the
+ context in the variant list and put the field either in the new
+ type if there is a selected variant or in one new variant. */
+ if (gnu_context == gnu_old_type
+ || (gnu_rep_part && gnu_context == TREE_TYPE (gnu_rep_part)))
+ gnu_cont_type = gnu_new_type;
+ else
+ {
+ unsigned int i;
+ tree rep_part;
+
+ FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
+ if (gnu_context == v->type
+ || ((rep_part = get_rep_part (v->type))
+ && gnu_context == TREE_TYPE (rep_part)))
+ break;
+
+ if (v)
+ gnu_cont_type = selected_variant ? gnu_new_type : v->new_type;
+ else
+ /* The front-end may pass us zombie components if it fails to
+ recognize that a constrain statically selects a particular
+ variant. Discard them. */
+ continue;
+ }
+
+ /* Now create the new field modeled on the old one. */
+ gnu_field
+ = create_field_decl_from (gnu_old_field, gnu_field_type,
+ gnu_cont_type, gnu_size,
+ gnu_pos_list, gnu_subst_list);
+ gnu_pos = DECL_FIELD_OFFSET (gnu_field);
+
+ /* If the context is a variant, put it in the new variant directly. */
+ if (gnu_cont_type != gnu_new_type)
+ {
+ if (TREE_CODE (gnu_pos) == INTEGER_CST)
+ {
+ DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+ TYPE_FIELDS (gnu_cont_type) = gnu_field;
+ }
+ else
+ {
+ DECL_CHAIN (gnu_field) = v->aux;
+ v->aux = gnu_field;
+ }
+ }
+
+ /* To match the layout crafted in components_to_record, if this is
+ the _Tag or _Parent field, put it before any other fields. */
+ else if (gnat_name == Name_uTag || gnat_name == Name_uParent)
+ gnu_field_list = chainon (gnu_field_list, gnu_field);
+
+ /* Similarly, if this is the _Controller field, put it before the
+ other fields except for the _Tag or _Parent field. */
+ else if (gnat_name == Name_uController && gnu_last)
+ {
+ DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
+ DECL_CHAIN (gnu_last) = gnu_field;
+ }
+
+ /* Otherwise, put it after the other fields. */
+ else
+ {
+ if (TREE_CODE (gnu_pos) == INTEGER_CST)
+ {
+ DECL_CHAIN (gnu_field) = gnu_field_list;
+ gnu_field_list = gnu_field;
+ if (!gnu_last)
+ gnu_last = gnu_field;
+ }
+ else
+ {
+ DECL_CHAIN (gnu_field) = gnu_variable_field_list;
+ gnu_variable_field_list = gnu_field;
+ }
+ }
+
+ /* For a stored discriminant in a derived type, replace the field. */
+ if (!is_subtype && Ekind (gnat_field) == E_Discriminant)
+ {
+ tree gnu_ref = get_gnu_tree (gnat_field);
+ TREE_OPERAND (gnu_ref, 1) = gnu_field;
+ }
+ else
+ save_gnu_tree (gnat_field, gnu_field, false);
+ }
+
+ /* Put the fields with fixed position in order of increasing position. */
+ if (gnu_field_list)
+ gnu_field_list = reverse_sort_field_list (gnu_field_list);
+
+ /* Put the fields with variable position at the end. */
+ if (gnu_variable_field_list)
+ gnu_field_list = chainon (gnu_variable_field_list, gnu_field_list);
+
+ /* If there is a variant list and no selected variant, we need to create the
+ nest of variant parts from the old nest. */
+ if (gnu_variant_list.exists () && !selected_variant)
+ {
+ variant_desc *v;
+ unsigned int i;
+
+ /* Same processing as above for the fields of each variant. */
+ FOR_EACH_VEC_ELT (gnu_variant_list, i, v)
+ {
+ if (TYPE_FIELDS (v->new_type))
+ TYPE_FIELDS (v->new_type)
+ = reverse_sort_field_list (TYPE_FIELDS (v->new_type));
+ if (v->aux)
+ TYPE_FIELDS (v->new_type)
+ = chainon (v->aux, TYPE_FIELDS (v->new_type));
+ }
+
+ tree new_variant_part
+ = create_variant_part_from (gnu_variant_part, gnu_variant_list,
+ gnu_new_type, gnu_pos_list,
+ gnu_subst_list, debug_info_p);
+ DECL_CHAIN (new_variant_part) = gnu_field_list;
+ gnu_field_list = new_variant_part;
+ }
+
+ gnu_variant_list.release ();
+ gnu_subst_list.release ();
+
+ /* If NEW_TYPE is a subtype, it inherits all the attributes from OLD_TYPE.
+ Otherwise sizes and alignment must be computed independently. */
+ finish_record_type (gnu_new_type, nreverse (gnu_field_list),
+ is_subtype ? 2 : 1, debug_info_p);
+
+ /* Now go through the entities again looking for Itypes that we have not yet
+ elaborated (e.g. Etypes of fields that have Original_Components). */
+ for (Entity_Id gnat_field = First_Entity (gnat_new_type);
+ Present (gnat_field);
+ gnat_field = Next_Entity (gnat_field))
+ if ((Ekind (gnat_field) == E_Component
+ || Ekind (gnat_field) == E_Discriminant)
+ && Is_Itype (Etype (gnat_field))
+ && !present_gnu_tree (Etype (gnat_field)))
+ gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
+}
+
/* Associate to GNU_TYPE, the translation of GNAT_ENTITY, which is
the implementation type of a packed array type (Is_Packed_Array_Impl_Type),
the original array type if it has been translated. This association is a
add_parallel_type (gnu_type, gnu_original_array_type);
}
\f
-/* Given a type T, a FIELD_DECL F, and a replacement value R, return a
- type with all size expressions that contain F in a PLACEHOLDER_EXPR
- updated by replacing F with R.
+/* Given a type T, a FIELD_DECL F, and a replacement value R, return an
+ equivalent type with adjusted size expressions where all occurrences
+ of references to F in a PLACEHOLDER_EXPR have been replaced by R.
The function doesn't update the layout of the type, i.e. it assumes
that the substitution is purely formal. That's why the replacement
return t;
nt = build_nonshared_array_type (component, domain);
- TYPE_ALIGN (nt) = TYPE_ALIGN (t);
+ SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
SET_TYPE_MODE (nt, TYPE_MODE (t));
TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
- TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
+ if (TYPE_REVERSE_STORAGE_ORDER (t))
+ set_reverse_storage_order_on_array_type (nt);
+ if (TYPE_NONALIASED_COMPONENT (t))
+ set_nonaliased_component_on_array_type (nt);
return nt;
}
{
/* Initialize the cache of annotated values. */
annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
+
+ /* Initialize the association of dummy types with subprograms. */
+ dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
}
/* Destroy data structures of the decl.c module. */
/* Destroy the cache of annotated values. */
annotate_value_cache->empty ();
annotate_value_cache = NULL;
+
+ /* Destroy the association of dummy types with subprograms. */
+ dummy_to_subprog_map->empty ();
+ dummy_to_subprog_map = NULL;
}
#include "gt-ada-decl.h"
projects / gcc.git / blobdiff