* *
* C Implementation File *
* *
- * Copyright (C) 1992-2009, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2010, 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 "tree.h"
#include "flags.h"
#include "toplev.h"
-#include "convert.h"
#include "ggc.h"
-#include "obstack.h"
#include "target.h"
#include "expr.h"
+#include "tree-inline.h"
#include "ada.h"
#include "types.h"
#include "fe.h"
#include "sinfo.h"
#include "einfo.h"
-#include "hashtab.h"
#include "ada-tree.h"
#include "gigi.h"
static void relate_alias_sets (tree, tree, enum alias_set_op);
-static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
static bool allocatable_size_p (tree, bool);
static void prepend_one_attribute_to (struct attrib **,
enum attr_type, tree, tree, Node_Id);
static void prepend_attributes (Entity_Id, struct attrib **);
static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
static bool is_variable_size (tree);
-static tree elaborate_expression_1 (Node_Id, Entity_Id, tree, tree,
- bool, bool);
+static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
static tree make_packable_type (tree, bool);
-static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
+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_field (Entity_Id, tree, int, bool, bool);
static bool same_discriminant_p (Entity_Id, Entity_Id);
-static bool array_type_has_nonaliased_component (Entity_Id, tree);
+static bool array_type_has_nonaliased_component (tree, Entity_Id);
static bool compile_time_known_address_p (Node_Id);
+static bool cannot_be_superflat_p (Node_Id);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
- bool, bool, bool, bool);
+ bool, bool, bool, bool, bool);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
-static tree compute_field_positions (tree, tree, tree, tree, unsigned int);
+static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
+static tree build_subst_list (Entity_Id, Entity_Id, bool);
+static tree build_variant_list (tree, tree, tree);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
static void set_rm_size (Uint, tree, Entity_Id);
static tree make_type_from_size (tree, tree, bool);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree ftype1, tree ftype2);
+static int compatible_signatures_p (tree, tree);
+static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
+static tree get_rep_part (tree);
+static tree get_variant_part (tree);
+static tree create_variant_part_from (tree, tree, tree, tree, tree);
+static void copy_and_substitute_in_size (tree, tree, tree);
static void rest_of_type_decl_compilation_no_defer (tree);
\f
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
tree
gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
- Entity_Id gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
+ /* Contains the kind of the input GNAT node. */
+ const Entity_Kind kind = Ekind (gnat_entity);
+ /* True if this is a type. */
+ const bool is_type = IN (kind, Type_Kind);
+ /* 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. */
Entity_Id gnat_temp;
- Entity_Kind kind = Ekind (gnat_entity);
/* Contains the GCC DECL node which is equivalent to the input GNAT node.
This node will be associated with the GNAT node by calling at the end
of the `switch' statement. */
/* Contains the GCC size tree to be used for the GCC node. */
tree gnu_size = NULL_TREE;
/* Contains the GCC name to be used for the GCC node. */
- tree gnu_entity_id;
+ tree gnu_entity_name;
/* True if we have already saved gnu_decl as a GNAT association. */
bool saved = false;
/* True if we incremented defer_incomplete_level. */
/* True if this entity is to be considered as imported. */
bool imported_p = (Is_Imported (gnat_entity)
&& No (Address_Clause (gnat_entity)));
- unsigned int esize
- = ((Known_Esize (gnat_entity)
- && UI_Is_In_Int_Range (Esize (gnat_entity)))
- ? MIN (UI_To_Int (Esize (gnat_entity)),
- IN (kind, Float_Kind)
- ? fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE)
- : IN (kind, Access_Kind) ? POINTER_SIZE * 2
- : LONG_LONG_TYPE_SIZE)
- : LONG_LONG_TYPE_SIZE);
- unsigned int align = 0;
+ /* Size and alignment of the GCC node, if meaningful. */
+ unsigned int esize = 0, align = 0;
+ /* 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. */
if (!definition
+ && is_type
&& Is_Itype (gnat_entity)
&& !present_gnu_tree (gnat_entity)
&& In_Extended_Main_Code_Unit (gnat_entity))
}
}
- /* This abort means the entity has an incorrect scope, i.e. that its
+ /* This abort means the Itype has an incorrect scope, i.e. that its
scope does not correspond to the subprogram it is declared in. */
gcc_unreachable ();
}
- /* If the entiy is not present, something went badly wrong. */
- gcc_assert (Present (gnat_entity));
-
/* If we've already processed this entity, return what we got last time.
If we are defining the node, we should not have already processed it.
In that case, we will abort below when we try to save a new GCC tree
for this object. We also need to handle the case of getting a dummy
type when a Full_View exists. */
- if (present_gnu_tree (gnat_entity)
- && (!definition || (Is_Type (gnat_entity) && imported_p)))
+ if ((!definition || (is_type && imported_p))
+ && present_gnu_tree (gnat_entity))
{
gnu_decl = get_gnu_tree (gnat_entity);
|| kind == E_Anonymous_Access_Protected_Subprogram_Type
|| kind == E_Access_Subtype)));
- /* RM_Size must be specified for all discrete and fixed-point types. */
- gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
- || !Unknown_RM_Size (gnat_entity));
+ /* The RM size must be specified for all discrete and fixed-point types. */
+ gcc_assert (!(IN (kind, Discrete_Or_Fixed_Point_Kind)
+ && Unknown_RM_Size (gnat_entity)));
+
+ /* If we get here, it means we have not yet done anything with this entity.
+ If we are not defining it, it must be a type or an entity that is defined
+ elsewhere or externally, otherwise we should have defined it already. */
+ gcc_assert (definition
+ || type_annotate_only
+ || is_type
+ || kind == E_Discriminant
+ || kind == E_Component
+ || kind == E_Label
+ || (kind == E_Constant && Present (Full_View (gnat_entity)))
+ || Is_Public (gnat_entity));
/* Get the name of the entity and set up the line number and filename of
the original definition for use in any decl we make. */
- gnu_entity_id = get_entity_name (gnat_entity);
+ gnu_entity_name = get_entity_name (gnat_entity);
Sloc_to_locus (Sloc (gnat_entity), &input_location);
- /* If we get here, it means we have not yet done anything with this
- entity. If we are not defining it here, it must be external,
- otherwise we should have defined it already. */
- gcc_assert (definition || Is_Public (gnat_entity) || type_annotate_only
- || kind == E_Discriminant || kind == E_Component
- || kind == E_Label
- || (kind == E_Constant && Present (Full_View (gnat_entity)))
- || IN (kind, Type_Kind));
-
/* For cases when we are not defining (i.e., we are referencing from
another compilation unit) public entities, show we are at global level
for the purpose of computing scopes. Don't do this for components or
discriminants since the relevant test is whether or not the record is
- being defined. But do this for Imported functions or procedures in
- all cases. */
- if ((!definition && Is_Public (gnat_entity)
- && !Is_Statically_Allocated (gnat_entity)
- && kind != E_Discriminant && kind != E_Component)
- || (Is_Imported (gnat_entity)
- && (kind == E_Function || kind == E_Procedure)))
+ being defined. */
+ if (!definition
+ && kind != E_Component
+ && kind != E_Discriminant
+ && Is_Public (gnat_entity)
+ && !Is_Statically_Allocated (gnat_entity))
force_global++, this_global = true;
/* Handle any attributes directly attached to the entity. */
if (Has_Gigi_Rep_Item (gnat_entity))
prepend_attributes (gnat_entity, &attr_list);
- /* Machine_Attributes on types are expected to be propagated to subtypes.
- The corresponding Gigi_Rep_Items are only attached to the first subtype
- though, so we handle the propagation here. */
- if (Is_Type (gnat_entity) && Base_Type (gnat_entity) != gnat_entity
- && !Is_First_Subtype (gnat_entity)
- && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
- prepend_attributes (First_Subtype (Base_Type (gnat_entity)), &attr_list);
+ /* Do some common processing for types. */
+ if (is_type)
+ {
+ /* Compute the equivalent type to be used in gigi. */
+ gnat_equiv_type = Gigi_Equivalent_Type (gnat_entity);
+
+ /* Machine_Attributes on types are expected to be propagated to
+ subtypes. The corresponding Gigi_Rep_Items are only attached
+ to the first subtype though, so we handle the propagation here. */
+ if (Base_Type (gnat_entity) != gnat_entity
+ && !Is_First_Subtype (gnat_entity)
+ && Has_Gigi_Rep_Item (First_Subtype (Base_Type (gnat_entity))))
+ prepend_attributes (First_Subtype (Base_Type (gnat_entity)),
+ &attr_list);
+
+ /* Compute a default value for the size of the type. */
+ if (Known_Esize (gnat_entity)
+ && UI_Is_In_Int_Range (Esize (gnat_entity)))
+ {
+ unsigned int max_esize;
+ esize = UI_To_Int (Esize (gnat_entity));
+
+ if (IN (kind, Float_Kind))
+ max_esize = fp_prec_to_size (LONG_DOUBLE_TYPE_SIZE);
+ else if (IN (kind, Access_Kind))
+ max_esize = POINTER_SIZE * 2;
+ else
+ max_esize = LONG_LONG_TYPE_SIZE;
+
+ if (esize > max_esize)
+ esize = max_esize;
+ }
+ else
+ esize = LONG_LONG_TYPE_SIZE;
+ }
switch (kind)
{
if (Present (Debug_Renaming_Link (gnat_entity)))
{
rtx addr;
- gnu_decl = build_decl (VAR_DECL, gnu_entity_id, gnu_type);
+ gnu_decl = build_decl (input_location,
+ VAR_DECL, gnu_entity_name, gnu_type);
/* The (MEM (CONST (0))) pattern is prescribed by STABS. */
if (global_bindings_p ())
addr = gen_rtx_CONST (VOIDmode, const0_rtx);
return error_mark_node;
}
- /* If an alignment is specified, use it if valid. Note that
- exceptions are objects but don't have alignments. We must do this
- before we validate the size, since the alignment can affect the
- size. */
+ /* 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));
- gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
- "PAD", false, definition, true);
+ /* 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
+ gnu_type
+ = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
+ false, false, definition, true);
}
/* If we are defining the object, see if it has a Size value and
despite having a nominal type with self-referential
size, we can get the size directly from it. */
if (TREE_CODE (gnu_expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
- == RECORD_TYPE
&& TYPE_IS_PADDING_P
(TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
&& TREE_CODE (TREE_OPERAND (gnu_expr, 0)) == VAR_DECL
&& !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
&& (!Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
|| !Is_Array_Type (Etype (gnat_entity)))
- && !Present (Renamed_Object (gnat_entity))
- && !Present (Address_Clause (gnat_entity)))
+ && No (Renamed_Object (gnat_entity))
+ && No (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
/* If this is an object with no specified size and alignment, and
gnu_type
= build_unc_object_type_from_ptr (gnu_fat, gnu_type,
- concat_id_with_name (gnu_entity_id,
- "UNC"));
+ concat_name (gnu_entity_name,
+ "UNC"));
}
#ifdef MINIMUM_ATOMIC_ALIGNMENT
gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
if (gnu_size || align > 0)
gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- "PAD", false, definition,
+ false, false, definition,
gnu_size ? true : false);
/* If this is a renaming, avoid as much as possible to create a new
/* If the renamed object had padding, strip off the reference
to the inner object and reset our type. */
if ((TREE_CODE (gnu_expr) == COMPONENT_REF
- && TREE_CODE (TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))
- == RECORD_TYPE
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
/* Strip useless conversions around the object. */
|| (TREE_CODE (gnu_expr) == NOP_EXPR
if (stable)
{
- gnu_decl = maybe_stable_expr;
/* ??? No DECL_EXPR is created so we need to mark
the expression manually lest it is shared. */
if (global_bindings_p ())
- mark_visited (&gnu_decl);
+ MARK_VISITED (maybe_stable_expr);
+ gnu_decl = maybe_stable_expr;
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
+ annotate_object (gnat_entity, gnu_type, NULL_TREE,
+ false);
break;
}
/* Case 3: If this is a constant renaming and creating a
new object is allowed and cheap, treat it as a normal
object whose initial value is what is being renamed. */
- if (const_flag && Is_Elementary_Type (Etype (gnat_entity)))
+ if (const_flag
+ && !Is_Composite_Type
+ (Underlying_Type (Etype (gnat_entity))))
;
/* Case 4: Make this into a constant pointer to the object we
/* Make a volatile version of this object's type if we are to make
the object volatile. We also interpret 13.3(19) conservatively
- and disallow any optimizations for an object covered by it. */
+ and disallow any optimizations for such a non-constant object. */
if ((Treat_As_Volatile (gnat_entity)
- || (Is_Exported (gnat_entity)
- /* Exclude exported constants created by the compiler,
- which should boil down to static dispatch tables and
- make it possible to put them in read-only memory. */
- && (Comes_From_Source (gnat_entity) || !const_flag))
- || Is_Imported (gnat_entity)
- || Present (Address_Clause (gnat_entity)))
+ || (!const_flag
+ && (Is_Exported (gnat_entity)
+ || Is_Imported (gnat_entity)
+ || Present (Address_Clause (gnat_entity)))))
&& !TYPE_VOLATILE (gnu_type))
gnu_type = build_qualified_type (gnu_type,
(TYPE_QUALS (gnu_type)
&& !gnu_expr
&& TREE_CODE (gnu_type) == RECORD_TYPE
&& (TYPE_CONTAINS_TEMPLATE_P (gnu_type)
- /* Beware that padding might have been introduced
- via maybe_pad_type above. */
- || (TYPE_IS_PADDING_P (gnu_type)
+ /* Beware that padding might have been introduced above. */
+ || (TYPE_PADDING_P (gnu_type)
&& TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type)))
== RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P
(TREE_TYPE (TYPE_FIELDS (gnu_type))))))
{
tree template_field
- = TYPE_IS_PADDING_P (gnu_type)
+ = TYPE_PADDING_P (gnu_type)
? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
: TYPE_FIELDS (gnu_type);
if (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
+ && !(TYPE_IS_PADDING_P (gnu_type)
+ && CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this is a pointer and it does not have an initializing
expression, initialize it to NULL, unless the object is
imported. */
if (definition
- && (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
+ && (POINTER_TYPE_P (gnu_type) || TYPE_IS_FAT_POINTER_P (gnu_type))
&& !Is_Imported (gnat_entity) && !gnu_expr)
gnu_expr = integer_zero_node;
post_error ("?Storage_Error will be raised at run-time!",
gnat_entity);
- gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
- 0, 0, gnat_entity, mutable_p);
+ gnu_expr
+ = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
+ Empty, Empty, gnat_entity, mutable_p);
}
else
{
if (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
- && (CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
+ && !(TYPE_IS_PADDING_P (gnu_type)
+ && CONTAINS_PLACEHOLDER_P
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this name is external or there was a name specified, use it,
|| (Is_Public (gnat_entity)
&& (!Is_Imported (gnat_entity)
|| Is_Exported (gnat_entity)))))
- gnu_ext_name = create_concat_name (gnat_entity, 0);
+ gnu_ext_name = create_concat_name (gnat_entity, NULL);
/* If this is constant initialized to a static constant and the
object has an aggregate type, force it to be statically
&& gnu_expr && TREE_CONSTANT (gnu_expr)
&& AGGREGATE_TYPE_P (gnu_type)
&& host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
- && !(TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type)
+ && !(TYPE_IS_PADDING_P (gnu_type)
&& !host_integerp (TYPE_SIZE_UNIT
(TREE_TYPE (TYPE_FIELDS (gnu_type))), 1)))
static_p = true;
- gnu_decl = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
+ gnu_decl = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, const_flag,
Is_Public (gnat_entity),
imported_p || !definition,
accessed from within the debugger through the PARM_DECL. */
if (kind == E_Out_Parameter && definition && !optimize)
{
- tree param = create_param_decl (gnu_entity_id, gnu_type, false);
+ tree param = create_param_decl (gnu_entity_name, gnu_type, false);
gnat_pushdecl (param, gnat_entity);
SET_DECL_VALUE_EXPR (param, gnu_decl);
DECL_HAS_VALUE_EXPR_P (param) = 1;
for these. */
if (TREE_CODE (gnu_decl) == CONST_DECL
&& (definition || Sloc (gnat_entity) > Standard_Location)
- && ((Is_Public (gnat_entity)
- && !Present (Address_Clause (gnat_entity)))
+ && ((Is_Public (gnat_entity) && No (Address_Clause (gnat_entity)))
|| !optimize
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
|| Is_Aliased (Etype (gnat_entity))))
{
tree gnu_corr_var
- = create_true_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
+ = create_true_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_expr, true, Is_Public (gnat_entity),
- !definition, static_p, NULL,
+ !definition, static_p, attr_list,
gnat_entity);
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
&& Exception_Mechanism != Back_End_Exceptions)
TREE_ADDRESSABLE (gnu_decl) = 1;
- gnu_type = TREE_TYPE (gnu_decl);
-
- /* Back-annotate Alignment and Esize of the object if not already
- known, except for when the object is actually a pointer to the
- real object, since alignment and size of a pointer don't have
- anything to do with those of the designated object. Note that
- we pick the values of the type, not those of the object, to
- shield ourselves from low-level platform-dependent adjustments
- like alignment promotion. This is both consistent with all the
- treatment above, where alignment and size are set on the type of
- the object and not on the object directly, and makes it possible
- to support confirming representation clauses in all cases. */
-
- if (!used_by_ref && Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity,
- UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
-
- if (!used_by_ref && Unknown_Esize (gnat_entity))
- {
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- gnu_object_size
- = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
-
- Set_Esize (gnat_entity, annotate_value (gnu_object_size));
- }
+ /* Back-annotate Esize and Alignment of the object if not already
+ known. Note that we pick the values of the type, not those of
+ the object, to shield ourselves from low-level platform-dependent
+ adjustments like alignment promotion. This is both consistent with
+ all the treatment above, where alignment and size are set on the
+ type of the object and not on the object directly, and makes it
+ possible to support all confirming representation clauses. */
+ annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
+ used_by_ref);
}
break;
break;
case E_Enumeration_Type:
- /* A special case, for the types Character and Wide_Character in
+ /* 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 type. */
if (No (First_Literal (gnat_entity)))
{
gnu_type = make_unsigned_type (esize);
- TYPE_NAME (gnu_type) = gnu_entity_id;
+ TYPE_NAME (gnu_type) = gnu_entity_name;
- /* Set TYPE_STRING_FLAG for Ada Character and Wide_Character types.
+ /* 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;
break;
}
- /* Normal case of non-character type, or non-Standard character type */
{
- /* Here we have a list of enumeral constants in First_Literal.
- We make a CONST_DECL for each and build into GNU_LITERAL_LIST
- the list to be places into TYPE_FIELDS. Each node in the list
- is a TREE_LIST node whose TREE_VALUE is the literal name
- and whose TREE_PURPOSE is the value of the literal.
-
- Esize contains the number of bits needed to represent the enumeral
- type, Type_Low_Bound also points to the first literal and
- Type_High_Bound points to the last literal. */
-
- Entity_Id gnat_literal;
+ /* We have a list of enumeral constants in First_Literal. We make a
+ CONST_DECL for each one and build into GNU_LITERAL_LIST the list to
+ be placed into TYPE_FIELDS. Each node in the list is a TREE_LIST
+ whose TREE_VALUE is the literal name and whose TREE_PURPOSE is the
+ value of the literal. But when we have a regular boolean type, we
+ simplify this a little by using a BOOLEAN_TYPE. */
+ bool is_boolean = Is_Boolean_Type (gnat_entity)
+ && !Has_Non_Standard_Rep (gnat_entity);
tree gnu_literal_list = NULL_TREE;
+ Entity_Id gnat_literal;
if (Is_Unsigned_Type (gnat_entity))
gnu_type = make_unsigned_type (esize);
else
gnu_type = make_signed_type (esize);
- TREE_SET_CODE (gnu_type, ENUMERAL_TYPE);
+ TREE_SET_CODE (gnu_type, is_boolean ? BOOLEAN_TYPE : ENUMERAL_TYPE);
for (gnat_literal = First_Literal (gnat_entity);
Present (gnat_literal);
gnat_literal = Next_Literal (gnat_literal))
{
- tree gnu_value = UI_To_gnu (Enumeration_Rep (gnat_literal),
- gnu_type);
+ tree gnu_value
+ = UI_To_gnu (Enumeration_Rep (gnat_literal), gnu_type);
tree gnu_literal
= create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
gnu_type, gnu_value, true, false, false,
gnu_value, gnu_literal_list);
}
- TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
+ if (!is_boolean)
+ TYPE_VALUES (gnu_type) = nreverse (gnu_literal_list);
/* Note that the bounds are updated at the end of this function
- because to avoid an infinite recursion when we get the bounds of
- this type, since those bounds are objects of this type. */
+ to avoid an infinite recursion since they refer to the type. */
}
break;
break;
case E_Modular_Integer_Type:
- /* For modular types, make the unsigned type of the proper number of
- bits and then set up the modulus, if required. */
{
- enum machine_mode mode;
- tree gnu_modulus;
- tree gnu_high = 0;
+ /* For modular types, make the unsigned type of the proper number
+ of bits and then set up the modulus, if required. */
+ tree gnu_modulus, gnu_high = NULL_TREE;
- if (Is_Packed_Array_Type (gnat_entity))
- esize = UI_To_Int (RM_Size (gnat_entity));
+ /* Packed array types are supposed to be subtypes only. */
+ gcc_assert (!Is_Packed_Array_Type (gnat_entity));
- /* Find the smallest mode at least ESIZE bits wide and make a class
- using that mode. */
-
- for (mode = GET_CLASS_NARROWEST_MODE (MODE_INT);
- GET_MODE_BITSIZE (mode) < esize;
- mode = GET_MODE_WIDER_MODE (mode))
- ;
-
- gnu_type = make_unsigned_type (GET_MODE_BITSIZE (mode));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
- = (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
+ gnu_type = make_unsigned_type (esize);
/* Get the modulus in this type. If it overflows, assume it is because
it is equal to 2**Esize. Note that there is no overflow checking
convert (gnu_type, integer_one_node));
}
- /* If we have to set TYPE_PRECISION different from its natural value,
- make a subtype to do do. Likewise if there is a modulus and
- it is not one greater than TYPE_MAX_VALUE. */
- if (TYPE_PRECISION (gnu_type) != esize
- || (TYPE_MODULAR_P (gnu_type)
- && !tree_int_cst_equal (TYPE_MAX_VALUE (gnu_type), gnu_high)))
+ /* If the upper bound is not maximal, make an extra subtype. */
+ if (gnu_high
+ && !tree_int_cst_equal (gnu_high, TYPE_MAX_VALUE (gnu_type)))
{
- tree gnu_subtype = make_node (INTEGER_TYPE);
-
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
+ tree gnu_subtype = make_unsigned_type (esize);
+ SET_TYPE_RM_MAX_VALUE (gnu_subtype, gnu_high);
TREE_TYPE (gnu_subtype) = gnu_type;
- TYPE_MIN_VALUE (gnu_subtype) = TYPE_MIN_VALUE (gnu_type);
- TYPE_MAX_VALUE (gnu_subtype)
- = TYPE_MODULAR_P (gnu_type)
- ? gnu_high : TYPE_MAX_VALUE (gnu_type);
- TYPE_PRECISION (gnu_subtype) = esize;
- TYPE_UNSIGNED (gnu_subtype) = 1;
TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
- TYPE_PACKED_ARRAY_TYPE_P (gnu_subtype)
- = (Is_Packed_Array_Type (gnat_entity)
- && Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
- layout_type (gnu_subtype);
-
+ TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "UMT");
gnu_type = gnu_subtype;
}
}
case E_Ordinary_Fixed_Point_Subtype:
case E_Decimal_Fixed_Point_Subtype:
- /* For integral subtypes, we make a new INTEGER_TYPE. Note
- that we do not want to call build_range_type since we would
- like each subtype node to be distinct. This will be important
- when memory aliasing is implemented.
+ /* For integral subtypes, we make a new INTEGER_TYPE. Note that we do
+ not want to call create_range_type since we would like each subtype
+ node to be distinct. ??? Historically this was in preparation for
+ when memory aliasing is implemented, but that's obsolete now given
+ the call to relate_alias_sets below.
- The TREE_TYPE field of the INTEGER_TYPE we make points to the
- parent type; this fact is used by the arithmetic conversion
- functions.
+ The TREE_TYPE field of the INTEGER_TYPE points to the base type;
+ this fact is used by the arithmetic conversion functions.
- We elaborate the Ancestor_Subtype if it is not in the current
- unit and one of our bounds is non-static. We do this to ensure
- consistent naming in the case where several subtypes share the same
- bounds by always elaborating the first such subtype first, thus
- using its name. */
+ We elaborate the Ancestor_Subtype if it is not in the current unit
+ and one of our bounds is non-static. We do this to ensure consistent
+ naming in the case where several subtypes share the same bounds, by
+ elaborating the first such subtype first, thus using its name. */
if (!definition
&& Present (Ancestor_Subtype (gnat_entity))
&& !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
&& (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
|| !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
- gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity),
- gnu_expr, 0);
-
- gnu_type = make_node (INTEGER_TYPE);
- TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
+ gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
- /* Set the precision to the Esize except for bit-packed arrays and
- subtypes of Standard.Boolean. */
+ /* Set the precision to the Esize except for bit-packed arrays. */
if (Is_Packed_Array_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
- {
- esize = UI_To_Int (RM_Size (gnat_entity));
- TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
- }
- else if (TREE_CODE (TREE_TYPE (gnu_type)) == BOOLEAN_TYPE)
- esize = 1;
-
- TYPE_PRECISION (gnu_type) = esize;
-
- TYPE_MIN_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_Low_Bound (gnat_entity),
- gnat_entity,
- get_identifier ("L"), definition, 1,
- Needs_Debug_Info (gnat_entity)));
+ esize = UI_To_Int (RM_Size (gnat_entity));
+
+ /* 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))
+ gnu_type = make_unsigned_type (esize);
+ else
+ gnu_type = make_signed_type (esize);
+ TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
- TYPE_MAX_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity,
- get_identifier ("U"), definition, 1,
- Needs_Debug_Info (gnat_entity)));
+ SET_TYPE_RM_MIN_VALUE
+ (gnu_type,
+ convert (TREE_TYPE (gnu_type),
+ elaborate_expression (Type_Low_Bound (gnat_entity),
+ gnat_entity, get_identifier ("L"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity))));
+
+ SET_TYPE_RM_MAX_VALUE
+ (gnu_type,
+ convert (TREE_TYPE (gnu_type),
+ elaborate_expression (Type_High_Bound (gnat_entity),
+ gnat_entity, get_identifier ("U"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity))));
/* One of the above calls might have caused us to be elaborated,
so don't blow up if so. */
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
- /* This should be an unsigned type if the lower bound is constant
- and non-negative or if the base type is unsigned; a signed type
- otherwise. */
- TYPE_UNSIGNED (gnu_type)
- = (TYPE_UNSIGNED (TREE_TYPE (gnu_type))
- || (TREE_CODE (TYPE_MIN_VALUE (gnu_type)) == INTEGER_CST
- && TREE_INT_CST_HIGH (TYPE_MIN_VALUE (gnu_type)) >= 0)
- || TYPE_BIASED_REPRESENTATION_P (gnu_type)
- || Is_Unsigned_Type (gnat_entity));
-
- layout_type (gnu_type);
+ /* 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);
/* Inherit our alias set from what we're a subtype of. Subtypes
are not different types and a pointer can designate any instance
within a subtype hierarchy. */
relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
- /* If the type we are dealing with is to represent a packed array,
+ /* For a packed array, make the original array type a parallel type. */
+ if (debug_info_p
+ && Is_Packed_Array_Type (gnat_entity)
+ && present_gnu_tree (Original_Array_Type (gnat_entity)))
+ add_parallel_type (TYPE_STUB_DECL (gnu_type),
+ gnat_to_gnu_type
+ (Original_Array_Type (gnat_entity)));
+
+ /* We have to handle clauses that under-align the type specially. */
+ if ((Present (Alignment_Clause (gnat_entity))
+ || (Is_Packed_Array_Type (gnat_entity)
+ && Present
+ (Alignment_Clause (Original_Array_Type (gnat_entity)))))
+ && UI_Is_In_Int_Range (Alignment (gnat_entity)))
+ {
+ align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT;
+ if (align >= TYPE_ALIGN (gnu_type))
+ align = 0;
+ }
+
+ /* If the type we are dealing with represents a bit-packed array,
we need to have the bits left justified on big-endian targets
and right justified on little-endian targets. We also need to
ensure that when the value is read (e.g. for comparison of two
such values), we only get the good bits, since the unused bits
- are uninitialized. Both goals are accomplished by wrapping the
- modular value in an enclosing struct. */
+ are uninitialized. Both goals are accomplished by wrapping up
+ the modular type in an enclosing record type. */
if (Is_Packed_Array_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
{
- tree gnu_field_type = gnu_type;
- tree gnu_field;
+ tree gnu_field_type, gnu_field;
+
+ /* Set the RM size before wrapping up the original type. */
+ SET_TYPE_RM_SIZE (gnu_type,
+ UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
+ TYPE_PACKED_ARRAY_TYPE_P (gnu_type) = 1;
+
+ /* Create a stripped-down declaration, mainly for debugging. */
+ create_type_decl (gnu_entity_name, gnu_type, NULL, true,
+ debug_info_p, gnat_entity);
+
+ /* Now save it and build the enclosing record type. */
+ gnu_field_type = gnu_type;
- TYPE_RM_SIZE_NUM (gnu_field_type)
- = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
-
- /* Propagate the alignment of the modular type to the record.
- This means that bitpacked arrays have "ceil" alignment for
- their size, which may seem counter-intuitive but makes it
- possible to easily overlay them on modular types. */
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (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));
+
+ /* Propagate the alignment of the modular type to the record type,
+ unless there is an alignment clause that under-aligns the type.
+ 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);
- /* Create a stripped-down declaration of the original type, mainly
- for debugging. */
- create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
- NULL, true, debug_info_p, gnat_entity);
+ relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
/* Don't notify the field as "addressable", since we won't be taking
it's address and it would prevent create_field_decl from making a
bitfield. */
gnu_field = create_field_decl (get_identifier ("OBJECT"),
- gnu_field_type, gnu_type, 1, 0, 0, 0);
+ gnu_field_type, gnu_type, 1,
+ NULL_TREE, bitsize_zero_node, 0);
- finish_record_type (gnu_type, gnu_field, 0, false);
+ /* Do not emit debug info until after the parallel type is added. */
+ finish_record_type (gnu_type, gnu_field, 2, false);
+ compute_record_mode (gnu_type);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
- SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
- relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
+ if (debug_info_p)
+ {
+ /* Make the original array type a parallel type. */
+ if (present_gnu_tree (Original_Array_Type (gnat_entity)))
+ add_parallel_type (TYPE_STUB_DECL (gnu_type),
+ gnat_to_gnu_type
+ (Original_Array_Type (gnat_entity)));
+
+ 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 under-align
the latter. We reuse the padding machinery for this purpose. */
- else if (Known_Alignment (gnat_entity)
- && UI_Is_In_Int_Range (Alignment (gnat_entity))
- && (align = UI_To_Int (Alignment (gnat_entity)) * BITS_PER_UNIT)
- && align < TYPE_ALIGN (gnu_type))
+ else if (align > 0)
{
- tree gnu_field_type = gnu_type;
- tree gnu_field;
+ 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));
+
+ /* Create a stripped-down declaration, mainly for debugging. */
+ create_type_decl (gnu_entity_name, gnu_type, NULL, true,
+ debug_info_p, gnat_entity);
+
+ /* Now save it and build the enclosing record type. */
+ gnu_field_type = gnu_type;
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
-
- TYPE_ALIGN (gnu_type) = align;
TYPE_PACKED (gnu_type) = 1;
-
- /* Create a stripped-down declaration of the original type, mainly
- for debugging. */
- create_type_decl (get_entity_name (gnat_entity), gnu_field_type,
- NULL, true, debug_info_p, gnat_entity);
+ 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 notify the field as "addressable", since we won't be taking
it's address and it would prevent create_field_decl from making a
bitfield. */
- gnu_field = create_field_decl (get_identifier ("OBJECT"),
- gnu_field_type, gnu_type, 1, 0, 0, 0);
-
- finish_record_type (gnu_type, gnu_field, 0, false);
- TYPE_IS_PADDING_P (gnu_type) = 1;
- SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
+ gnu_field = create_field_decl (get_identifier ("F"),
+ gnu_field_type, gnu_type, 1,
+ NULL_TREE, bitsize_zero_node, 0);
- relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
+ finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
+ compute_record_mode (gnu_type);
+ TYPE_PADDING_P (gnu_type) = 1;
}
- /* Otherwise reset the alignment lest we computed it above. */
- else
- align = 0;
-
break;
case E_Floating_Point_Type:
gnu_type = make_node (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
TYPE_PRECISION (gnu_type) = fp_size_to_prec (esize);
+ TYPE_GCC_MIN_VALUE (gnu_type)
+ = TYPE_GCC_MIN_VALUE (TREE_TYPE (gnu_type));
+ TYPE_GCC_MAX_VALUE (gnu_type)
+ = TYPE_GCC_MAX_VALUE (TREE_TYPE (gnu_type));
+ layout_type (gnu_type);
- TYPE_MIN_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_Low_Bound (gnat_entity),
- gnat_entity, get_identifier ("L"),
- definition, 1,
- Needs_Debug_Info (gnat_entity)));
-
- TYPE_MAX_VALUE (gnu_type)
- = convert (TREE_TYPE (gnu_type),
- elaborate_expression (Type_High_Bound (gnat_entity),
- gnat_entity, get_identifier ("U"),
- definition, 1,
- Needs_Debug_Info (gnat_entity)));
+ SET_TYPE_RM_MIN_VALUE
+ (gnu_type,
+ convert (TREE_TYPE (gnu_type),
+ elaborate_expression (Type_Low_Bound (gnat_entity),
+ gnat_entity, get_identifier ("L"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity))));
+
+ SET_TYPE_RM_MAX_VALUE
+ (gnu_type,
+ convert (TREE_TYPE (gnu_type),
+ elaborate_expression (Type_High_Bound (gnat_entity),
+ gnat_entity, get_identifier ("U"),
+ definition, true,
+ Needs_Debug_Info (gnat_entity))));
/* One of the above calls might have caused us to be elaborated,
so don't blow up if so. */
break;
}
- layout_type (gnu_type);
-
/* Inherit our alias set from what we're a subtype of, as for
integer subtypes. */
relate_alias_sets (gnu_type, TREE_TYPE (gnu_type), ALIAS_SET_COPY);
case E_String_Type:
case E_Array_Type:
{
+ Entity_Id gnat_index, gnat_name;
+ const bool convention_fortran_p
+ = (Convention (gnat_entity) == Convention_Fortran);
+ const int ndim = Number_Dimensions (gnat_entity);
tree gnu_template_fields = NULL_TREE;
tree gnu_template_type = make_node (RECORD_TYPE);
+ tree gnu_template_reference;
tree gnu_ptr_template = build_pointer_type (gnu_template_type);
tree gnu_fat_type = make_node (RECORD_TYPE);
- int ndim = Number_Dimensions (gnat_entity);
- int firstdim
- = (Convention (gnat_entity) == Convention_Fortran) ? ndim - 1 : 0;
- int nextdim
- = (Convention (gnat_entity) == Convention_Fortran) ? - 1 : 1;
+ tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
+ tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
+ tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
int index;
- tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree *));
- tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree *));
- tree gnu_comp_size = 0;
- tree gnu_max_size = size_one_node;
- tree gnu_max_size_unit;
- Entity_Id gnat_ind_subtype;
- Entity_Id gnat_ind_base_subtype;
- tree gnu_template_reference;
- tree tem;
TYPE_NAME (gnu_template_type)
= create_concat_name (gnat_entity, "XUB");
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
if (!definition)
- defer_incomplete_level++, this_deferred = true;
+ {
+ defer_incomplete_level++;
+ this_deferred = true;
+ }
/* 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
tem = chainon (chainon (NULL_TREE,
create_field_decl (get_identifier ("P_ARRAY"),
ptr_void_type_node,
- gnu_fat_type, 0, 0, 0, 0)),
+ gnu_fat_type, 0,
+ NULL_TREE, NULL_TREE, 0)),
create_field_decl (get_identifier ("P_BOUNDS"),
gnu_ptr_template,
- gnu_fat_type, 0, 0, 0, 0));
+ gnu_fat_type, 0,
+ NULL_TREE, NULL_TREE, 0));
/* Make sure we can put this into a register. */
TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
- /* Do not finalize this record type since the types of its fields
- are still incomplete at this point. */
- finish_record_type (gnu_fat_type, tem, 0, true);
- TYPE_IS_FAT_POINTER_P (gnu_fat_type) = 1;
+ /* Do not emit debug info for this record type since the types of its
+ fields are still incomplete at this point. */
+ finish_record_type (gnu_fat_type, tem, 0, false);
+ TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
= build_unary_op (INDIRECT_REF, gnu_template_type, tem);
TREE_READONLY (gnu_template_reference) = 1;
- /* Now create the GCC type for each index and add the fields for
- that index to the template. */
- for (index = firstdim, gnat_ind_subtype = First_Index (gnat_entity),
- gnat_ind_base_subtype
- = First_Index (Implementation_Base_Type (gnat_entity));
- index < ndim && index >= 0;
- index += nextdim,
- gnat_ind_subtype = Next_Index (gnat_ind_subtype),
- gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
+ /* Now create the GCC type for each index and add the fields for that
+ index to the template. */
+ for (index = (convention_fortran_p ? ndim - 1 : 0),
+ gnat_index = First_Index (gnat_entity);
+ 0 <= index && index < ndim;
+ index += (convention_fortran_p ? - 1 : 1),
+ gnat_index = Next_Index (gnat_index))
{
- char field_name[10];
- tree gnu_ind_subtype
- = get_unpadded_type (Base_Type (Etype (gnat_ind_subtype)));
- tree gnu_base_subtype
- = get_unpadded_type (Etype (gnat_ind_base_subtype));
- tree gnu_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
- tree gnu_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
- tree gnu_min_field, gnu_max_field, gnu_min, gnu_max;
-
- /* Make the FIELD_DECLs for the minimum and maximum of this
- type and then make extractions of that field from the
+ char field_name[16];
+ tree gnu_index_base_type
+ = get_unpadded_type (Base_Type (Etype (gnat_index)));
+ tree gnu_low_field, gnu_high_field, gnu_low, gnu_high, gnu_max;
+
+ /* Make the FIELD_DECLs for the low and high bounds of this
+ type and then make extractions of these fields from the
template. */
sprintf (field_name, "LB%d", index);
- gnu_min_field = create_field_decl (get_identifier (field_name),
- gnu_ind_subtype,
- gnu_template_type, 0, 0, 0, 0);
- field_name[0] = 'U';
- gnu_max_field = create_field_decl (get_identifier (field_name),
- gnu_ind_subtype,
- gnu_template_type, 0, 0, 0, 0);
-
+ gnu_low_field = create_field_decl (get_identifier (field_name),
+ gnu_index_base_type,
+ gnu_template_type, 0,
+ NULL_TREE, NULL_TREE, 0);
Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_min_field));
+ &DECL_SOURCE_LOCATION (gnu_low_field));
+
+ field_name[0] = 'U';
+ gnu_high_field = create_field_decl (get_identifier (field_name),
+ gnu_index_base_type,
+ gnu_template_type, 0,
+ NULL_TREE, NULL_TREE, 0);
Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_max_field));
- gnu_temp_fields[index] = chainon (gnu_min_field, gnu_max_field);
+ &DECL_SOURCE_LOCATION (gnu_high_field));
- /* We can't use build_component_ref here since the template
- type isn't complete yet. */
- gnu_min = build3 (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_min_field,
- NULL_TREE);
- gnu_max = build3 (COMPONENT_REF, gnu_ind_subtype,
- gnu_template_reference, gnu_max_field,
- NULL_TREE);
- TREE_READONLY (gnu_min) = TREE_READONLY (gnu_max) = 1;
+ gnu_temp_fields[index] = chainon (gnu_low_field, gnu_high_field);
- /* Make a range type with the new ranges, but using
- the Ada subtype. Then we convert to sizetype. */
+ /* We can't use build_component_ref here since the template type
+ isn't complete yet. */
+ gnu_low = build3 (COMPONENT_REF, gnu_index_base_type,
+ gnu_template_reference, gnu_low_field,
+ NULL_TREE);
+ gnu_high = build3 (COMPONENT_REF, gnu_index_base_type,
+ gnu_template_reference, gnu_high_field,
+ NULL_TREE);
+ TREE_READONLY (gnu_low) = TREE_READONLY (gnu_high) = 1;
+
+ /* Compute the size of this dimension. */
+ gnu_max
+ = build3 (COND_EXPR, gnu_index_base_type,
+ build2 (GE_EXPR, integer_type_node, gnu_high, gnu_low),
+ gnu_high,
+ build2 (MINUS_EXPR, gnu_index_base_type,
+ gnu_low, fold_convert (gnu_index_base_type,
+ integer_one_node)));
+
+ /* Make a range type with the new range in the Ada base type.
+ Then make an index type with the size range in sizetype. */
gnu_index_types[index]
- = create_index_type (convert (sizetype, gnu_min),
+ = create_index_type (convert (sizetype, gnu_low),
convert (sizetype, gnu_max),
- build_range_type (gnu_ind_subtype,
- gnu_min, gnu_max),
+ create_range_type (gnu_index_base_type,
+ gnu_low, gnu_high),
gnat_entity);
- /* Update the maximum size of the array, in elements. */
- gnu_max_size
- = size_binop (MULT_EXPR, gnu_max_size,
- size_binop (PLUS_EXPR, size_one_node,
- size_binop (MINUS_EXPR, gnu_base_max,
- gnu_base_min)));
+
+ /* 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
+ = convert (sizetype, TYPE_MAX_VALUE (gnu_index_type));
+ tree gnu_this_max
+ = size_binop (MAX_EXPR,
+ size_binop (PLUS_EXPR, size_one_node,
+ size_binop (MINUS_EXPR,
+ gnu_max, gnu_min)),
+ size_zero_node);
+
+ if (TREE_CODE (gnu_this_max) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_this_max))
+ gnu_max_size = NULL_TREE;
+ else
+ gnu_max_size
+ = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
+ }
TYPE_NAME (gnu_index_types[index])
= create_concat_name (gnat_entity, field_name);
= chainon (gnu_template_fields, gnu_temp_fields[index]);
/* Install all the fields into the template. */
- finish_record_type (gnu_template_type, gnu_template_fields, 0, false);
+ finish_record_type (gnu_template_type, gnu_template_fields, 0,
+ debug_info_p);
TYPE_READONLY (gnu_template_type) = 1;
/* Now make the array of arrays and update the pointer to the array
in the fat pointer. Note that it is the first field. */
- tem = gnat_to_gnu_type (Component_Type (gnat_entity));
-
- /* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_entity)
- || Has_Component_Size_Clause (gnat_entity))
- && !Is_Bit_Packed_Array (gnat_entity)
- && !Has_Aliased_Components (gnat_entity)
- && !Strict_Alignment (Component_Type (gnat_entity))
- && TREE_CODE (tem) == RECORD_TYPE
- && !TYPE_IS_FAT_POINTER_P (tem)
- && host_integerp (TYPE_SIZE (tem), 1))
- tem = make_packable_type (tem, false);
-
- if (Has_Atomic_Components (gnat_entity))
- check_ok_for_atomic (tem, gnat_entity, true);
-
- /* Get and validate any specified Component_Size, but if Packed,
- ignore it since the front end will have taken care of it. */
- gnu_comp_size
- = validate_size (Component_Size (gnat_entity), tem,
- gnat_entity,
- (Is_Bit_Packed_Array (gnat_entity)
- ? TYPE_DECL : VAR_DECL),
- true, Has_Component_Size_Clause (gnat_entity));
-
- /* If the component type is a RECORD_TYPE that has a self-referential
- size, use the maximum size. */
- if (!gnu_comp_size && TREE_CODE (tem) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (tem)))
- gnu_comp_size = max_size (TYPE_SIZE (tem), true);
-
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
- {
- tree orig_tem;
- tem = make_type_from_size (tem, gnu_comp_size, false);
- orig_tem = tem;
- tem = maybe_pad_type (tem, gnu_comp_size, 0, gnat_entity,
- "C_PAD", 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 (tem != orig_tem)
- create_type_decl (TYPE_NAME (tem), tem, NULL, true,
- debug_info_p, gnat_entity);
- }
-
- if (Has_Volatile_Components (gnat_entity))
- tem = build_qualified_type (tem,
- TYPE_QUALS (tem) | TYPE_QUAL_VOLATILE);
+ tem = gnat_to_gnu_component_type (gnat_entity, definition,
+ debug_info_p);
/* If Component_Size is not already specified, annotate it with the
size of the component. */
if (Unknown_Component_Size (gnat_entity))
Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
- gnu_max_size_unit = size_binop (MAX_EXPR, size_zero_node,
- size_binop (MULT_EXPR, gnu_max_size,
- TYPE_SIZE_UNIT (tem)));
- gnu_max_size = size_binop (MAX_EXPR, bitsize_zero_node,
- size_binop (MULT_EXPR,
- convert (bitsizetype,
- gnu_max_size),
- TYPE_SIZE (tem)));
+ /* Compute the maximum size of the array in units and bits. */
+ if (gnu_max_size)
+ {
+ gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
+ TYPE_SIZE_UNIT (tem));
+ gnu_max_size = size_binop (MULT_EXPR,
+ convert (bitsizetype, gnu_max_size),
+ TYPE_SIZE (tem));
+ }
+ else
+ gnu_max_size_unit = NULL_TREE;
+ /* Now build the array type. */
for (index = ndim - 1; index >= 0; index--)
{
tem = build_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
- if (array_type_has_nonaliased_component (gnat_entity, tem))
+ if (array_type_has_nonaliased_component (tem, gnat_entity))
TYPE_NONALIASED_COMPONENT (tem) = 1;
}
- /* If an alignment is specified, use it if valid. But ignore it for
- types that represent the unpacked base type for packed arrays. If
- the alignment was requested with an explicit user alignment clause,
- state so. */
+ /* If an alignment is specified, use it if valid. But ignore it
+ for the original type of packed array types. If the alignment
+ was requested with an explicit alignment clause, state so. */
if (No (Packed_Array_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
- gcc_assert (Present (Alignment (gnat_entity)));
TYPE_ALIGN (tem)
= validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (tem));
TYPE_USER_ALIGN (tem) = 1;
}
- TYPE_CONVENTION_FORTRAN_P (tem)
- = (Convention (gnat_entity) == Convention_Fortran);
+ TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
/* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
/* If the maximum size doesn't overflow, use it. */
- if (TREE_CODE (gnu_max_size) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max_size))
- TYPE_SIZE (tem)
- = size_binop (MIN_EXPR, gnu_max_size, TYPE_SIZE (tem));
- if (TREE_CODE (gnu_max_size_unit) == INTEGER_CST
+ if (gnu_max_size
+ && TREE_CODE (gnu_max_size) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_max_size)
+ && TREE_CODE (gnu_max_size_unit) == INTEGER_CST
&& !TREE_OVERFLOW (gnu_max_size_unit))
- TYPE_SIZE_UNIT (tem)
- = size_binop (MIN_EXPR, gnu_max_size_unit,
- TYPE_SIZE_UNIT (tem));
+ {
+ TYPE_SIZE (tem) = size_binop (MIN_EXPR, gnu_max_size,
+ TYPE_SIZE (tem));
+ TYPE_SIZE_UNIT (tem) = size_binop (MIN_EXPR, gnu_max_size_unit,
+ TYPE_SIZE_UNIT (tem));
+ }
create_type_decl (create_concat_name (gnat_entity, "XUA"),
tem, NULL, !Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
- /* Give the fat pointer type a name. */
- create_type_decl (create_concat_name (gnat_entity, "XUP"),
+ /* Give the fat pointer type a name. If this is a packed type, tell
+ the debugger how to interpret the underlying bits. */
+ if (Present (Packed_Array_Type (gnat_entity)))
+ gnat_name = Packed_Array_Type (gnat_entity);
+ else
+ gnat_name = gnat_entity;
+ create_type_decl (create_concat_name (gnat_name, "XUP"),
gnu_fat_type, NULL, true,
debug_info_p, gnat_entity);
record type for the object and its template with the field offsets
shifted to have the template at a negative offset. */
tem = build_unc_object_type (gnu_template_type, tem,
- create_concat_name (gnat_entity, "XUT"));
+ create_concat_name (gnat_name, "XUT"));
shift_unc_components_for_thin_pointers (tem);
SET_TYPE_UNCONSTRAINED_ARRAY (tem, gnu_type);
TYPE_OBJECT_RECORD_TYPE (gnu_type) = tem;
-
- /* Give the thin pointer type a name. */
- create_type_decl (create_concat_name (gnat_entity, "XUX"),
- build_pointer_type (tem), NULL, true,
- debug_info_p, gnat_entity);
}
break;
case E_Array_Subtype:
/* This is the actual data type for array variables. Multidimensional
- arrays are implemented in the gnu tree as arrays of arrays. Note
- that for the moment arrays which have sparse enumeration subtypes as
- index components create sparse arrays, which is obviously space
- inefficient but so much easier to code for now.
+ arrays are implemented as arrays of arrays. Note that arrays which
+ have sparse enumeration subtypes as index components create sparse
+ arrays, which is obviously space inefficient but so much easier to
+ code for now.
- Also note that the subtype never refers to the unconstrained
- array type, which is somewhat at variance with Ada semantics.
+ Also note that the subtype never refers to the unconstrained array
+ type, which is somewhat at variance with Ada semantics.
- First check to see if this is simply a renaming of the array
- type. If so, the result is the array type. */
+ First check to see if this is simply a renaming of the array type.
+ If so, the result is the array type. */
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
if (!Is_Constrained (gnat_entity))
- break;
+ ;
else
{
- int index;
- int array_dim = Number_Dimensions (gnat_entity);
- int first_dim
- = ((Convention (gnat_entity) == Convention_Fortran)
- ? array_dim - 1 : 0);
- int next_dim
- = (Convention (gnat_entity) == Convention_Fortran) ? -1 : 1;
- Entity_Id gnat_ind_subtype;
- Entity_Id gnat_ind_base_subtype;
+ Entity_Id gnat_index, gnat_base_index;
+ const bool convention_fortran_p
+ = (Convention (gnat_entity) == Convention_Fortran);
+ const int ndim = Number_Dimensions (gnat_entity);
tree gnu_base_type = gnu_type;
- tree *gnu_index_type = (tree *) alloca (array_dim * sizeof (tree *));
- tree gnu_comp_size = NULL_TREE;
- tree gnu_max_size = size_one_node;
- tree gnu_max_size_unit;
+ tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
+ tree gnu_max_size = size_one_node, gnu_max_size_unit;
bool need_index_type_struct = false;
- bool max_overflow = false;
-
- /* First create the gnu types for each index. Create types for
- debugging information to point to the index types if the
- are not integer types, have variable bounds, or are
- wider than sizetype. */
+ int index;
- for (index = first_dim, gnat_ind_subtype = First_Index (gnat_entity),
- gnat_ind_base_subtype
+ /* First create the GCC type for each index and find out whether
+ special types are needed for debugging information. */
+ for (index = (convention_fortran_p ? ndim - 1 : 0),
+ gnat_index = First_Index (gnat_entity),
+ gnat_base_index
= First_Index (Implementation_Base_Type (gnat_entity));
- index < array_dim && index >= 0;
- index += next_dim,
- gnat_ind_subtype = Next_Index (gnat_ind_subtype),
- gnat_ind_base_subtype = Next_Index (gnat_ind_base_subtype))
+ 0 <= index && index < ndim;
+ index += (convention_fortran_p ? - 1 : 1),
+ gnat_index = Next_Index (gnat_index),
+ gnat_base_index = Next_Index (gnat_base_index))
{
- tree gnu_index_subtype
- = get_unpadded_type (Etype (gnat_ind_subtype));
- tree gnu_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_index_subtype));
- tree gnu_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_index_subtype));
- tree gnu_base_subtype
- = get_unpadded_type (Etype (gnat_ind_base_subtype));
- tree gnu_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_subtype));
- tree gnu_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_subtype));
- tree gnu_base_type = get_base_type (gnu_base_subtype);
- tree gnu_base_base_min
- = convert (sizetype, TYPE_MIN_VALUE (gnu_base_type));
- tree gnu_base_base_max
- = convert (sizetype, TYPE_MAX_VALUE (gnu_base_type));
- tree gnu_high;
- tree gnu_this_max;
-
- /* If the minimum and maximum values both overflow in
- SIZETYPE, but the difference in the original type
- does not overflow in SIZETYPE, ignore the overflow
- indications. */
- if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)
- || TYPE_UNSIGNED (gnu_index_subtype)
- != TYPE_UNSIGNED (sizetype))
- && TREE_CODE (gnu_min) == INTEGER_CST
- && TREE_CODE (gnu_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
- && (!TREE_OVERFLOW
- (fold_build2 (MINUS_EXPR, gnu_index_subtype,
- TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype)))))
+ tree gnu_index_type = get_unpadded_type (Etype (gnat_index));
+ const int prec_comp
+ = compare_tree_int (TYPE_RM_SIZE (gnu_index_type),
+ TYPE_PRECISION (sizetype));
+ const bool subrange_p = (prec_comp < 0)
+ || (prec_comp == 0
+ && TYPE_UNSIGNED (gnu_index_type)
+ == TYPE_UNSIGNED (sizetype));
+ const bool wider_p = (prec_comp > 0);
+ tree gnu_orig_min = TYPE_MIN_VALUE (gnu_index_type);
+ tree gnu_orig_max = TYPE_MAX_VALUE (gnu_index_type);
+ tree gnu_min = convert (sizetype, gnu_orig_min);
+ tree gnu_max = convert (sizetype, gnu_orig_max);
+ tree gnu_base_index_type
+ = get_unpadded_type (Etype (gnat_base_index));
+ tree gnu_base_orig_min = TYPE_MIN_VALUE (gnu_base_index_type);
+ tree gnu_base_orig_max = TYPE_MAX_VALUE (gnu_base_index_type);
+ tree gnu_high, gnu_low;
+
+ /* See if the base array type is already flat. If it is, we
+ are probably compiling an ACATS test but it will cause the
+ code below to malfunction if we don't handle it specially. */
+ if (TREE_CODE (gnu_base_orig_min) == INTEGER_CST
+ && TREE_CODE (gnu_base_orig_max) == INTEGER_CST
+ && tree_int_cst_lt (gnu_base_orig_max, gnu_base_orig_min))
{
- TREE_OVERFLOW (gnu_min) = 0;
- TREE_OVERFLOW (gnu_max) = 0;
+ gnu_min = size_one_node;
+ gnu_max = size_zero_node;
+ gnu_high = gnu_max;
}
- /* Similarly, if the range is null, use bounds of 1..0 for
- the sizetype bounds. */
- else if ((TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)
- || TYPE_UNSIGNED (gnu_index_subtype)
- != TYPE_UNSIGNED (sizetype))
+ /* Similarly, if one of the values overflows in sizetype and the
+ range is null, use 1..0 for the sizetype bounds. */
+ else if (!subrange_p
&& TREE_CODE (gnu_min) == INTEGER_CST
&& TREE_CODE (gnu_max) == INTEGER_CST
&& (TREE_OVERFLOW (gnu_min) || TREE_OVERFLOW (gnu_max))
- && tree_int_cst_lt (TYPE_MAX_VALUE (gnu_index_subtype),
- TYPE_MIN_VALUE (gnu_index_subtype)))
- gnu_min = size_one_node, gnu_max = size_zero_node;
-
- /* Now compute the size of this bound. We need to provide
- GCC with an upper bound to use but have to deal with the
- "superflat" case. There are three ways to do this. If we
- can prove that the array can never be superflat, we can
- just use the high bound of the index subtype. If we can
- prove that the low bound minus one can't overflow, we
- can do this as MAX (hb, lb - 1). Otherwise, we have to use
- the expression hb >= lb ? hb : lb - 1. */
- gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
+ && tree_int_cst_lt (gnu_orig_max, gnu_orig_min))
+ {
+ gnu_min = size_one_node;
+ gnu_max = size_zero_node;
+ gnu_high = gnu_max;
+ }
- /* See if the base array type is already flat. If it is, we
- are probably compiling an ACVC test, but it will cause the
- code below to malfunction if we don't handle it specially. */
- if (TREE_CODE (gnu_base_min) == INTEGER_CST
- && TREE_CODE (gnu_base_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_min)
- && !TREE_OVERFLOW (gnu_base_max)
- && tree_int_cst_lt (gnu_base_max, gnu_base_min))
- gnu_high = size_zero_node, gnu_min = size_one_node;
-
- /* If gnu_high is now an integer which overflowed, the array
- cannot be superflat. */
- else if (TREE_CODE (gnu_high) == INTEGER_CST
- && TREE_OVERFLOW (gnu_high))
+ /* If the minimum and maximum values both overflow in sizetype,
+ but the difference in the original type does not overflow in
+ sizetype, ignore the overflow indication. */
+ else if (!subrange_p
+ && TREE_CODE (gnu_min) == INTEGER_CST
+ && TREE_CODE (gnu_max) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_min) && TREE_OVERFLOW (gnu_max)
+ && !TREE_OVERFLOW
+ (convert (sizetype,
+ fold_build2 (MINUS_EXPR, gnu_index_type,
+ gnu_orig_max,
+ gnu_orig_min))))
+ {
+ TREE_OVERFLOW (gnu_min) = 0;
+ TREE_OVERFLOW (gnu_max) = 0;
+ gnu_high = gnu_max;
+ }
+
+ /* Compute the size of this dimension in the general case. We
+ need to provide GCC with an upper bound to use but have to
+ deal with the "superflat" case. There are three ways to do
+ this. If we can prove that the array can never be superflat,
+ we can just use the high bound of the index type. */
+ else if (Nkind (gnat_index) == N_Range
+ && cannot_be_superflat_p (gnat_index))
gnu_high = gnu_max;
- else if (TYPE_UNSIGNED (gnu_base_subtype)
- || TREE_CODE (gnu_high) == INTEGER_CST)
- gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
+
+ /* Otherwise, if we can prove that the low bound minus one and
+ the high bound cannot overflow, we can just use the expression
+ MAX (hb, lb - 1). Similarly, if we can prove that the high
+ bound plus one and the low bound cannot overflow, we can use
+ the high bound as-is and MIN (hb + 1, lb) for the low bound.
+ Otherwise, we have to fall back to the most general expression
+ (hb >= lb) ? hb : lb - 1. Note that the comparison must be
+ done in the original index type, to avoid any overflow during
+ the conversion. */
else
- gnu_high
- = build_cond_expr
- (sizetype, build_binary_op (GE_EXPR, integer_type_node,
- gnu_max, gnu_min),
- gnu_max, gnu_high);
-
- gnu_index_type[index]
- = create_index_type (gnu_min, gnu_high, gnu_index_subtype,
+ {
+ gnu_high = size_binop (MINUS_EXPR, gnu_min, size_one_node);
+ gnu_low = size_binop (PLUS_EXPR, gnu_max, size_one_node);
+
+ /* If gnu_high is a constant that has overflowed, the low
+ bound is the smallest integer so cannot be the maximum.
+ If gnu_low is a constant that has overflowed, the high
+ bound is the highest integer so cannot be the minimum. */
+ if ((TREE_CODE (gnu_high) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_high))
+ || (TREE_CODE (gnu_low) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_low)))
+ gnu_high = gnu_max;
+
+ /* If the index type is a subrange and gnu_high a constant
+ that hasn't overflowed, we can use the maximum. */
+ else if (subrange_p && TREE_CODE (gnu_high) == INTEGER_CST)
+ gnu_high = size_binop (MAX_EXPR, gnu_max, gnu_high);
+
+ /* If the index type is a subrange and gnu_low a constant
+ that hasn't overflowed, we can use the minimum. */
+ else if (subrange_p && TREE_CODE (gnu_low) == INTEGER_CST)
+ {
+ gnu_high = gnu_max;
+ gnu_min = size_binop (MIN_EXPR, gnu_min, gnu_low);
+ }
+
+ else
+ gnu_high
+ = build_cond_expr (sizetype,
+ build_binary_op (GE_EXPR,
+ integer_type_node,
+ gnu_orig_max,
+ gnu_orig_min),
+ gnu_max, gnu_high);
+ }
+
+ gnu_index_types[index]
+ = create_index_type (gnu_min, gnu_high, gnu_index_type,
gnat_entity);
- /* Also compute the maximum size of the array. Here we
+ /* Update the maximum size of the array in elements. Here we
see if any constraint on the index type of the base type
- can be used in the case of self-referential bound on
- the index type of the subtype. We look for a non-"infinite"
+ can be used in the case of self-referential bound on the
+ index type of the subtype. We look for a non-"infinite"
and non-self-referential bound from any type involved and
handle each bound separately. */
+ if (gnu_max_size)
+ {
+ 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));
+ tree gnu_base_base_max
+ = convert (sizetype,
+ TYPE_MAX_VALUE (gnu_base_index_base_type));
+
+ if (!CONTAINS_PLACEHOLDER_P (gnu_min)
+ || !(TREE_CODE (gnu_base_min) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_base_min)))
+ gnu_base_min = gnu_min;
+
+ if (!CONTAINS_PLACEHOLDER_P (gnu_max)
+ || !(TREE_CODE (gnu_base_max) == INTEGER_CST
+ && !TREE_OVERFLOW (gnu_base_max)))
+ gnu_base_max = gnu_max;
+
+ if ((TREE_CODE (gnu_base_min) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_base_min))
+ || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
+ || (TREE_CODE (gnu_base_max) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_base_max))
+ || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
+ gnu_max_size = NULL_TREE;
+ else
+ {
+ tree gnu_this_max
+ = size_binop (MAX_EXPR,
+ size_binop (PLUS_EXPR, size_one_node,
+ size_binop (MINUS_EXPR,
+ gnu_base_max,
+ gnu_base_min)),
+ size_zero_node);
+
+ if (TREE_CODE (gnu_this_max) == INTEGER_CST
+ && TREE_OVERFLOW (gnu_this_max))
+ gnu_max_size = NULL_TREE;
+ else
+ gnu_max_size
+ = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
+ }
+ }
- if ((TREE_CODE (gnu_min) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_min)
- && !operand_equal_p (gnu_min, gnu_base_base_min, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_min)
- || !(TREE_CODE (gnu_base_min) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_min)))
- gnu_base_min = gnu_min;
-
- if ((TREE_CODE (gnu_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_max)
- && !operand_equal_p (gnu_max, gnu_base_base_max, 0))
- || !CONTAINS_PLACEHOLDER_P (gnu_max)
- || !(TREE_CODE (gnu_base_max) == INTEGER_CST
- && !TREE_OVERFLOW (gnu_base_max)))
- gnu_base_max = gnu_max;
-
- if ((TREE_CODE (gnu_base_min) == INTEGER_CST
- && TREE_OVERFLOW (gnu_base_min))
- || operand_equal_p (gnu_base_min, gnu_base_base_min, 0)
- || (TREE_CODE (gnu_base_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_base_max))
- || operand_equal_p (gnu_base_max, gnu_base_base_max, 0))
- max_overflow = true;
-
- gnu_base_min = size_binop (MAX_EXPR, gnu_base_min, gnu_min);
- gnu_base_max = size_binop (MIN_EXPR, gnu_base_max, gnu_max);
-
- gnu_this_max
- = size_binop (MAX_EXPR,
- size_binop (PLUS_EXPR, size_one_node,
- size_binop (MINUS_EXPR, gnu_base_max,
- gnu_base_min)),
- size_zero_node);
-
- if (TREE_CODE (gnu_this_max) == INTEGER_CST
- && TREE_OVERFLOW (gnu_this_max))
- max_overflow = true;
-
- gnu_max_size
- = size_binop (MULT_EXPR, gnu_max_size, gnu_this_max);
-
- if (!integer_onep (TYPE_MIN_VALUE (gnu_index_subtype))
- || (TREE_CODE (TYPE_MAX_VALUE (gnu_index_subtype))
- != INTEGER_CST)
- || TREE_CODE (gnu_index_subtype) != INTEGER_TYPE
- || (TREE_TYPE (gnu_index_subtype)
- && (TREE_CODE (TREE_TYPE (gnu_index_subtype))
- != INTEGER_TYPE))
- || TYPE_BIASED_REPRESENTATION_P (gnu_index_subtype)
- || (TYPE_PRECISION (gnu_index_subtype)
- > TYPE_PRECISION (sizetype)))
+ /* We need special types for debugging information to point to
+ the index types if they have variable bounds, are not integer
+ types, are biased or are wider than sizetype. */
+ if (!integer_onep (gnu_orig_min)
+ || 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)
+ || wider_p)
need_index_type_struct = true;
}
&& !Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)))
{
gnu_type = gnat_to_gnu_type (Original_Array_Type (gnat_entity));
- for (index = array_dim - 1; index >= 0; index--)
+ for (index = ndim - 1; index >= 0; index--)
gnu_type = TREE_TYPE (gnu_type);
/* One of the above calls might have caused us to be elaborated,
}
else
{
- gnu_type = gnat_to_gnu_type (Component_Type (gnat_entity));
+ gnu_type = gnat_to_gnu_component_type (gnat_entity, definition,
+ debug_info_p);
/* One of the above calls might have caused us to be elaborated,
so don't blow up if so. */
maybe_present = true;
break;
}
-
- /* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_entity)
- || Has_Component_Size_Clause (gnat_entity))
- && !Is_Bit_Packed_Array (gnat_entity)
- && !Has_Aliased_Components (gnat_entity)
- && !Strict_Alignment (Component_Type (gnat_entity))
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && !TYPE_IS_FAT_POINTER_P (gnu_type)
- && host_integerp (TYPE_SIZE (gnu_type), 1))
- gnu_type = make_packable_type (gnu_type, false);
-
- /* Get and validate any specified Component_Size, but if Packed,
- ignore it since the front end will have taken care of it. */
- gnu_comp_size
- = validate_size (Component_Size (gnat_entity), gnu_type,
- gnat_entity,
- (Is_Bit_Packed_Array (gnat_entity)
- ? TYPE_DECL : VAR_DECL), true,
- Has_Component_Size_Clause (gnat_entity));
-
- /* If the component type is a RECORD_TYPE that has a
- self-referential size, use the maximum size. */
- if (!gnu_comp_size
- && TREE_CODE (gnu_type) == RECORD_TYPE
- && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
-
- if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_entity))
- {
- tree orig_gnu_type;
- gnu_type
- = make_type_from_size (gnu_type, gnu_comp_size, false);
- orig_gnu_type = gnu_type;
- gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0,
- gnat_entity, "C_PAD", 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_gnu_type)
- create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL,
- true, debug_info_p, gnat_entity);
- }
-
- if (Has_Volatile_Components (Base_Type (gnat_entity)))
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_VOLATILE));
}
- gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
- TYPE_SIZE_UNIT (gnu_type));
- gnu_max_size = size_binop (MULT_EXPR,
- convert (bitsizetype, gnu_max_size),
- TYPE_SIZE (gnu_type));
+ /* Compute the maximum size of the array in units and bits. */
+ if (gnu_max_size)
+ {
+ gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
+ TYPE_SIZE_UNIT (gnu_type));
+ gnu_max_size = size_binop (MULT_EXPR,
+ convert (bitsizetype, gnu_max_size),
+ TYPE_SIZE (gnu_type));
+ }
+ else
+ gnu_max_size_unit = NULL_TREE;
- for (index = array_dim - 1; index >= 0; index --)
+ /* Now build the array type. */
+ for (index = ndim - 1; index >= 0; index --)
{
- gnu_type = build_array_type (gnu_type, gnu_index_type[index]);
+ gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
- if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
+ if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
}
/* Attach the TYPE_STUB_DECL in case we have a parallel type. */
- if (need_index_type_struct)
- TYPE_STUB_DECL (gnu_type)
- = create_type_stub_decl (gnu_entity_id, gnu_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, we
- need to make a variable corresponding to the stride of the
+ /* If we are at file level and this is a multi-dimensional array,
+ we need to make a variable corresponding to the stride of the
inner dimensions. */
- if (global_bindings_p () && array_dim > 1)
+ if (global_bindings_p () && ndim > 1)
{
tree gnu_str_name = get_identifier ("ST");
tree gnu_arr_type;
for (gnu_arr_type = TREE_TYPE (gnu_type);
TREE_CODE (gnu_arr_type) == ARRAY_TYPE;
gnu_arr_type = TREE_TYPE (gnu_arr_type),
- gnu_str_name = concat_id_with_name (gnu_str_name, "ST"))
+ gnu_str_name = concat_name (gnu_str_name, "ST"))
{
tree eltype = TREE_TYPE (gnu_arr_type);
TYPE_SIZE (gnu_arr_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_arr_type),
- gnu_str_name, definition, 0);
+ = elaborate_expression_1 (TYPE_SIZE (gnu_arr_type),
+ gnat_entity, gnu_str_name,
+ definition, false);
/* ??? For now, store the size as a multiple of the
alignment of the element type in bytes so that we
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
- (gnat_entity, gnat_entity,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
+ (build_binary_op (EXACT_DIV_EXPR, sizetype,
TYPE_SIZE_UNIT (gnu_arr_type),
size_int (TYPE_ALIGN (eltype)
/ BITS_PER_UNIT)),
- concat_id_with_name (gnu_str_name, "A_U"),
- definition, 0),
+ gnat_entity, concat_name (gnu_str_name, "A_U"),
+ definition, false),
size_int (TYPE_ALIGN (eltype) / BITS_PER_UNIT));
/* ??? create_type_decl is not invoked on the inner types so
the MULT_EXPR node built above will never be marked. */
- mark_visited (&TYPE_SIZE_UNIT (gnu_arr_type));
+ MARK_VISITED (TYPE_SIZE_UNIT (gnu_arr_type));
}
}
- /* If we need to write out a record type giving the names of
- the bounds, do it now. Make sure to reference the index
- types themselves, not just their names, as the debugger
- may fall back on them in some cases. */
- if (need_index_type_struct && debug_info_p)
+ /* If we need to write out a record type giving the names of the
+ bounds for debugging purposes, do it now and make the record
+ type a parallel type. This is not needed for a packed array
+ since the bounds are conveyed by the original array type. */
+ if (need_index_type_struct
+ && debug_info_p
+ && !Is_Packed_Array_Type (gnat_entity))
{
tree gnu_bound_rec = make_node (RECORD_TYPE);
tree gnu_field_list = NULL_TREE;
TYPE_NAME (gnu_bound_rec)
= create_concat_name (gnat_entity, "XA");
- for (index = array_dim - 1; index >= 0; index--)
+ for (index = ndim - 1; index >= 0; index--)
{
- tree gnu_index = TYPE_INDEX_TYPE (gnu_index_type[index]);
+ tree gnu_index = TYPE_INDEX_TYPE (gnu_index_types[index]);
tree gnu_index_name = TYPE_NAME (gnu_index);
if (TREE_CODE (gnu_index_name) == TYPE_DECL)
gnu_index_name = DECL_NAME (gnu_index_name);
+ /* Make sure to reference the types themselves, and not just
+ their names, as the debugger may fall back on them. */
gnu_field = create_field_decl (gnu_index_name, gnu_index,
gnu_bound_rec,
0, NULL_TREE, NULL_TREE, 0);
gnu_field_list = gnu_field;
}
- finish_record_type (gnu_bound_rec, gnu_field_list, 0, false);
+ finish_record_type (gnu_bound_rec, gnu_field_list, 0, true);
add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
}
- TYPE_CONVENTION_FORTRAN_P (gnu_type)
- = (Convention (gnat_entity) == Convention_Fortran);
+ /* Otherwise, for a packed array, make the original array type a
+ parallel type. */
+ else if (debug_info_p
+ && Is_Packed_Array_Type (gnat_entity)
+ && present_gnu_tree (Original_Array_Type (gnat_entity)))
+ add_parallel_type (TYPE_STUB_DECL (gnu_type),
+ gnat_to_gnu_type
+ (Original_Array_Type (gnat_entity)));
+
+ TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= (Is_Packed_Array_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
- /* If our size depends on a placeholder and the maximum size doesn't
+ /* If the size is self-referential and the maximum size doesn't
overflow, use it. */
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
+ && gnu_max_size
&& !(TREE_CODE (gnu_max_size) == INTEGER_CST
&& TREE_OVERFLOW (gnu_max_size))
&& !(TREE_CODE (gnu_max_size_unit) == INTEGER_CST
- && TREE_OVERFLOW (gnu_max_size_unit))
- && !max_overflow)
+ && TREE_OVERFLOW (gnu_max_size_unit)))
{
TYPE_SIZE (gnu_type) = size_binop (MIN_EXPR, gnu_max_size,
TYPE_SIZE (gnu_type));
/* Set our alias set to that of our base type. This gives all
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 (Present (Packed_Array_Type (gnat_entity)))
- {
- Entity_Id gnat_index;
- tree gnu_inner_type;
- /* First finish the type we had been making so that we output
- debugging information for it. */
- gnu_type
- = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | (TYPE_QUAL_VOLATILE
- * Treat_As_Volatile (gnat_entity))));
-
- /* Make it artificial only if the base type was artificial as well.
- That's sort of "morally" true and will make it possible for the
- debugger to look it up by name in DWARF more easily. */
- gnu_decl
- = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity)
- && !Comes_From_Source (Etype (gnat_entity)),
- 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_Type (gnat_entity),
- NULL_TREE, 0);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, NULL_TREE, false);
-
- gnu_inner_type = gnu_type;
- while (TREE_CODE (gnu_inner_type) == RECORD_TYPE
- && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner_type)
- || TYPE_IS_PADDING_P (gnu_inner_type)))
- gnu_inner_type = TREE_TYPE (TYPE_FIELDS (gnu_inner_type));
-
- /* We need to point the type we just made to our index type so
- the actual bounds can be put into a template. */
-
- if ((TREE_CODE (gnu_inner_type) == ARRAY_TYPE
- && !TYPE_ACTUAL_BOUNDS (gnu_inner_type))
- || (TREE_CODE (gnu_inner_type) == INTEGER_TYPE
- && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type)))
+ /* If this is a packed type, make this type the same as the packed
+ array type, but do some adjusting in the type first. */
+ if (Present (Packed_Array_Type (gnat_entity)))
{
- if (TREE_CODE (gnu_inner_type) == INTEGER_TYPE)
+ Entity_Id gnat_index;
+ tree gnu_inner;
+
+ /* First finish the type we had been making so that we output
+ debugging information for it. */
+ if (Treat_As_Volatile (gnat_entity))
+ gnu_type
+ = build_qualified_type (gnu_type,
+ TYPE_QUALS (gnu_type)
+ | TYPE_QUAL_VOLATILE);
+
+ /* Make it artificial only if the base type was artificial too.
+ 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
+ = create_type_decl (gnu_entity_name, gnu_type, attr_list,
+ !Comes_From_Source (Etype (gnat_entity))
+ && !Comes_From_Source (gnat_entity),
+ 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_Type (gnat_entity),
+ NULL_TREE, 0);
+ this_made_decl = true;
+ gnu_type = TREE_TYPE (gnu_decl);
+ save_gnu_tree (gnat_entity, NULL_TREE, false);
+
+ gnu_inner = gnu_type;
+ while (TREE_CODE (gnu_inner) == RECORD_TYPE
+ && (TYPE_JUSTIFIED_MODULAR_P (gnu_inner)
+ || TYPE_PADDING_P (gnu_inner)))
+ gnu_inner = TREE_TYPE (TYPE_FIELDS (gnu_inner));
+
+ /* We need to attach the index type to the type we just made so
+ that the actual bounds can later be put into a template. */
+ if ((TREE_CODE (gnu_inner) == ARRAY_TYPE
+ && !TYPE_ACTUAL_BOUNDS (gnu_inner))
+ || (TREE_CODE (gnu_inner) == INTEGER_TYPE
+ && !TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner)))
{
- /* The TYPE_ACTUAL_BOUNDS field is also used for the modulus.
- If it is, we need to make another type. */
- if (TYPE_MODULAR_P (gnu_inner_type))
+ if (TREE_CODE (gnu_inner) == INTEGER_TYPE)
{
- tree gnu_subtype;
-
- gnu_subtype = make_node (INTEGER_TYPE);
-
- TREE_TYPE (gnu_subtype) = gnu_inner_type;
- TYPE_MIN_VALUE (gnu_subtype)
- = TYPE_MIN_VALUE (gnu_inner_type);
- TYPE_MAX_VALUE (gnu_subtype)
- = TYPE_MAX_VALUE (gnu_inner_type);
- TYPE_PRECISION (gnu_subtype)
- = TYPE_PRECISION (gnu_inner_type);
- TYPE_UNSIGNED (gnu_subtype)
- = TYPE_UNSIGNED (gnu_inner_type);
- TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
- layout_type (gnu_subtype);
-
- gnu_inner_type = gnu_subtype;
+ /* The TYPE_ACTUAL_BOUNDS field is overloaded with the
+ TYPE_MODULUS for modular types so we make an extra
+ subtype if necessary. */
+ if (TYPE_MODULAR_P (gnu_inner))
+ {
+ tree gnu_subtype
+ = make_unsigned_type (TYPE_PRECISION (gnu_inner));
+ TREE_TYPE (gnu_subtype) = gnu_inner;
+ TYPE_EXTRA_SUBTYPE_P (gnu_subtype) = 1;
+ SET_TYPE_RM_MIN_VALUE (gnu_subtype,
+ TYPE_MIN_VALUE (gnu_inner));
+ SET_TYPE_RM_MAX_VALUE (gnu_subtype,
+ TYPE_MAX_VALUE (gnu_inner));
+ gnu_inner = gnu_subtype;
+ }
+
+ TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner) = 1;
+
+#ifdef ENABLE_CHECKING
+ /* Check for other cases of overloading. */
+ gcc_assert (!TYPE_ACTUAL_BOUNDS (gnu_inner));
+#endif
}
- TYPE_HAS_ACTUAL_BOUNDS_P (gnu_inner_type) = 1;
+ for (gnat_index = First_Index (gnat_entity);
+ Present (gnat_index);
+ gnat_index = Next_Index (gnat_index))
+ SET_TYPE_ACTUAL_BOUNDS
+ (gnu_inner,
+ tree_cons (NULL_TREE,
+ get_unpadded_type (Etype (gnat_index)),
+ TYPE_ACTUAL_BOUNDS (gnu_inner)));
+
+ if (Convention (gnat_entity) != Convention_Fortran)
+ SET_TYPE_ACTUAL_BOUNDS
+ (gnu_inner, nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner)));
+
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
+ TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
}
-
- SET_TYPE_ACTUAL_BOUNDS (gnu_inner_type, NULL_TREE);
-
- for (gnat_index = First_Index (gnat_entity);
- Present (gnat_index); gnat_index = Next_Index (gnat_index))
- SET_TYPE_ACTUAL_BOUNDS
- (gnu_inner_type,
- tree_cons (NULL_TREE,
- get_unpadded_type (Etype (gnat_index)),
- TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
-
- if (Convention (gnat_entity) != Convention_Fortran)
- SET_TYPE_ACTUAL_BOUNDS
- (gnu_inner_type,
- nreverse (TYPE_ACTUAL_BOUNDS (gnu_inner_type)));
-
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_type))
- TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner_type;
}
- }
-
- /* Abort if packed array with no packed array type field set. */
- else
- gcc_assert (!Is_Packed (gnat_entity));
+ else
+ /* Abort if packed array with no Packed_Array_Type field set. */
+ gcc_assert (!Is_Packed (gnat_entity));
+ }
break;
case E_String_Literal_Subtype:
= build_binary_op (PLUS_EXPR, gnu_string_index_type,
gnu_lower_bound,
convert (gnu_string_index_type, gnu_length));
- tree gnu_range_type
- = build_range_type (gnu_string_index_type,
- gnu_lower_bound, gnu_upper_bound);
tree gnu_index_type
- = create_index_type (convert (sizetype,
- TYPE_MIN_VALUE (gnu_range_type)),
- convert (sizetype,
- TYPE_MAX_VALUE (gnu_range_type)),
- gnu_range_type, gnat_entity);
+ = create_index_type (convert (sizetype, gnu_lower_bound),
+ convert (sizetype, gnu_upper_bound),
+ create_range_type (gnu_string_index_type,
+ gnu_lower_bound,
+ gnu_upper_bound),
+ gnat_entity);
gnu_type
= build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
gnu_index_type);
- if (array_type_has_nonaliased_component (gnat_entity, gnu_type))
+ if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
}
Node_Id full_definition = Declaration_Node (gnat_entity);
Node_Id record_definition = Type_Definition (full_definition);
Entity_Id gnat_field;
- tree gnu_field;
- tree gnu_field_list = NULL_TREE;
- tree gnu_get_parent;
+ tree gnu_field, gnu_field_list = NULL_TREE, gnu_get_parent;
/* Set PACKED in keeping with gnat_to_gnu_field. */
int packed
= Is_Packed (gnat_entity)
&& Known_Static_Esize (gnat_entity)))
? -2
: 0;
+ bool has_discr = Has_Discriminants (gnat_entity);
bool has_rep = Has_Specified_Layout (gnat_entity);
bool all_rep = has_rep;
bool is_extension
= (Is_Tagged_Type (gnat_entity)
&& Nkind (record_definition) == N_Derived_Type_Definition);
+ bool is_unchecked_union = Is_Unchecked_Union (gnat_entity);
/* See if all fields have a rep clause. Stop when we find one
that doesn't. */
- for (gnat_field = First_Entity (gnat_entity);
- Present (gnat_field) && all_rep;
- gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Component
- || Ekind (gnat_field) == E_Discriminant)
- && No (Component_Clause (gnat_field)))
- all_rep = false;
+ if (all_rep)
+ 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)
+ && No (Component_Clause (gnat_field)))
+ {
+ all_rep = false;
+ break;
+ }
/* If this is a record extension, go a level further to find the
record definition. Also, verify we have a Parent_Subtype. */
/* Make a node for the record. If we are not defining the record,
suppress expanding incomplete types. */
gnu_type = make_node (tree_code_for_record_type (gnat_entity));
- TYPE_NAME (gnu_type) = gnu_entity_id;
+ TYPE_NAME (gnu_type) = gnu_entity_name;
TYPE_PACKED (gnu_type) = (packed != 0) || has_rep;
if (!definition)
- defer_incomplete_level++, this_deferred = true;
+ {
+ defer_incomplete_level++;
+ this_deferred = true;
+ }
/* If both a size and rep clause was specified, put the size in
the record type now so that it can get the proper mode. */
base type of the parent subtype. */
gnu_get_parent = build3 (COMPONENT_REF, void_type_node,
build0 (PLACEHOLDER_EXPR, gnu_type),
- build_decl (FIELD_DECL, NULL_TREE,
+ build_decl (input_location,
+ FIELD_DECL, NULL_TREE,
void_type_node),
NULL_TREE);
- if (Has_Discriminants (gnat_entity))
+ if (has_discr)
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
if (Present (Corresponding_Discriminant (gnat_field)))
- save_gnu_tree
- (gnat_field,
- build3 (COMPONENT_REF,
- get_unpadded_type (Etype (gnat_field)),
- gnu_get_parent,
- gnat_to_gnu_field_decl (Corresponding_Discriminant
- (gnat_field)),
- NULL_TREE),
- true);
-
- /* Then we build the parent subtype. */
- gnu_parent = gnat_to_gnu_type (gnat_parent);
+ {
+ tree gnu_field
+ = gnat_to_gnu_field_decl (Corresponding_Discriminant
+ (gnat_field));
+ save_gnu_tree
+ (gnat_field,
+ build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
+ gnu_get_parent, gnu_field, NULL_TREE),
+ true);
+ }
+
+ /* Then we build the parent subtype. If it has discriminants but
+ the type itself has unknown discriminants, this means that it
+ doesn't contain information about how the discriminants are
+ derived from those of the ancestor type, so it cannot be used
+ directly. Instead it is built by cloning the parent subtype
+ of the underlying record view of the type, for which the above
+ derivation of discriminants has been made explicit. */
+ if (Has_Discriminants (gnat_parent)
+ && Has_Unknown_Discriminants (gnat_entity))
+ {
+ Entity_Id gnat_uview = Underlying_Record_View (gnat_entity);
+
+ /* If we are defining the type, the underlying record
+ view must already have been elaborated at this point.
+ Otherwise do it now as its parent subtype cannot be
+ technically elaborated on its own. */
+ if (definition)
+ gcc_assert (present_gnu_tree (gnat_uview));
+ else
+ gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
+
+ gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
+
+ /* Substitute the "get to the parent" of the type for that
+ of its underlying record view in the cloned type. */
+ for (gnat_field = First_Stored_Discriminant (gnat_uview);
+ Present (gnat_field);
+ gnat_field = Next_Stored_Discriminant (gnat_field))
+ if (Present (Corresponding_Discriminant (gnat_field)))
+ {
+ tree gnu_field = gnat_to_gnu_field_decl (gnat_field);
+ tree gnu_ref
+ = build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
+ gnu_get_parent, gnu_field, NULL_TREE);
+ gnu_parent
+ = substitute_in_type (gnu_parent, gnu_field, gnu_ref);
+ }
+ }
+ else
+ gnu_parent = gnat_to_gnu_type (gnat_parent);
/* Finally we fix up both kinds of twisted COMPONENT_REF we have
initially built. The discriminants must reference the fields
of the parent subtype and not those of its base type for the
placeholder machinery to properly work. */
- if (Has_Discriminants (gnat_entity))
- for (gnat_field = First_Stored_Discriminant (gnat_entity);
- Present (gnat_field);
- gnat_field = Next_Stored_Discriminant (gnat_field))
- if (Present (Corresponding_Discriminant (gnat_field)))
+ if (has_discr)
+ {
+ /* The actual parent subtype is the full view. */
+ if (IN (Ekind (gnat_parent), Private_Kind))
{
- Entity_Id field = Empty;
- for (field = First_Stored_Discriminant (gnat_parent);
- Present (field);
- field = Next_Stored_Discriminant (field))
- if (same_discriminant_p (gnat_field, field))
- break;
- gcc_assert (Present (field));
- TREE_OPERAND (get_gnu_tree (gnat_field), 1)
- = gnat_to_gnu_field_decl (field);
+ if (Present (Full_View (gnat_parent)))
+ gnat_parent = Full_View (gnat_parent);
+ else
+ gnat_parent = Underlying_Full_View (gnat_parent);
}
+ for (gnat_field = First_Stored_Discriminant (gnat_entity);
+ Present (gnat_field);
+ gnat_field = Next_Stored_Discriminant (gnat_field))
+ if (Present (Corresponding_Discriminant (gnat_field)))
+ {
+ Entity_Id field = Empty;
+ for (field = First_Stored_Discriminant (gnat_parent);
+ Present (field);
+ field = Next_Stored_Discriminant (field))
+ if (same_discriminant_p (gnat_field, field))
+ break;
+ gcc_assert (Present (field));
+ TREE_OPERAND (get_gnu_tree (gnat_field), 1)
+ = gnat_to_gnu_field_decl (field);
+ }
+ }
+
/* The "get to the parent" COMPONENT_REF must be given its
proper type... */
TREE_TYPE (gnu_get_parent) = gnu_parent;
- /* ...and reference the _parent field of this record. */
- gnu_field_list
+ /* ...and reference the _Parent field of this record. */
+ gnu_field
= create_field_decl (get_identifier
(Get_Name_String (Name_uParent)),
gnu_parent, gnu_type, 0,
- has_rep ? TYPE_SIZE (gnu_parent) : 0,
- has_rep ? bitsize_zero_node : 0, 1);
- DECL_INTERNAL_P (gnu_field_list) = 1;
- TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
+ has_rep
+ ? TYPE_SIZE (gnu_parent) : NULL_TREE,
+ has_rep
+ ? bitsize_zero_node : NULL_TREE, 1);
+ DECL_INTERNAL_P (gnu_field) = 1;
+ TREE_OPERAND (gnu_get_parent, 1) = gnu_field;
+ TYPE_FIELDS (gnu_type) = gnu_field;
}
/* Make the fields for the discriminants and put them into the record
unless it's an Unchecked_Union. */
- if (Has_Discriminants (gnat_entity))
+ if (has_discr)
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
{
- /* If this is a record extension and this discriminant
- is the renaming of another discriminant, we've already
- handled the discriminant above. */
+ /* 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))
&& Present (Corresponding_Discriminant (gnat_field)))
continue;
gnu_field
- = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition);
+ = gnat_to_gnu_field (gnat_field, gnu_type, packed, definition,
+ debug_info_p);
/* Make an expression using a PLACEHOLDER_EXPR from the
FIELD_DECL node just created and link that with the
- corresponding GNAT defining identifier. Then add to the
- list of fields. */
+ corresponding GNAT defining identifier. */
save_gnu_tree (gnat_field,
build3 (COMPONENT_REF, TREE_TYPE (gnu_field),
- build0 (PLACEHOLDER_EXPR,
- DECL_CONTEXT (gnu_field)),
+ build0 (PLACEHOLDER_EXPR, gnu_type),
gnu_field, NULL_TREE),
true);
- if (!Is_Unchecked_Union (gnat_entity))
+ if (!is_unchecked_union)
{
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
}
- /* Put the discriminants into the record (backwards), so we can
- know the appropriate discriminant to use for the names of the
- variants. */
- TYPE_FIELDS (gnu_type) = gnu_field_list;
-
- /* Add the listed fields into the record and finish it up. */
+ /* 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, NULL,
- false, all_rep, false,
- Is_Unchecked_Union (gnat_entity));
+ false, all_rep, is_unchecked_union,
+ debug_info_p, false);
- /* We used to remove the associations of the discriminants and
- _Parent for validity checking, but we may need them if there's
- Freeze_Node for a subtype used in this record. */
- TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
- TYPE_BY_REFERENCE_P (gnu_type) = Is_By_Reference_Type (gnat_entity);
-
- /* If it is a tagged record force the type to BLKmode to insure
- that these objects will always be placed in memory. Do the
- same thing for limited record types. */
+ /* If it is a tagged record force the type to BLKmode to insure that
+ these objects will always be put in memory. Likewise for limited
+ record types. */
if (Is_Tagged_Type (gnat_entity) || Is_Limited_Record (gnat_entity))
SET_TYPE_MODE (gnu_type, BLKmode);
+ /* We used to remove the associations of the discriminants and _Parent
+ for validity checking but we may need them if there's a Freeze_Node
+ for a subtype used in this record. */
+ TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
+
/* 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. */
+ /* 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))
+ 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))
/* ... fall through ... */
case E_Record_Subtype:
-
/* If Cloned_Subtype is Present it means this record subtype has
identical layout to that type or subtype and we should use
that GCC type for this one. The front end guarantees that
gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
NULL_TREE, 0);
maybe_present = true;
+ break;
}
/* Otherwise, first ensure the base type is elaborated. Then, if we are
- changing the type, make a new type with each field having the
- type of the field in the new subtype but having the position
- computed by transforming every discriminant reference according
- to the constraints. We don't see any difference between
- private and nonprivate type here since derivations from types should
- have been deferred until the completion of the private type. */
+ changing the type, make a new type with each field having the type of
+ the field in the new subtype but the position computed by transforming
+ every discriminant reference according to the constraints. We don't
+ see any difference between private and non-private type here since
+ derivations from types should have been deferred until the completion
+ of the private type. */
else
{
Entity_Id gnat_base_type = Implementation_Base_Type (gnat_entity);
tree gnu_base_type;
- tree gnu_orig_type;
if (!definition)
- defer_incomplete_level++, this_deferred = true;
+ {
+ defer_incomplete_level++;
+ this_deferred = true;
+ }
- /* Get the base type initially for its alignment and sizes. But
- if it is a padded type, we do all the other work with the
- unpadded type. */
gnu_base_type = gnat_to_gnu_type (gnat_base_type);
- if (TREE_CODE (gnu_base_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_base_type))
- gnu_type = gnu_orig_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
- else
- gnu_type = gnu_orig_type = gnu_base_type;
-
if (present_gnu_tree (gnat_entity))
{
maybe_present = true;
break;
}
- /* When the type has discriminants, and these discriminants
- affect the shape of what it built, factor them in.
-
- If we are making a subtype of an Unchecked_Union (must be an
- Itype), just return the type.
-
- We can't just use Is_Constrained because private subtypes without
- discriminants of full types with discriminants with default
- expressions are Is_Constrained but aren't constrained! */
-
+ /* 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_For_Access_Subtype (gnat_entity)
&& !Is_Unchecked_Union (gnat_base_type)
+ && !Is_For_Access_Subtype (gnat_entity)
&& Is_Constrained (gnat_entity)
- && Stored_Constraint (gnat_entity) != No_Elist
- && Present (Discriminant_Constraint (gnat_entity)))
+ && Has_Discriminants (gnat_entity)
+ && Present (Discriminant_Constraint (gnat_entity))
+ && Stored_Constraint (gnat_entity) != No_Elist)
{
- Entity_Id gnat_field;
- tree gnu_field_list = 0;
- tree gnu_pos_list
- = compute_field_positions (gnu_orig_type, NULL_TREE,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
tree gnu_subst_list
- = substitution_list (gnat_entity, gnat_base_type, NULL_TREE,
- definition);
- tree gnu_temp;
+ = build_subst_list (gnat_entity, gnat_base_type, definition);
+ tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
+ tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
+ bool selected_variant = false;
+ Entity_Id gnat_field;
gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = gnu_entity_id;
- TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
+ TYPE_NAME (gnu_type) = gnu_entity_name;
/* Set the size, alignment and alias set of the new type to
- match that of the old one, doing required substitutions.
- We do it this early because we need the size of the new
- type below to discard old fields if necessary. */
- TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_base_type);
- TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_base_type);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_ADA_SIZE (gnu_base_type));
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_base_type);
- relate_alias_sets (gnu_type, gnu_base_type, ALIAS_SET_COPY);
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- TYPE_SIZE (gnu_type)
- = substitute_in_expr (TYPE_SIZE (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- TYPE_SIZE_UNIT (gnu_type)
- = substitute_in_expr (TYPE_SIZE_UNIT (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (gnu_type)))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- SET_TYPE_ADA_SIZE
- (gnu_type, substitute_in_expr (TYPE_ADA_SIZE (gnu_type),
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp)));
+ match that of the old one, doing required substitutions. */
+ copy_and_substitute_in_size (gnu_type, gnu_base_type,
+ gnu_subst_list);
+
+ if (TYPE_IS_PADDING_P (gnu_base_type))
+ gnu_unpad_base_type = TREE_TYPE (TYPE_FIELDS (gnu_base_type));
+ else
+ gnu_unpad_base_type = gnu_base_type;
+
+ /* Look for a REP part in the base type. */
+ gnu_rep_part = get_rep_part (gnu_unpad_base_type);
+
+ /* Look for a variant part in the 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)
+ {
+ gnu_variant_list
+ = build_variant_list (TREE_TYPE (gnu_variant_part),
+ gnu_subst_list, NULL_TREE);
+
+ /* If all the qualifiers are unconditionally true, the
+ innermost variant is statically selected. */
+ selected_variant = true;
+ for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+ if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
+ {
+ selected_variant = false;
+ break;
+ }
+
+ /* Otherwise, create the new variants. */
+ if (!selected_variant)
+ for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+ {
+ tree old_variant = TREE_PURPOSE (t);
+ tree new_variant = make_node (RECORD_TYPE);
+ TYPE_NAME (new_variant)
+ = DECL_NAME (TYPE_NAME (old_variant));
+ copy_and_substitute_in_size (new_variant, old_variant,
+ gnu_subst_list);
+ TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
+ }
+ }
+ else
+ {
+ gnu_variant_list = NULL_TREE;
+ selected_variant = false;
+ }
+
+ gnu_pos_list
+ = build_position_list (gnu_unpad_base_type,
+ gnu_variant_list && !selected_variant,
+ size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, NULL_TREE);
for (gnat_field = First_Entity (gnat_entity);
- Present (gnat_field); gnat_field = Next_Entity (gnat_field))
+ Present (gnat_field);
+ gnat_field = Next_Entity (gnat_field))
if ((Ekind (gnat_field) == E_Component
|| Ekind (gnat_field) == E_Discriminant)
- && (Underlying_Type (Scope (Original_Record_Component
- (gnat_field)))
- == gnat_base_type)
- && (No (Corresponding_Discriminant (gnat_field))
- || !Is_Tagged_Type (gnat_base_type)))
+ && !(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 (Original_Record_Component
- (gnat_field));
- tree gnu_offset
- = TREE_VALUE (purpose_member (gnu_old_field,
- gnu_pos_list));
- tree gnu_pos = TREE_PURPOSE (gnu_offset);
- tree gnu_bitpos = TREE_VALUE (TREE_VALUE (gnu_offset));
- tree gnu_field_type
- = gnat_to_gnu_type (Etype (gnat_field));
- tree gnu_size = TYPE_SIZE (gnu_field_type);
- tree gnu_new_pos = NULL_TREE;
- unsigned int offset_align
- = tree_low_cst (TREE_PURPOSE (TREE_VALUE (gnu_offset)),
- 1);
- tree gnu_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;
+ 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
- (Original_Record_Component (gnat_field)))
+ 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))
{
gnu_size = DECL_SIZE (gnu_old_field);
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && !TYPE_IS_FAT_POINTER_P (gnu_field_type)
+ && !TYPE_FAT_POINTER_P (gnu_field_type)
&& host_integerp (TYPE_SIZE (gnu_field_type), 1))
gnu_field_type
= make_packable_type (gnu_field_type, true);
}
- if (CONTAINS_PLACEHOLDER_P (gnu_pos))
- for (gnu_temp = gnu_subst_list;
- gnu_temp; gnu_temp = TREE_CHAIN (gnu_temp))
- gnu_pos = substitute_in_expr (gnu_pos,
- TREE_PURPOSE (gnu_temp),
- TREE_VALUE (gnu_temp));
-
- /* If the position is now a constant, we can set it as the
- position of the field when we make it. Otherwise, we need
- to deal with it specially below. */
- if (TREE_CONSTANT (gnu_pos))
+ 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
{
- gnu_new_pos = bit_from_pos (gnu_pos, gnu_bitpos);
-
- /* Discard old fields that are outside the new type.
- This avoids confusing code scanning it to decide
- how to pass it to functions on some platforms. */
- if (TREE_CODE (gnu_new_pos) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST
- && !integer_zerop (gnu_size)
- && !tree_int_cst_lt (gnu_new_pos,
- TYPE_SIZE (gnu_type)))
+ t = purpose_member (gnu_context, gnu_variant_list);
+ if (t)
+ {
+ if (selected_variant)
+ gnu_cont_type = gnu_type;
+ else
+ gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ }
+ 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
- (DECL_NAME (gnu_old_field), gnu_field_type, gnu_type,
- DECL_PACKED (gnu_old_field), gnu_size, gnu_new_pos,
- !DECL_NONADDRESSABLE_P (gnu_old_field));
+ = create_field_decl_from (gnu_old_field, gnu_field_type,
+ gnu_cont_type, gnu_size,
+ gnu_pos_list, gnu_subst_list);
- if (!TREE_CONSTANT (gnu_pos))
+ /* Put it in one of the new variants directly. */
+ if (gnu_cont_type != gnu_type)
{
- normalize_offset (&gnu_pos, &gnu_bitpos, offset_align);
- DECL_FIELD_OFFSET (gnu_field) = gnu_pos;
- DECL_FIELD_BIT_OFFSET (gnu_field) = gnu_bitpos;
- SET_DECL_OFFSET_ALIGN (gnu_field, offset_align);
- DECL_SIZE (gnu_field) = gnu_size;
- DECL_SIZE_UNIT (gnu_field)
- = convert (sizetype,
- size_binop (CEIL_DIV_EXPR, gnu_size,
- bitsize_unit_node));
- layout_decl (gnu_field, DECL_OFFSET_ALIGN (gnu_field));
+ TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+ TYPE_FIELDS (gnu_cont_type) = gnu_field;
}
- DECL_INTERNAL_P (gnu_field)
- = DECL_INTERNAL_P (gnu_old_field);
- SET_DECL_ORIGINAL_FIELD
- (gnu_field, (DECL_ORIGINAL_FIELD (gnu_old_field)
- ? DECL_ORIGINAL_FIELD (gnu_old_field)
- : gnu_old_field));
- DECL_DISCRIMINANT_NUMBER (gnu_field)
- = DECL_DISCRIMINANT_NUMBER (gnu_old_field);
- TREE_THIS_VOLATILE (gnu_field)
- = TREE_THIS_VOLATILE (gnu_old_field);
-
- /* To match the layout crafted in components_to_record, if
- this is the _Tag field, put it before any discriminants
- instead of after them as for all other fields. */
- if (Chars (gnat_field) == Name_uTag)
+ /* 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)
+ {
+ TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
+ TREE_CHAIN (gnu_last) = gnu_field;
+ }
+
+ /* Otherwise, if this is a regular field, put it after
+ the other fields. */
else
{
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
+ if (!gnu_last)
+ gnu_last = gnu_field;
}
save_gnu_tree (gnat_field, gnu_field, false);
}
+ /* 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 && !selected_variant)
+ {
+ tree new_variant_part
+ = create_variant_part_from (gnu_variant_part,
+ gnu_variant_list, gnu_type,
+ gnu_pos_list, gnu_subst_list);
+ TREE_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). */
&& !present_gnu_tree (Etype (gnat_field)))
gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
- /* Do not finalize it since we're going to modify it below. */
+ /* Do not emit debug info for the type yet since we're going to
+ modify it below. */
gnu_field_list = nreverse (gnu_field_list);
- finish_record_type (gnu_type, gnu_field_list, 2, true);
+ finish_record_type (gnu_type, gnu_field_list, 2, false);
- /* Finalize size and mode. */
- TYPE_SIZE (gnu_type) = variable_size (TYPE_SIZE (gnu_type));
- TYPE_SIZE_UNIT (gnu_type)
- = variable_size (TYPE_SIZE_UNIT (gnu_type));
+ /* See the E_Record_Type case for the rationale. */
+ if (Is_Tagged_Type (gnat_entity)
+ || Is_Limited_Record (gnat_entity))
+ SET_TYPE_MODE (gnu_type, BLKmode);
+ else
+ compute_record_mode (gnu_type);
- compute_record_mode (gnu_type);
+ TYPE_VOLATILE (gnu_type) = Treat_As_Volatile (gnat_entity);
/* Fill in locations of fields. */
annotate_rep (gnat_entity, gnu_type);
- /* We've built a new type, make an XVS type to show what this
- is a subtype of. Some debuggers require the XVS type to be
- output first, so do it in that order. */
+ /* If debugging information is being written for the type, write
+ a record that shows what we are a subtype of and also make a
+ variable that indicates our size, if still variable. */
if (debug_info_p)
{
tree gnu_subtype_marker = make_node (RECORD_TYPE);
- tree gnu_orig_name = TYPE_NAME (gnu_orig_type);
+ tree gnu_unpad_base_name = TYPE_NAME (gnu_unpad_base_type);
+ tree gnu_size_unit = TYPE_SIZE_UNIT (gnu_type);
- if (TREE_CODE (gnu_orig_name) == TYPE_DECL)
- gnu_orig_name = DECL_NAME (gnu_orig_name);
+ if (TREE_CODE (gnu_unpad_base_name) == TYPE_DECL)
+ gnu_unpad_base_name = DECL_NAME (gnu_unpad_base_name);
TYPE_NAME (gnu_subtype_marker)
= create_concat_name (gnat_entity, "XVS");
finish_record_type (gnu_subtype_marker,
- create_field_decl (gnu_orig_name,
- integer_type_node,
+ create_field_decl (gnu_unpad_base_name,
+ build_reference_type
+ (gnu_unpad_base_type),
gnu_subtype_marker,
0, NULL_TREE,
NULL_TREE, 0),
- 0, false);
+ 0, true);
add_parallel_type (TYPE_STUB_DECL (gnu_type),
gnu_subtype_marker);
+
+ if (definition
+ && TREE_CODE (gnu_size_unit) != INTEGER_CST
+ && !CONTAINS_PLACEHOLDER_P (gnu_size_unit))
+ create_var_decl (create_concat_name (gnat_entity, "XVZ"),
+ NULL_TREE, sizetype, gnu_size_unit, false,
+ false, false, false, NULL, gnat_entity);
}
/* Now we can finalize it. */
rest_of_record_type_compilation (gnu_type);
}
- /* Otherwise, go down all the components in the new type and
- make them equivalent to those in the base type. */
+ /* Otherwise, go down all the components in the new type and make
+ them equivalent to those in the base type. */
else
- for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
- gnat_temp = Next_Entity (gnat_temp))
- if ((Ekind (gnat_temp) == E_Discriminant
- && !Is_Unchecked_Union (gnat_base_type))
- || Ekind (gnat_temp) == E_Component)
- save_gnu_tree (gnat_temp,
- gnat_to_gnu_field_decl
- (Original_Record_Component (gnat_temp)), false);
+ {
+ gnu_type = gnu_base_type;
+
+ for (gnat_temp = First_Entity (gnat_entity);
+ Present (gnat_temp);
+ gnat_temp = Next_Entity (gnat_temp))
+ if ((Ekind (gnat_temp) == E_Discriminant
+ && !Is_Unchecked_Union (gnat_base_type))
+ || Ekind (gnat_temp) == E_Component)
+ save_gnu_tree (gnat_temp,
+ gnat_to_gnu_field_decl
+ (Original_Record_Component (gnat_temp)),
+ false);
+ }
}
break;
gnu_type
= build_pointer_type
(make_dummy_type (Directly_Designated_Type (gnat_entity)));
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
this_made_decl = true;
&& ! present_gnu_tree (gnat_desig_equiv))
|| (in_main_unit && is_from_limited_with
&& Present (Freeze_Node (gnat_desig_rep)))))
- {
- tree gnu_old
- = (present_gnu_tree (gnat_desig_rep)
- ? TREE_TYPE (get_gnu_tree (gnat_desig_rep))
- : make_dummy_type (gnat_desig_rep));
- tree fields;
+ {
+ tree gnu_old;
+
+ if (present_gnu_tree (gnat_desig_rep))
+ gnu_old = TREE_TYPE (get_gnu_tree (gnat_desig_rep));
+ else
+ {
+ gnu_old = make_dummy_type (gnat_desig_rep);
- /* Show the dummy we get will be a fat pointer. */
- got_fat_p = made_dummy = true;
+ /* Show the dummy we get will be a fat pointer. */
+ got_fat_p = made_dummy = true;
+ }
/* If the call above got something that has a pointer, that
pointer is our type. This could have happened either
tree gnu_ptr_template = build_pointer_type (gnu_template_type);
tree gnu_array_type = make_node (ENUMERAL_TYPE);
tree gnu_ptr_array = build_pointer_type (gnu_array_type);
+ tree fields;
TYPE_NAME (gnu_template_type)
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUB");
+ = create_concat_name (gnat_desig_equiv, "XUB");
TYPE_DUMMY_P (gnu_template_type) = 1;
TYPE_NAME (gnu_array_type)
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUA");
+ = create_concat_name (gnat_desig_equiv, "XUA");
TYPE_DUMMY_P (gnu_array_type) = 1;
gnu_type = make_node (RECORD_TYPE);
/* Make sure we can place this into a register. */
TYPE_ALIGN (gnu_type)
= MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
- TYPE_IS_FAT_POINTER_P (gnu_type) = 1;
+ TYPE_FAT_POINTER_P (gnu_type) = 1;
- /* Do not finalize this record type since the types of
- its fields are incomplete. */
- finish_record_type (gnu_type, fields, 0, true);
+ /* Do not emit debug info for this record type since the types
+ of its fields are incomplete. */
+ finish_record_type (gnu_type, fields, 0, false);
TYPE_OBJECT_RECORD_TYPE (gnu_old) = make_node (RECORD_TYPE);
TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_old))
- = concat_id_with_name (get_entity_name (gnat_desig_equiv),
- "XUT");
+ = create_concat_name (gnat_desig_equiv, "XUT");
TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_old)) = 1;
}
}
if ((! in_main_unit || is_from_limited_with) && made_dummy)
{
tree gnu_old_type
- = TYPE_FAT_POINTER_P (gnu_type)
+ = TYPE_IS_FAT_POINTER_P (gnu_type)
? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
if (esize == POINTER_SIZE
- && (got_fat_p || TYPE_FAT_POINTER_P (gnu_type)))
+ && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
gnu_type
= build_pointer_type
(TYPE_OBJECT_RECORD_TYPE
(TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
this_made_decl = true;
tree gnu_field_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
+ 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_return_list = NULL_TREE;
+ tree gnu_cico_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;
&& Is_Pure (gnat_entity));
bool volatile_flag = No_Return (gnat_entity);
- bool returns_by_ref = false;
- bool returns_unconstrained = false;
- bool returns_by_target_ptr = false;
+ bool return_by_direct_ref_p = false;
+ bool return_by_invisi_ref_p = false;
+ bool return_unconstrained_p = false;
bool has_copy_in_out = false;
bool has_stub = false;
int parmnum;
+ /* A parameter may refer to this type, so defer completion of any
+ incomplete types. */
if (kind == E_Subprogram_Type && !definition)
- /* A parameter may refer to this type, so defer completion
- of any incomplete types. */
- defer_incomplete_level++, this_deferred = true;
+ {
+ defer_incomplete_level++;
+ this_deferred = true;
+ }
/* If the subprogram has an alias, it is probably inherited, so
we can use the original one. If the original "subprogram"
if (kind == E_Function || kind == E_Subprogram_Type)
gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
- /* If this function returns by reference, make the actual
- return type of this function the pointer and mark the decl. */
+ /* If this function returns by reference, make the actual return
+ type of this function the pointer and mark the decl. */
if (Returns_By_Ref (gnat_entity))
{
- returns_by_ref = true;
gnu_return_type = build_pointer_type (gnu_return_type);
+ return_by_direct_ref_p = true;
}
- /* If the Mechanism is By_Reference, ensure the return type uses
- the machine's by-reference mechanism, which may not the same
- as above (e.g., it might be by passing a fake parameter). */
- else if (kind == E_Function
- && Mechanism (gnat_entity) == By_Reference)
- {
- TREE_ADDRESSABLE (gnu_return_type) = 1;
-
- /* We expect this bit to be reset by gigi shortly, so can avoid a
- type node copy here. This actually also prevents troubles with
- the generation of debug information for the function, because
- we might have issued such info for this type already, and would
- be attaching a distinct type node to the function if we made a
- copy here. */
- }
-
- /* If we are supposed to return an unconstrained array,
- actually return a fat pointer and make a note of that. Return
- a pointer to an unconstrained record of variable size. */
+ /* 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).
+
+ Prior to GCC 4, this was handled by just setting TREE_ADDRESSABLE
+ on the result type. Everything required to pass by invisible
+ reference using the target's mechanism (e.g. an extra parameter)
+ was handled at RTL expansion time.
+
+ This doesn't work with GCC 4 any more for several reasons. First,
+ the gimplification process might need to create temporaries of this
+ type and the gimplifier ICEs on such attempts; that's why the flag
+ is now set on the function type instead. Second, the middle-end
+ now also relies on a different attribute, DECL_BY_REFERENCE on the
+ RESULT_DECL, and expects the by-invisible-reference-ness to be made
+ explicit in the function body. */
+ else if (kind == E_Function && Mechanism (gnat_entity) == By_Reference)
+ return_by_invisi_ref_p = true;
+
+ /* If we are supposed to return an unconstrained array, actually return
+ a fat pointer and make a note of that. */
else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
{
gnu_return_type = TREE_TYPE (gnu_return_type);
- returns_unconstrained = true;
+ return_unconstrained_p = true;
}
/* If the type requires a transient scope, the result is allocated
else if (Requires_Transient_Scope (Etype (gnat_entity)))
{
gnu_return_type = build_pointer_type (gnu_return_type);
- returns_unconstrained = true;
+ return_unconstrained_p = true;
}
/* If the type is a padded type and the underlying type would not
be passed by reference or this function has a foreign convention,
return the underlying type. */
- else if (TREE_CODE (gnu_return_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_return_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 has a non-constant size, we convert the function
- into a procedure and its caller will pass a pointer to an object as
- the first parameter when we call the function. This can happen for
- an unconstrained type with a maximum size or a constrained type with
- a size not known at compile time. */
- if (TYPE_SIZE_UNIT (gnu_return_type)
- && !TREE_CONSTANT (TYPE_SIZE_UNIT (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)))
{
- returns_by_target_ptr = true;
- gnu_param_list
- = create_param_decl (get_identifier ("TARGET"),
- build_reference_type (gnu_return_type),
- true);
- gnu_return_type = void_type_node;
+ gnu_return_type
+ = maybe_pad_type (gnu_return_type,
+ max_size (TYPE_SIZE (gnu_return_type), true),
+ 0, gnat_entity, false, false, false, true);
+ return_by_invisi_ref_p = true;
}
/* If the return type has a size that overflows, we cannot have
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_FAT_POINTER_P (gnu_param_type))
+ || TYPE_IS_FAT_POINTER_P (gnu_param_type))
const_flag = false;
}
gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
gnu_return_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
+ /* Set a default alignment to speed up accesses. */
+ TYPE_ALIGN (gnu_return_type)
+ = get_mode_alignment (ptr_mode);
has_copy_in_out = true;
}
&DECL_SOURCE_LOCATION (gnu_field));
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
- gnu_return_list = tree_cons (gnu_field, gnu_param,
- gnu_return_list);
+ gnu_cico_list
+ = tree_cons (gnu_field, gnu_param, gnu_cico_list);
}
}
stubbed since structures are incomplete for the back-end. */
if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
finish_record_type (gnu_return_type, nreverse (gnu_field_list),
- 0, false);
+ 0, debug_info_p);
/* If we have a CICO list but it has only one entry, we convert
this function into a function that simply returns that one
object. */
- if (list_length (gnu_return_list) == 1)
- gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
+ if (list_length (gnu_cico_list) == 1)
+ gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
if (Has_Stdcall_Convention (gnat_entity))
prepend_one_attribute_to
gnu_param_list = nreverse (gnu_param_list);
if (has_stub)
gnu_stub_param_list = nreverse (gnu_stub_param_list);
- gnu_return_list = nreverse (gnu_return_list);
+ gnu_cico_list = nreverse (gnu_cico_list);
if (Ekind (gnat_entity) == E_Function)
- Set_Mechanism (gnat_entity,
- (returns_by_ref || returns_unconstrained
- ? By_Reference : By_Copy));
+ 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_return_list, returns_unconstrained,
- returns_by_ref, returns_by_target_ptr);
+ gnu_cico_list, return_unconstrained_p,
+ return_by_direct_ref_p,
+ return_by_invisi_ref_p);
if (has_stub)
gnu_stub_type
= create_subprog_type (gnu_return_type, gnu_stub_param_list,
- gnu_return_list, returns_unconstrained,
- returns_by_ref, returns_by_target_ptr);
+ gnu_cico_list, return_unconstrained_p,
+ return_by_direct_ref_p,
+ return_by_invisi_ref_p);
/* A subprogram (something that doesn't return anything) shouldn't
be considered const since there would be no reason for such a
/* 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_id)
+ 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
gnu_address = convert (gnu_type, gnu_address);
gnu_decl
- = create_var_decl (gnu_entity_id, gnu_ext_name, gnu_type,
+ = create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_address, false, Is_Public (gnat_entity),
extern_flag, false, NULL, gnat_entity);
DECL_BY_REF_P (gnu_decl) = 1;
}
else if (kind == E_Subprogram_Type)
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
else
public_flag = false;
}
- gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
+ gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
gnu_type, gnu_param_list,
inline_flag, public_flag,
extern_flag, attr_list,
if (has_stub)
{
tree gnu_stub_decl
- = create_subprog_decl (gnu_entity_id, gnu_stub_name,
+ = create_subprog_decl (gnu_entity_name, gnu_stub_name,
gnu_stub_type, gnu_stub_param_list,
inline_flag, true,
extern_flag, attr_list,
break;
case E_Label:
- gnu_decl = create_label_decl (gnu_entity_id);
+ gnu_decl = create_label_decl (gnu_entity_name);
break;
case E_Block:
/* If we are processing a type and there is either no decl for it or
we just made one, do some common processing for the type, such as
handling alignment and possible padding. */
-
- if ((!gnu_decl || this_made_decl) && IN (kind, Type_Kind))
+ if (is_type && (!gnu_decl || this_made_decl))
{
if (Is_Tagged_Type (gnat_entity)
|| Is_Class_Wide_Equivalent_Type (gnat_entity))
else if ((TREE_CODE (gnu_type) == RECORD_TYPE
|| TREE_CODE (gnu_type) == UNION_TYPE
|| TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type))
+ && !TYPE_FAT_POINTER_P (gnu_type))
size = rm_size (gnu_type);
else
size = TYPE_SIZE (gnu_type);
us when we make the new TYPE_DECL below. */
if (gnu_size || align > 0)
gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- "PAD", true, definition, false);
+ false, !gnu_decl, definition, false);
- if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_type))
+ if (TYPE_IS_PADDING_P (gnu_type))
{
- gnu_entity_id = TYPE_NAME (gnu_type);
- if (TREE_CODE (gnu_entity_id) == TYPE_DECL)
- gnu_entity_id = DECL_NAME (gnu_entity_id);
+ gnu_entity_name = TYPE_NAME (gnu_type);
+ if (TREE_CODE (gnu_entity_name) == TYPE_DECL)
+ gnu_entity_name = DECL_NAME (gnu_entity_name);
}
set_rm_size (RM_Size (gnat_entity), gnu_type, gnat_entity);
TYPE_SIZE (gnu_type), 0))
{
TYPE_SIZE (gnu_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_type),
- get_identifier ("SIZE"),
- definition, 0);
+ = elaborate_expression_1 (TYPE_SIZE (gnu_type),
+ gnat_entity, get_identifier ("SIZE"),
+ definition, false);
SET_TYPE_ADA_SIZE (gnu_type, TYPE_SIZE (gnu_type));
}
else
{
TYPE_SIZE (gnu_type)
- = elaborate_expression_1 (gnat_entity, gnat_entity,
- TYPE_SIZE (gnu_type),
- get_identifier ("SIZE"),
- definition, 0);
+ = elaborate_expression_1 (TYPE_SIZE (gnu_type),
+ gnat_entity, get_identifier ("SIZE"),
+ definition, false);
/* ??? For now, store the size as a multiple of the alignment
in bytes so that we can see the alignment from the tree. */
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
- (gnat_entity, gnat_entity,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
+ (build_binary_op (EXACT_DIV_EXPR, sizetype,
TYPE_SIZE_UNIT (gnu_type),
size_int (TYPE_ALIGN (gnu_type)
/ BITS_PER_UNIT)),
- get_identifier ("SIZE_A_UNIT"),
- definition, 0),
+ gnat_entity, get_identifier ("SIZE_A_UNIT"),
+ definition, false),
size_int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
if (TREE_CODE (gnu_type) == RECORD_TYPE)
SET_TYPE_ADA_SIZE
(gnu_type,
- elaborate_expression_1 (gnat_entity,
+ elaborate_expression_1 (TYPE_ADA_SIZE (gnu_type),
gnat_entity,
- TYPE_ADA_SIZE (gnu_type),
get_identifier ("RM_SIZE"),
- definition, 0));
+ definition, false));
}
}
= build_binary_op
(MULT_EXPR, sizetype,
elaborate_expression_1
- (gnat_temp, gnat_temp,
- build_binary_op (EXACT_DIV_EXPR, sizetype,
+ (build_binary_op (EXACT_DIV_EXPR, sizetype,
DECL_FIELD_OFFSET (gnu_field),
size_int (DECL_OFFSET_ALIGN (gnu_field)
/ BITS_PER_UNIT)),
- get_identifier ("OFFSET"),
- definition, 0),
+ gnat_temp, get_identifier ("OFFSET"),
+ definition, false),
size_int (DECL_OFFSET_ALIGN (gnu_field) / BITS_PER_UNIT));
/* ??? 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));
}
}
- gnu_type = build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | (TYPE_QUAL_VOLATILE
- * Treat_As_Volatile (gnat_entity))));
+ if (Treat_As_Volatile (gnat_entity))
+ gnu_type
+ = build_qualified_type (gnu_type,
+ TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
if (Is_Atomic (gnat_entity))
check_ok_for_atomic (gnu_type, gnat_entity, false);
TYPE_UNIVERSAL_ALIASING_P (TYPE_MAIN_VARIANT (gnu_type)) = 1;
if (!gnu_decl)
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
else
- TREE_TYPE (gnu_decl) = gnu_type;
+ {
+ TREE_TYPE (gnu_decl) = gnu_type;
+ TYPE_STUB_DECL (gnu_type) = gnu_decl;
+ }
}
- if (IN (kind, Type_Kind) && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
+ if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
{
gnu_type = TREE_TYPE (gnu_decl);
superset superset
R ----------> D ----------> T
+ However, for composite types, conversions between derived types are
+ translated into VIEW_CONVERT_EXPRs so a sequence like:
+
+ type Comp1 is new Comp;
+ type Comp2 is new Comp;
+ procedure Proc (C : Comp1);
+
+ C : Comp2;
+ Proc (Comp1 (C));
+
+ is translated into:
+
+ C : Comp2;
+ Proc ((Comp1 &) &VIEW_CONVERT_EXPR <Comp1> (C));
+
+ and gimplified into:
+
+ C : Comp2;
+ Comp1 *C.0;
+ C.0 = (Comp1 *) &C;
+ Proc (C.0);
+
+ i.e. generates code involving type punning. Therefore, Comp1 needs
+ to conflict with Comp2 and an alias set copy is required.
+
The language rules ensure the parent type is already frozen here. */
if (Is_Derived_Type (gnat_entity))
{
tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_entity));
- relate_alias_sets (gnu_type, gnu_parent_type, ALIAS_SET_SUPERSET);
+ relate_alias_sets (gnu_type, gnu_parent_type,
+ Is_Composite_Type (gnat_entity)
+ ? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
}
/* Back-annotate the Alignment of the type if not already in the
tree. Likewise for sizes. */
if (Unknown_Alignment (gnat_entity))
- Set_Alignment (gnat_entity,
- UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
+ {
+ unsigned int double_align, align;
+ bool is_capped_double, align_clause;
+
+ /* If the default alignment of "double" or larger scalar types is
+ specifically capped and this is not an array with an alignment
+ clause on the component type, return the cap. */
+ if ((double_align = double_float_alignment) > 0)
+ is_capped_double
+ = is_double_float_or_array (gnat_entity, &align_clause);
+ else if ((double_align = double_scalar_alignment) > 0)
+ is_capped_double
+ = is_double_scalar_or_array (gnat_entity, &align_clause);
+ else
+ is_capped_double = align_clause = false;
+
+ if (is_capped_double && !align_clause)
+ align = double_align;
+ else
+ align = TYPE_ALIGN (gnu_type) / BITS_PER_UNIT;
+
+ Set_Alignment (gnat_entity, UI_From_Int (align));
+ }
if (Unknown_Esize (gnat_entity) && TYPE_SIZE (gnu_type))
{
if (!saved)
save_gnu_tree (gnat_entity, gnu_decl, false);
- /* If this is an enumeral or floating-point type, we were not able to set
- the bounds since they refer to the type. These bounds are always static.
-
- For enumeration types, also write debugging information and declare the
- enumeration literal table, if needed. */
-
+ /* If this is an enumeration or floating-point type, we were not able to set
+ the bounds since they refer to the type. These are always static. */
if ((kind == E_Enumeration_Type && Present (First_Literal (gnat_entity)))
|| (kind == E_Floating_Point_Type && !Vax_Float (gnat_entity)))
{
tree gnu_scalar_type = gnu_type;
+ tree gnu_low_bound, gnu_high_bound;
/* If this is a padded type, we need to use the underlying type. */
- if (TREE_CODE (gnu_scalar_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_scalar_type))
+ if (TYPE_IS_PADDING_P (gnu_scalar_type))
gnu_scalar_type = TREE_TYPE (TYPE_FIELDS (gnu_scalar_type));
/* If this is a floating point type and we haven't set a floating
point type yet, use this in the evaluation of the bounds. */
if (!longest_float_type_node && kind == E_Floating_Point_Type)
- longest_float_type_node = gnu_type;
+ longest_float_type_node = gnu_scalar_type;
- TYPE_MIN_VALUE (gnu_scalar_type)
- = gnat_to_gnu (Type_Low_Bound (gnat_entity));
- TYPE_MAX_VALUE (gnu_scalar_type)
- = gnat_to_gnu (Type_High_Bound (gnat_entity));
+ gnu_low_bound = gnat_to_gnu (Type_Low_Bound (gnat_entity));
+ gnu_high_bound = gnat_to_gnu (Type_High_Bound (gnat_entity));
- if (TREE_CODE (gnu_scalar_type) == ENUMERAL_TYPE)
+ if (kind == E_Enumeration_Type)
{
- /* Since this has both a typedef and a tag, avoid outputting
- the name twice. */
+ /* Enumeration types have specific RM bounds. */
+ SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
+ SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
+
+ /* Write full debugging information. Since this has both a
+ typedef and a tag, avoid outputting the name twice. */
DECL_ARTIFICIAL (gnu_decl) = 1;
rest_of_type_decl_compilation (gnu_decl);
}
+
+ else
+ {
+ /* Floating-point types don't have specific RM bounds. */
+ TYPE_GCC_MIN_VALUE (gnu_scalar_type) = gnu_low_bound;
+ TYPE_GCC_MAX_VALUE (gnu_scalar_type) = gnu_high_bound;
+ }
}
/* If we deferred processing of incomplete types, re-enable it. If there
if (this_global)
force_global--;
+ /* If this is a packed array type whose original array type is itself
+ an Itype without freeze node, make sure the latter is processed. */
if (Is_Packed_Array_Type (gnat_entity)
- && Is_Itype (Associated_Node_For_Itype (gnat_entity))
- && No (Freeze_Node (Associated_Node_For_Itype (gnat_entity)))
- && !present_gnu_tree (Associated_Node_For_Itype (gnat_entity)))
- gnat_to_gnu_entity (Associated_Node_For_Itype (gnat_entity), NULL_TREE, 0);
+ && 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);
return gnu_decl;
}
{
tree type = gnat_to_gnu_type (gnat_entity);
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ if (TYPE_IS_PADDING_P (type))
type = TREE_TYPE (TYPE_FIELDS (type));
return type;
break;
case E_Class_Wide_Type:
- gnat_equiv = ((Present (Equivalent_Type (gnat_entity)))
- ? Equivalent_Type (gnat_entity)
- : Root_Type (gnat_entity));
+ gnat_equiv = Root_Type (gnat_entity);
break;
case E_Task_Type:
return gnat_equiv;
}
+/* Return a GCC tree for a type corresponding to the component type of the
+ array type or subtype GNAT_ARRAY. DEFINITION is true if this component
+ is for an array being defined. DEBUG_INFO_P is true if we need to write
+ debug information for other types that we may create in the process. */
+
+static tree
+gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
+ bool debug_info_p)
+{
+ tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
+ tree gnu_comp_size;
+
+ /* Try to get a smaller form of the component if needed. */
+ if ((Is_Packed (gnat_array)
+ || Has_Component_Size_Clause (gnat_array))
+ && !Is_Bit_Packed_Array (gnat_array)
+ && !Has_Aliased_Components (gnat_array)
+ && !Strict_Alignment (Component_Type (gnat_array))
+ && TREE_CODE (gnu_type) == RECORD_TYPE
+ && !TYPE_FAT_POINTER_P (gnu_type)
+ && host_integerp (TYPE_SIZE (gnu_type), 1))
+ gnu_type = make_packable_type (gnu_type, false);
+
+ if (Has_Atomic_Components (gnat_array))
+ check_ok_for_atomic (gnu_type, gnat_array, true);
+
+ /* Get and validate any specified Component_Size. */
+ gnu_comp_size
+ = validate_size (Component_Size (gnat_array), gnu_type, gnat_array,
+ 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
+ && TREE_CODE (gnu_type) == RECORD_TYPE
+ && CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ gnu_comp_size = max_size (TYPE_SIZE (gnu_type), true);
+
+ /* 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_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)
+ gnu_type = orig_type;
+ else
+ orig_type = gnu_type;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_comp_size, 0, gnat_array,
+ true, 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, NULL, true,
+ debug_info_p, gnat_array);
+ }
+
+ if (Has_Volatile_Components (Base_Type (gnat_array)))
+ gnu_type
+ = build_qualified_type (gnu_type,
+ TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
+
+ 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
/* If this is either a foreign function or if the underlying type won't
be passed by reference, strip off possible padding type. */
- if (TREE_CODE (gnu_param_type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (gnu_param_type))
+ if (TYPE_IS_PADDING_P (gnu_param_type))
{
tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
}
/* Fat pointers are passed as thin pointers for foreign conventions. */
- else if (foreign && TYPE_FAT_POINTER_P (gnu_param_type))
+ else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
gnu_param_type
= make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
Original_Record_Component (discr1) == Original_Record_Component (discr2);
}
-/* Return true if the array type specified by GNAT_TYPE and GNU_TYPE has
- a non-aliased component in the back-end sense. */
+/* Return true if the array type GNU_TYPE, which represents a dimension of
+ GNAT_TYPE, has a non-aliased component in the back-end sense. */
static bool
-array_type_has_nonaliased_component (Entity_Id gnat_type, tree gnu_type)
+array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
{
- /* If the type below this is a multi-array type, then
- this does not have aliased components. */
+ /* If the array type is not the innermost dimension of the GNAT type,
+ then it has a non-aliased component. */
if (TREE_CODE (TREE_TYPE (gnu_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_type)))
return true;
+ /* If the array type has an aliased component in the front-end sense,
+ then it also has an aliased component in the back-end sense. */
if (Has_Aliased_Components (gnat_type))
return false;
+ /* If this is a derived type, then it has a non-aliased component if
+ and only if its parent type also has one. */
+ if (Is_Derived_Type (gnat_type))
+ {
+ tree gnu_parent_type = gnat_to_gnu_type (Etype (gnat_type));
+ int index;
+ if (TREE_CODE (gnu_parent_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_parent_type
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_parent_type))));
+ for (index = Number_Dimensions (gnat_type) - 1; index > 0; index--)
+ gnu_parent_type = TREE_TYPE (gnu_parent_type);
+ return TYPE_NONALIASED_COMPONENT (gnu_parent_type);
+ }
+
+ /* Otherwise, rely exclusively on properties of the element type. */
return type_for_nonaliased_component_p (TREE_TYPE (gnu_type));
}
return Compile_Time_Known_Value (gnat_address);
}
+
+/* Return true if GNAT_RANGE, a N_Range node, cannot be superflat, i.e.
+ cannot verify HB < LB-1 when LB and HB are the low and high bounds. */
+
+static bool
+cannot_be_superflat_p (Node_Id gnat_range)
+{
+ Node_Id gnat_lb = Low_Bound (gnat_range), gnat_hb = High_Bound (gnat_range);
+ Node_Id scalar_range;
+
+ tree gnu_lb, gnu_hb;
+
+ /* If the low bound is not constant, try to find an upper bound. */
+ while (Nkind (gnat_lb) != N_Integer_Literal
+ && (Ekind (Etype (gnat_lb)) == E_Signed_Integer_Subtype
+ || Ekind (Etype (gnat_lb)) == E_Modular_Integer_Subtype)
+ && (scalar_range = Scalar_Range (Etype (gnat_lb)))
+ && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
+ || Nkind (scalar_range) == N_Range))
+ gnat_lb = High_Bound (scalar_range);
+
+ /* If the high bound is not constant, try to find a lower bound. */
+ while (Nkind (gnat_hb) != N_Integer_Literal
+ && (Ekind (Etype (gnat_hb)) == E_Signed_Integer_Subtype
+ || Ekind (Etype (gnat_hb)) == E_Modular_Integer_Subtype)
+ && (scalar_range = Scalar_Range (Etype (gnat_hb)))
+ && (Nkind (scalar_range) == N_Signed_Integer_Type_Definition
+ || Nkind (scalar_range) == N_Range))
+ gnat_hb = Low_Bound (scalar_range);
+
+ if (!(Nkind (gnat_lb) == N_Integer_Literal
+ && Nkind (gnat_hb) == N_Integer_Literal))
+ return false;
+
+ gnu_lb = UI_To_gnu (Intval (gnat_lb), bitsizetype);
+ gnu_hb = UI_To_gnu (Intval (gnat_hb), bitsizetype);
+
+ /* If the low bound is the smallest integer, nothing can be smaller. */
+ gnu_lb = size_binop (MINUS_EXPR, gnu_lb, bitsize_one_node);
+ if (TREE_OVERFLOW (gnu_lb))
+ return true;
+
+ return (tree_int_cst_lt (gnu_hb, gnu_lb) == 0);
+}
\f
/* Given GNAT_ENTITY, elaborate all expressions that are required to
be elaborated at the point of its definition, but do nothing else. */
Node_Id gnat_lb = Type_Low_Bound (gnat_entity);
Node_Id gnat_hb = Type_High_Bound (gnat_entity);
- /* ??? Tests for avoiding static constraint error expression
- is needed until the front stops generating bogus conversions
- on bounds of real types. */
-
+ /* ??? Tests to avoid Constraint_Error in static expressions
+ are needed until after the front stops generating bogus
+ conversions on bounds of real types. */
if (!Raises_Constraint_Error (gnat_lb))
elaborate_expression (gnat_lb, gnat_entity, get_identifier ("L"),
- 1, 0, Needs_Debug_Info (gnat_entity));
+ true, false, Needs_Debug_Info (gnat_entity));
if (!Raises_Constraint_Error (gnat_hb))
elaborate_expression (gnat_hb, gnat_entity, get_identifier ("U"),
- 1, 0, Needs_Debug_Info (gnat_entity));
+ true, false, Needs_Debug_Info (gnat_entity));
break;
}
case E_Limited_Private_Subtype:
case E_Record_Subtype_With_Private:
if (Is_Constrained (gnat_entity)
- && Has_Discriminants (Base_Type (gnat_entity))
+ && Has_Discriminants (gnat_entity)
&& Present (Discriminant_Constraint (gnat_entity)))
{
Node_Id gnat_discriminant_expr;
Entity_Id gnat_field;
- for (gnat_field = First_Discriminant (Base_Type (gnat_entity)),
+ for (gnat_field
+ = First_Discriminant (Implementation_Base_Type (gnat_entity)),
gnat_discriminant_expr
= First_Elmt (Discriminant_Constraint (gnat_entity));
Present (gnat_field);
/* ??? For now, ignore access discriminants. */
if (!Is_Access_Type (Etype (Node (gnat_discriminant_expr))))
elaborate_expression (Node (gnat_discriminant_expr),
- gnat_entity,
- get_entity_name (gnat_field), 1, 0, 0);
+ gnat_entity, get_entity_name (gnat_field),
+ true, false, false);
}
break;
see the inner types. */
while (TREE_CODE (gnu_old_type) == RECORD_TYPE
&& (TYPE_JUSTIFIED_MODULAR_P (gnu_old_type)
- || TYPE_IS_PADDING_P (gnu_old_type)))
+ || TYPE_PADDING_P (gnu_old_type)))
gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
/* Unconstrained array types are deemed incomplete and would thus be given
record_component_aliases (gnu_new_type);
}
\f
-/* Return a TREE_LIST describing the substitutions needed to reflect
- discriminant substitutions from GNAT_SUBTYPE to GNAT_TYPE and add
- them to GNU_LIST. If GNAT_TYPE is not specified, use the base type
- of GNAT_SUBTYPE. The substitutions can be in any order. TREE_PURPOSE
- gives the tree for the discriminant and TREE_VALUES is the replacement
- value. They are in the form of operands to substitute_in_expr.
- DEFINITION is as in gnat_to_gnu_entity. */
-
-static tree
-substitution_list (Entity_Id gnat_subtype, Entity_Id gnat_type,
- tree gnu_list, bool definition)
-{
- Entity_Id gnat_discrim;
- Node_Id gnat_value;
-
- if (No (gnat_type))
- gnat_type = Implementation_Base_Type (gnat_subtype);
-
- if (Has_Discriminants (gnat_type))
- for (gnat_discrim = First_Stored_Discriminant (gnat_type),
- gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
- Present (gnat_discrim);
- gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
- gnat_value = Next_Elmt (gnat_value))
- /* Ignore access discriminants. */
- if (!Is_Access_Type (Etype (Node (gnat_value))))
- gnu_list = tree_cons (gnat_to_gnu_field_decl (gnat_discrim),
- elaborate_expression
- (Node (gnat_value), gnat_subtype,
- get_entity_name (gnat_discrim), definition,
- 1, 0),
- gnu_list);
-
- return gnu_list;
-}
-\f
/* Return true if the size represented by GNU_SIZE can be handled by an
allocation. If STATIC_P is true, consider only what can be done with a
static allocation. */
{
Node_Id gnat_temp;
+ /* Attributes are stored as Representation Item pragmas. */
+
for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Rep_Item (gnat_temp))
if (Nkind (gnat_temp) == N_Pragma)
Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
enum attr_type etype;
- if (Present (gnat_assoc) && Present (First (gnat_assoc))
- && Present (Next (First (gnat_assoc)))
- && (Nkind (Expression (Next (First (gnat_assoc))))
- == N_String_Literal))
- {
- gnu_arg0 = get_identifier (TREE_STRING_POINTER
- (gnat_to_gnu
- (Expression (Next
- (First (gnat_assoc))))));
- if (Present (Next (Next (First (gnat_assoc))))
- && (Nkind (Expression (Next (Next (First (gnat_assoc)))))
- == N_String_Literal))
- gnu_arg1 = get_identifier (TREE_STRING_POINTER
- (gnat_to_gnu
- (Expression
- (Next (Next
- (First (gnat_assoc)))))));
- }
+ /* Map the kind of pragma at hand. Skip if this is not one
+ we know how to handle. */
switch (Get_Pragma_Id (Chars (Pragma_Identifier (gnat_temp))))
{
etype = ATTR_WEAK_EXTERNAL;
break;
+ case Pragma_Thread_Local_Storage:
+ etype = ATTR_THREAD_LOCAL_STORAGE;
+ break;
+
default:
continue;
}
+ /* See what arguments we have and turn them into GCC trees for
+ attribute handlers. These expect identifier for strings. We
+ handle at most two arguments, static expressions only. */
+
+ if (Present (gnat_assoc) && Present (First (gnat_assoc)))
+ {
+ Node_Id gnat_arg0 = Next (First (gnat_assoc));
+ Node_Id gnat_arg1 = Empty;
+
+ if (Present (gnat_arg0)
+ && Is_Static_Expression (Expression (gnat_arg0)))
+ {
+ gnu_arg0 = gnat_to_gnu (Expression (gnat_arg0));
+
+ if (TREE_CODE (gnu_arg0) == STRING_CST)
+ gnu_arg0 = get_identifier (TREE_STRING_POINTER (gnu_arg0));
+
+ gnat_arg1 = Next (gnat_arg0);
+ }
+
+ if (Present (gnat_arg1)
+ && Is_Static_Expression (Expression (gnat_arg1)))
+ {
+ gnu_arg1 = gnat_to_gnu (Expression (gnat_arg1));
+
+ if (TREE_CODE (gnu_arg1) == STRING_CST)
+ gnu_arg1 = get_identifier (TREE_STRING_POINTER (gnu_arg1));
+ }
+ }
/* Prepend to the list now. Make a list of the argument we might
have, as GCC expects it. */
}
}
\f
-/* Called when we need to protect a variable object using a save_expr. */
+/* Called when we need to protect a variable object using a SAVE_EXPR. */
tree
maybe_variable (tree gnu_operand)
{
- if (TREE_CONSTANT (gnu_operand) || TREE_READONLY (gnu_operand)
+ if (TREE_CONSTANT (gnu_operand)
+ || TREE_READONLY (gnu_operand)
|| TREE_CODE (gnu_operand) == SAVE_EXPR
|| TREE_CODE (gnu_operand) == NULL_EXPR)
return gnu_operand;
if (TREE_CODE (gnu_operand) == UNCONSTRAINED_ARRAY_REF)
{
- tree gnu_result = build1 (UNCONSTRAINED_ARRAY_REF,
- TREE_TYPE (gnu_operand),
- variable_size (TREE_OPERAND (gnu_operand, 0)));
-
- TREE_READONLY (gnu_result) = TREE_STATIC (gnu_result)
- = TYPE_READONLY (TREE_TYPE (TREE_TYPE (gnu_operand)));
+ tree gnu_result
+ = build1 (UNCONSTRAINED_ARRAY_REF, TREE_TYPE (gnu_operand),
+ variable_size (TREE_OPERAND (gnu_operand, 0)));
+ TREE_READONLY (gnu_result) = TYPE_READONLY (TREE_TYPE (gnu_operand));
return gnu_result;
}
- else
- return variable_size (gnu_operand);
+
+ return variable_size (gnu_operand);
}
\f
/* Given a GNAT tree GNAT_EXPR, for an expression which is a value within a
type definition (either a bound or a discriminant value) for GNAT_ENTITY,
- return the GCC tree to use for that expression. GNU_NAME is the
- qualification to use if an external name is appropriate and DEFINITION is
- true if this is a definition of GNAT_ENTITY. If NEED_VALUE is true, we
- need a result. Otherwise, we are just elaborating this for side-effects.
- If NEED_DEBUG is true we need the symbol for debugging purposes even if it
+ return the GCC tree to use for that expression. GNU_NAME is the suffix
+ to use if a variable needs to be created and DEFINITION is true if this
+ is a definition of GNAT_ENTITY. If NEED_VALUE is true, we need a result;
+ otherwise, we are just elaborating the expression for side-effects. If
+ NEED_DEBUG is true, we need a variable for debugging purposes even if it
isn't needed for code generation. */
static tree
-elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity,
- tree gnu_name, bool definition, bool need_value,
- bool need_debug)
+elaborate_expression (Node_Id gnat_expr, Entity_Id gnat_entity, tree gnu_name,
+ bool definition, bool need_value, bool need_debug)
{
tree gnu_expr;
- /* If we already elaborated this expression (e.g., it was involved
+ /* If we already elaborated this expression (e.g. it was involved
in the definition of a private type), use the old value. */
if (present_gnu_tree (gnat_expr))
return get_gnu_tree (gnat_expr);
- /* If we don't need a value and this is static or a discriminant, we
- don't need to do anything. */
- else if (!need_value
- && (Is_OK_Static_Expression (gnat_expr)
- || (Nkind (gnat_expr) == N_Identifier
- && Ekind (Entity (gnat_expr)) == E_Discriminant)))
- return 0;
+ /* If we don't need a value and this is static or a discriminant,
+ we don't need to do anything. */
+ if (!need_value
+ && (Is_OK_Static_Expression (gnat_expr)
+ || (Nkind (gnat_expr) == N_Identifier
+ && Ekind (Entity (gnat_expr)) == E_Discriminant)))
+ return NULL_TREE;
+
+ /* If it's a static expression, we don't need a variable for debugging. */
+ if (need_debug && Is_OK_Static_Expression (gnat_expr))
+ need_debug = false;
- /* Otherwise, convert this tree to its GCC equivalent. */
- gnu_expr
- = elaborate_expression_1 (gnat_expr, gnat_entity, gnat_to_gnu (gnat_expr),
- gnu_name, definition, need_debug);
+ /* Otherwise, convert this tree to its GCC equivalent and elaborate it. */
+ gnu_expr = elaborate_expression_1 (gnat_to_gnu (gnat_expr), gnat_entity,
+ gnu_name, definition, need_debug);
/* Save the expression in case we try to elaborate this entity again. Since
it's not a DECL, don't check it. Don't save if it's a discriminant. */
return need_value ? gnu_expr : error_mark_node;
}
-/* Similar, but take a GNU expression. */
+/* Similar, but take a GNU expression and always return a result. */
static tree
-elaborate_expression_1 (Node_Id gnat_expr, Entity_Id gnat_entity,
- tree gnu_expr, tree gnu_name, bool definition,
- bool need_debug)
+elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
+ bool definition, bool need_debug)
{
- tree gnu_decl = NULL_TREE;
/* Skip any conversions and simple arithmetics to see if the expression
is a read-only variable.
??? This really should remain read-only, but we have to think about
the typing of the tree here. */
tree gnu_inner_expr
= skip_simple_arithmetic (remove_conversions (gnu_expr, true));
+ tree gnu_decl = NULL_TREE;
bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
bool expr_variable;
- /* In most cases, we won't see a naked FIELD_DECL here because a
- discriminant reference will have been replaced with a COMPONENT_REF
- when the type is being elaborated. However, there are some cases
- involving child types where we will. So convert it to a COMPONENT_REF
- here. We have to hope it will be at the highest level of the
- expression in these cases. */
+ /* In most cases, we won't see a naked FIELD_DECL because a discriminant
+ reference will have been replaced with a COMPONENT_REF when the type
+ is being elaborated. However, there are some cases involving child
+ types where we will. So convert it to a COMPONENT_REF. We hope it
+ will be at the highest level of the expression in these cases. */
if (TREE_CODE (gnu_expr) == FIELD_DECL)
gnu_expr = build3 (COMPONENT_REF, TREE_TYPE (gnu_expr),
build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
by the variable; otherwise use a SAVE_EXPR if needed. Note that we
rely here on the fact that an expression cannot contain both the
discriminant and some other variable. */
-
expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
&& !(TREE_CODE (gnu_inner_expr) == VAR_DECL
&& (TREE_READONLY (gnu_inner_expr)
|| DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
&& !CONTAINS_PLACEHOLDER_P (gnu_expr));
- /* If this is a static expression or contains a discriminant, we don't
- need the variable for debugging (and can't elaborate anyway if a
- discriminant). */
- if (need_debug
- && (Is_OK_Static_Expression (gnat_expr)
- || CONTAINS_PLACEHOLDER_P (gnu_expr)))
+ /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */
+ if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
need_debug = false;
/* Now create the variable if we need it. */
can do the right thing in the local case. */
if (expr_global && expr_variable)
return gnu_decl;
- else if (!expr_variable)
- return gnu_expr;
- else
- return maybe_variable (gnu_expr);
+
+ return expr_variable ? maybe_variable (gnu_expr) : gnu_expr;
}
\f
/* Create a record type that contains a SIZE bytes long field of TYPE with a
if (TREE_CODE (name) == TYPE_DECL)
name = DECL_NAME (name);
- TYPE_NAME (record_type) = concat_id_with_name (name, "_ALIGN");
+ TYPE_NAME (record_type) = concat_name (name, "_ALIGN");
/* Compute VOFFSET and then POS. The next byte position multiple of some
alignment after some address is obtained by "and"ing the alignment minus
TYPE_JUSTIFIED_MODULAR_P (new_type) = TYPE_JUSTIFIED_MODULAR_P (type);
TYPE_CONTAINS_TEMPLATE_P (new_type) = TYPE_CONTAINS_TEMPLATE_P (type);
if (TREE_CODE (type) == RECORD_TYPE)
- TYPE_IS_PADDING_P (new_type) = TYPE_IS_PADDING_P (type);
+ TYPE_PADDING_P (new_type) = TYPE_PADDING_P (type);
/* If we are in a record and have a small size, set the alignment to
try for an integral mode. Otherwise set it to try for a smaller
if ((TREE_CODE (new_field_type) == RECORD_TYPE
|| TREE_CODE (new_field_type) == UNION_TYPE
|| TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (new_field_type)
+ && !TYPE_FAT_POINTER_P (new_field_type)
&& host_integerp (TYPE_SIZE (new_field_type), 1))
new_field_type = make_packable_type (new_field_type, true);
/* However, for the last field in a not already packed record type
- that is of an aggregate type, we need to use the RM_Size in the
+ that is of an aggregate type, we need to use the RM size in the
packable version of the record type, see finish_record_type. */
if (!TREE_CHAIN (old_field)
&& !TYPE_PACKED (type)
&& (TREE_CODE (new_field_type) == RECORD_TYPE
|| TREE_CODE (new_field_type) == UNION_TYPE
|| TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (new_field_type)
+ && !TYPE_FAT_POINTER_P (new_field_type)
&& !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
&& TYPE_ADA_SIZE (new_field_type))
new_size = TYPE_ADA_SIZE (new_field_type);
field_list = new_field;
}
- finish_record_type (new_type, nreverse (field_list), 2, true);
+ finish_record_type (new_type, nreverse (field_list), 2, false);
relate_alias_sets (new_type, type, ALIAS_SET_COPY);
/* If this is a padding record, we never want to make the size smaller
than what was specified. For QUAL_UNION_TYPE, also copy the size. */
- if ((TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
- || TREE_CODE (type) == QUAL_UNION_TYPE)
+ if (TYPE_IS_PADDING_P (type) || TREE_CODE (type) == QUAL_UNION_TYPE)
{
TYPE_SIZE (new_type) = TYPE_SIZE (type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (type);
+ new_size = size;
}
else
{
\f
/* Ensure that TYPE has SIZE and ALIGN. Make and return a new padded type
if needed. We have already verified that SIZE and TYPE are large enough.
-
- GNAT_ENTITY and NAME_TRAILER are used to name the resulting record and
- to issue a warning.
-
- IS_USER_TYPE is true if we must complete the original type.
-
- DEFINITION is true if this type is being defined.
-
- SAME_RM_SIZE is true if the RM_Size of the resulting type is to be set
- to SIZE too; otherwise, it's set to the RM_Size of the original type. */
+ GNAT_ENTITY is used to name the resulting record and to issue a warning.
+ IS_COMPONENT_TYPE is true if this is being done for the component type
+ of an array. IS_USER_TYPE is true if we must complete the original type.
+ DEFINITION is true if this type is being defined. SAME_RM_SIZE is true
+ if the RM size of the resulting type is to be set to SIZE too; otherwise,
+ it's set to the RM size of the original type. */
tree
maybe_pad_type (tree type, tree size, unsigned int align,
- Entity_Id gnat_entity, const char *name_trailer,
+ Entity_Id gnat_entity, bool is_component_type,
bool is_user_type, bool definition, bool same_rm_size)
{
tree orig_rm_size = same_rm_size ? NULL_TREE : rm_size (type);
tree orig_size = TYPE_SIZE (type);
- unsigned int orig_align = align;
tree record, field;
/* If TYPE is a padded type, see if it agrees with any size and alignment
off the padding, since we will either be returning the inner type
or repadding it. If no size or alignment is specified, use that of
the original padded type. */
- if (TREE_CODE (type) == RECORD_TYPE && TYPE_IS_PADDING_P (type))
+ if (TYPE_IS_PADDING_P (type))
{
if ((!size
|| operand_equal_p (round_up (size,
}
/* If the size is either not being changed or is being made smaller (which
- is not done here (and is only valid for bitfields anyway), show the size
+ is not done here and is only valid for bitfields anyway), show the size
isn't changing. Likewise, clear the alignment if it isn't being
changed. Then return if we aren't doing anything. */
if (size
generate incorrect debugging information. So make a new record
type and name. */
record = make_node (RECORD_TYPE);
- TYPE_IS_PADDING_P (record) = 1;
+ TYPE_PADDING_P (record) = 1;
if (Present (gnat_entity))
- TYPE_NAME (record) = create_concat_name (gnat_entity, name_trailer);
+ TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
TYPE_VOLATILE (record)
= Present (gnat_entity) && Treat_As_Volatile (gnat_entity);
TYPE_ALIGN (record) = align;
- if (orig_align)
- TYPE_USER_ALIGN (record) = align;
-
TYPE_SIZE (record) = size ? size : orig_size;
TYPE_SIZE_UNIT (record)
= convert (sizetype,
orig_size, bitsize_zero_node, 1);
DECL_INTERNAL_P (field) = 1;
- /* Do not finalize it until after the auxiliary record is built. */
- finish_record_type (record, field, 1, true);
+ /* Do not emit debug info until after the auxiliary record is built. */
+ finish_record_type (record, field, 1, false);
- /* Set the same size for its RM_size if requested; otherwise reuse
- the RM_size of the original type. */
+ /* Set the same size for its RM size if requested; otherwise reuse
+ the RM size of the original type. */
SET_TYPE_ADA_SIZE (record, same_rm_size ? size : orig_rm_size);
/* Unless debugging information isn't being written for the input type,
write a record that shows what we are a subtype of and also make a
variable that indicates our size, if still variable. */
- if (TYPE_NAME (record)
- && AGGREGATE_TYPE_P (type)
- && TREE_CODE (orig_size) != INTEGER_CST
+ if (TREE_CODE (orig_size) != INTEGER_CST
+ && TYPE_NAME (record)
+ && TYPE_NAME (type)
&& !(TREE_CODE (TYPE_NAME (type)) == TYPE_DECL
&& DECL_IGNORED_P (TYPE_NAME (type))))
{
if (TREE_CODE (orig_name) == TYPE_DECL)
orig_name = DECL_NAME (orig_name);
- TYPE_NAME (marker) = concat_id_with_name (name, "XVS");
+ TYPE_NAME (marker) = concat_name (name, "XVS");
finish_record_type (marker,
- create_field_decl (orig_name, integer_type_node,
+ create_field_decl (orig_name,
+ build_reference_type (type),
marker, 0, NULL_TREE, NULL_TREE,
0),
- 0, false);
+ 0, true);
add_parallel_type (TYPE_STUB_DECL (record), marker);
- if (size && TREE_CODE (size) != INTEGER_CST && definition)
- create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
- sizetype, TYPE_SIZE_UNIT (record), false, false,
- false, false, NULL, gnat_entity);
+ if (definition && size && TREE_CODE (size) != INTEGER_CST)
+ create_var_decl (concat_name (name, "XVZ"), NULL_TREE, sizetype,
+ TYPE_SIZE_UNIT (record), false, false, false,
+ false, NULL, gnat_entity);
}
rest_of_record_type_compilation (record);
if (align)
orig_size = round_up (orig_size, align);
- if (size && Present (gnat_entity)
+ if (Present (gnat_entity)
+ && size
+ && TREE_CODE (size) != MAX_EXPR
&& !operand_equal_p (size, orig_size, 0)
&& !(TREE_CODE (size) == INTEGER_CST
&& TREE_CODE (orig_size) == INTEGER_CST
/* Generate message only for entities that come from source, since
if we have an entity created by expansion, the message will be
generated for some other corresponding source entity. */
- if (Comes_From_Source (gnat_entity) && Present (gnat_error_node))
- post_error_ne_tree ("{^ }bits of & unused?", gnat_error_node,
- gnat_entity,
- size_diffop (size, orig_size));
-
- else if (*name_trailer == 'C' && !Is_Internal (gnat_entity))
- post_error_ne_tree ("component of& padded{ by ^ bits}?",
- gnat_entity, gnat_entity,
- size_diffop (size, orig_size));
+ if (Comes_From_Source (gnat_entity))
+ {
+ if (Present (gnat_error_node))
+ post_error_ne_tree ("{^ }bits of & unused?",
+ gnat_error_node, gnat_entity,
+ size_diffop (size, orig_size));
+ else if (is_component_type)
+ post_error_ne_tree ("component of& padded{ by ^ bits}?",
+ gnat_entity, gnat_entity,
+ size_diffop (size, orig_size));
+ }
}
return record;
record has Component_Alignment of Storage_Unit, -2 if the enclosing
record has a specified alignment.
- DEFINITION is true if this field is for a record being defined. */
+ DEFINITION is true if this field is for a record being defined.
+
+ DEBUG_INFO_P is true if we need to write debug information for types
+ that we may create in the process. */
static tree
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
- bool definition)
+ bool definition, bool debug_info_p)
{
tree gnu_field_id = get_entity_name (gnat_field);
tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
else
gnu_size = NULL_TREE;
- /* If we have a specified size that's smaller than that of the field type,
- or a position is specified, and the field type is a record, see if we can
- get either an integral mode form of the type or a smaller form. If we
- can, show a size was specified for the field if there wasn't one already,
- so we know to make this a bitfield and avoid making things wider.
+ /* If we have a specified size that is smaller than that of the field's type,
+ or a position is specified, and the field's type is a record that doesn't
+ require strict alignment, see if we can get either an integral mode form
+ of the type or a smaller form. If we can, show a size was specified for
+ the field if there wasn't one already, so we know to make this a bitfield
+ and avoid making things wider.
- Doing this is first useful if the record is packed because we may then
- place the field at a non-byte-aligned position and so achieve tighter
- packing.
+ Changing to an integral mode form is useful when the record is packed as
+ we can then place the field at a non-byte-aligned position and so achieve
+ tighter packing. This is in addition required if the field shares a byte
+ with another field and the front-end lets the back-end handle the access
+ to the field, because GCC cannot handle non-byte-aligned BLKmode fields.
- This is in addition *required* if the field shares a byte with another
- field and the front-end lets the back-end handle the references, because
- GCC does not handle BLKmode bitfields properly.
+ Changing to a smaller form is required if the specified size is smaller
+ than that of the field's type and the type contains sub-fields that are
+ padded, in order to avoid generating accesses to these sub-fields that
+ are wider than the field.
We avoid the transformation if it is not required or potentially useful,
as it might entail an increase of the field's alignment and have ripple
effects on the outer record type. A typical case is a field known to be
- byte aligned and not to share a byte with another field.
-
- Besides, we don't even look the possibility of a transformation in cases
- known to be in error already, for instance when an invalid size results
- from a component clause. */
-
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && !TYPE_IS_FAT_POINTER_P (gnu_field_type)
+ byte-aligned and not to share a byte with another field. */
+ if (!needs_strict_alignment
+ && TREE_CODE (gnu_field_type) == RECORD_TYPE
+ && !TYPE_FAT_POINTER_P (gnu_field_type)
&& host_integerp (TYPE_SIZE (gnu_field_type), 1)
&& (packed == 1
|| (gnu_size
&& (tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type))
- || Present (Component_Clause (gnat_field))))))
+ || (Present (Component_Clause (gnat_field))
+ && !(UI_To_Int (Component_Bit_Offset (gnat_field))
+ % BITS_PER_UNIT == 0
+ && value_factor_p (gnu_size, BITS_PER_UNIT)))))))
{
- /* See what the alternate type and size would be. */
tree gnu_packable_type = make_packable_type (gnu_field_type, true);
-
- bool has_byte_aligned_clause
- = Present (Component_Clause (gnat_field))
- && (UI_To_Int (Component_Bit_Offset (gnat_field))
- % BITS_PER_UNIT == 0);
-
- /* Compute whether we should avoid the substitution. */
- bool reject
- /* There is no point substituting if there is no change... */
- = (gnu_packable_type == gnu_field_type)
- /* ... nor when the field is known to be byte aligned and not to
- share a byte with another field. */
- || (has_byte_aligned_clause
- && value_factor_p (gnu_size, BITS_PER_UNIT))
- /* The size of an aliased field must be an exact multiple of the
- type's alignment, which the substitution might increase. Reject
- substitutions that would so invalidate a component clause when the
- specified position is byte aligned, as the change would have no
- real benefit from the packing standpoint anyway. */
- || (Is_Aliased (gnat_field)
- && has_byte_aligned_clause
- && !value_factor_p (gnu_size, TYPE_ALIGN (gnu_packable_type)));
-
- /* Substitute unless told otherwise. */
- if (!reject)
+ if (gnu_packable_type != gnu_field_type)
{
gnu_field_type = gnu_packable_type;
-
if (!gnu_size)
gnu_size = rm_size (gnu_field_type);
}
if (Present (Component_Clause (gnat_field)))
{
+ Entity_Id gnat_parent
+ = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
+
gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
- /* Ensure the position does not overlap with the parent subtype,
- if there is one. */
- if (Present (Parent_Subtype (Underlying_Type (Scope (gnat_field)))))
+ /* Ensure the position does not overlap with the parent subtype, if there
+ is one. This test is omitted if the parent of the tagged type has a
+ full rep clause since, in this case, component clauses are allowed to
+ overlay the space allocated for the parent type and the front-end has
+ checked that there are no overlapping components. */
+ if (Present (gnat_parent) && !Is_Fully_Repped_Tagged_Type (gnat_parent))
{
- tree gnu_parent
- = gnat_to_gnu_type (Parent_Subtype
- (Underlying_Type (Scope (gnat_field))));
+ tree gnu_parent = gnat_to_gnu_type (gnat_parent);
if (TREE_CODE (TYPE_SIZE (gnu_parent)) == INTEGER_CST
&& tree_int_cst_lt (gnu_pos, TYPE_SIZE (gnu_parent)))
/* If a size is specified, adjust the field's type to it. */
if (gnu_size)
{
+ tree orig_field_type;
+
/* 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
gnu_field_type
= make_type_from_size (gnu_field_type, gnu_size,
Has_Biased_Representation (gnat_field));
+
+ orig_field_type = gnu_field_type;
gnu_field_type = maybe_pad_type (gnu_field_type, gnu_size, 0, gnat_field,
- "PAD", false, definition, true);
+ 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_field_type != orig_field_type
+ && !DECL_P (TYPE_NAME (gnu_field_type)))
+ create_type_decl (TYPE_NAME (gnu_field_type), gnu_field_type, NULL,
+ true, debug_info_p, gnat_field);
}
/* Otherwise (or if there was an error), don't specify a position. */
if (!TREE_CONSTANT (TYPE_SIZE (type)))
return true;
- if (TREE_CODE (type) == RECORD_TYPE
- && TYPE_IS_PADDING_P (type)
+ if (TYPE_IS_PADDING_P (type)
&& !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
return true;
return ret ? ret : (int) (DECL_UID (field1) - DECL_UID (field2));
}
-/* Return a GCC tree for a record type given a GNAT Component_List and a chain
- of GCC trees for fields that are in the record and have already been
- processed. When called from gnat_to_gnu_entity during the processing of a
- record type definition, the GCC nodes for the discriminants will be on
- the chain. The other calls to this function are recursive calls from
- itself for the Component_List of a variant and the chain is empty.
+/* 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. 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.
PACKED is 1 if this is for a packed record, -1 if this is for a record
with Component_Alignment of Storage_Unit, -2 if this is for a record
with a specified alignment.
- DEFINITION is true if we are defining this record.
+ DEFINITION is true if we are defining this record type.
P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
- with a rep clause is to be added. If it is nonzero, that is all that
- should be done with such fields.
+ with a rep clause is to be added; in this case, that is all that should
+ be done with such fields.
- CANCEL_ALIGNMENT, if true, means the alignment should be zeroed before
- laying out the record. This means the alignment only serves to force fields
- to be bitfields, but not require the record to be that aligned. This is
+ CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
+ out the record. This means the alignment only serves to force fields to
+ be bitfields, but not to require the record to be that aligned. This is
used for variants.
- ALL_REP, if true, means a rep clause was found for all the fields. This
- simplifies the logic since we know we're not in the mixed case.
+ ALL_REP is true if a rep clause is present for all the fields.
+
+ UNCHECKED_UNION is true if we are building this type for a record with a
+ Pragma Unchecked_Union.
- DO_NOT_FINALIZE, if true, means that the record type is expected to be
- modified afterwards so it will not be sent to the back-end for finalization.
+ DEBUG_INFO_P is true if we need to write debug information about the type.
- UNCHECKED_UNION, if true, means that we are building a type for a record
- with a Pragma Unchecked_Union.
+ 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, but only the container. */
- The processing of the component list fills in the chain with all of the
- fields of the record and then the record type is finished. */
static void
-components_to_record (tree gnu_record_type, Node_Id component_list,
+components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
tree gnu_field_list, int packed, bool definition,
tree *p_gnu_rep_list, bool cancel_alignment,
- bool all_rep, bool do_not_finalize, bool unchecked_union)
+ bool all_rep, bool unchecked_union, bool debug_info_p,
+ bool maybe_unused)
{
- Node_Id component_decl;
- Entity_Id gnat_field;
- Node_Id variant_part;
- tree gnu_our_rep_list = NULL_TREE;
- tree gnu_field, gnu_last;
- bool layout_with_rep = false;
bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
+ bool layout_with_rep = false;
+ Node_Id component_decl, variant_part;
+ tree gnu_our_rep_list = NULL_TREE;
+ tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
- /* For each variable within each component declaration create a GCC field
- and add it to the list, skipping any pragmas in the list. */
- if (Present (Component_Items (component_list)))
- for (component_decl = First_Non_Pragma (Component_Items (component_list));
+ /* For each component referenced in a component declaration create a GCC
+ field and add it to the list, skipping pragmas in the GNAT list. */
+ if (Present (Component_Items (gnat_component_list)))
+ for (component_decl
+ = First_Non_Pragma (Component_Items (gnat_component_list));
Present (component_decl);
component_decl = Next_Non_Pragma (component_decl))
{
- gnat_field = Defining_Entity (component_decl);
+ Entity_Id gnat_field = Defining_Entity (component_decl);
+ Name_Id gnat_name = Chars (gnat_field);
- if (Chars (gnat_field) == Name_uParent)
- gnu_field = tree_last (TYPE_FIELDS (gnu_record_type));
+ /* If present, the _Parent field must have been created as the single
+ field of the record type. Put it before any other fields. */
+ if (gnat_name == Name_uParent)
+ {
+ gnu_field = TYPE_FIELDS (gnu_record_type);
+ gnu_field_list = chainon (gnu_field_list, gnu_field);
+ }
else
{
- gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type,
- packed, definition);
+ gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
+ definition, debug_info_p);
- /* If this is the _Tag field, put it before any discriminants,
- instead of after them as is the case for all other fields. */
- if (Chars (gnat_field) == Name_uTag)
+ /* If this is the _Tag field, put it before any other fields. */
+ if (gnat_name == Name_uTag)
gnu_field_list = chainon (gnu_field_list, gnu_field);
+
+ /* 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)
+ {
+ TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
+ TREE_CHAIN (gnu_last) = gnu_field;
+ }
+
+ /* If this is a regular field, put it after the other fields. */
else
{
TREE_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
+ if (!gnu_last)
+ gnu_last = gnu_field;
}
}
}
/* At the end of the component list there may be a variant part. */
- variant_part = Variant_Part (component_list);
+ 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
use GNU_RECORD_TYPE if there are no fields so far. */
if (Present (variant_part))
{
- tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
- Node_Id variant;
+ Node_Id gnat_discr = Name (variant_part), variant;
+ tree gnu_discr = gnat_to_gnu (gnat_discr);
tree gnu_name = TYPE_NAME (gnu_record_type);
tree gnu_var_name
- = concat_id_with_name (get_identifier (Get_Name_String
- (Chars (Name (variant_part)))),
- "XVN");
- tree gnu_union_type;
- tree gnu_union_name;
- tree gnu_union_field;
+ = concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
+ "XVN");
+ tree gnu_union_type, gnu_union_name, gnu_union_field;
tree gnu_variant_list = NULL_TREE;
if (TREE_CODE (gnu_name) == TYPE_DECL)
gnu_name = DECL_NAME (gnu_name);
- gnu_union_name = concat_id_with_name (gnu_name,
- IDENTIFIER_POINTER (gnu_var_name));
+ gnu_union_name
+ = concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
/* Reuse an enclosing union if all fields are in the variant part
and there is no representation clause on the record, to match
tree gnu_qual;
Get_Variant_Encoding (variant);
- gnu_inner_name = get_identifier (Name_Buffer);
+ gnu_inner_name = get_identifier_with_length (Name_Buffer, Name_Len);
TYPE_NAME (gnu_variant_type)
- = concat_id_with_name (gnu_union_name,
- IDENTIFIER_POINTER (gnu_inner_name));
+ = concat_name (gnu_union_name,
+ IDENTIFIER_POINTER (gnu_inner_name));
/* 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. */
+ 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);
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
- /* Similarly, if the outer record has a size specified and all fields
- have record rep clauses, we can propagate the size into the
- variant part. */
+ /* Similarly, if the outer record has a size specified and all
+ fields have record rep clauses, we can propagate the size
+ into the variant part. */
if (all_rep_and_size)
{
TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
= TYPE_SIZE_UNIT (gnu_record_type);
}
- /* Create the record type for the variant. Note that we defer
- finalizing it until after we are sure to actually use it. */
+ /* 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. */
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
&gnu_our_rep_list, !all_rep_and_size, all_rep,
- true, unchecked_union);
+ unchecked_union, debug_info_p, true);
- gnu_qual = choices_to_gnu (gnu_discriminant,
- Discrete_Choices (variant));
+ gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
Set_Present_Expr (variant, annotate_value (gnu_qual));
otherwise, the union type definition will be lacking
the fields associated with these empty variants. */
rest_of_record_type_compilation (gnu_variant_type);
+ create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
+ NULL, true, debug_info_p, gnat_component_list);
gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
gnu_union_type, field_packed,
gnu_variant_list = gnu_field;
}
- /* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
+ /* Only make the QUAL_UNION_TYPE if there are non-empty variants. */
if (gnu_variant_list)
{
int union_field_packed;
}
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
- all_rep_and_size ? 1 : 0, false);
+ all_rep_and_size ? 1 : 0, debug_info_p);
/* If GNU_UNION_TYPE is our record type, it means we must have an
Unchecked_Union with no fields. Verify that and, if so, just
return;
}
+ create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
+ NULL, true, debug_info_p, gnat_component_list);
+
/* Deal with packedness like in gnat_to_gnu_field. */
union_field_packed
= adjust_packed (gnu_union_type, gnu_record_type, packed);
}
/* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
- do, pull them out and put them into GNU_OUR_REP_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.
-
- ??? Note: if we then reorder them, debugging information will be wrong,
- but there's nothing that can be done about this at the moment. */
- for (gnu_field = gnu_field_list, gnu_last = NULL_TREE; gnu_field; )
+ do, pull them out and put them into GNU_OUR_REP_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.
+
+ ??? If we then reorder them, debugging information will be wrong but
+ there's nothing that can be done about this at the moment. */
+ gnu_last = NULL_TREE;
+ for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
{
+ gnu_next = TREE_CHAIN (gnu_field);
+
if (DECL_FIELD_OFFSET (gnu_field))
{
- tree gnu_next = TREE_CHAIN (gnu_field);
-
if (!gnu_last)
gnu_field_list = gnu_next;
else
TREE_CHAIN (gnu_field) = gnu_our_rep_list;
gnu_our_rep_list = gnu_field;
- gnu_field = gnu_next;
}
else
- {
- gnu_last = gnu_field;
- gnu_field = TREE_CHAIN (gnu_field);
- }
+ gnu_last = gnu_field;
}
- /* If we have any items in our rep'ed field list, it is not the case that all
- the fields in the record have rep clauses, and P_REP_LIST is nonzero,
- set it and ignore the items. */
+ /* If we have any fields in our rep'ed field list and it is not the case that
+ all the fields in the record have rep clauses and P_REP_LIST is nonzero,
+ set it and ignore these fields. */
if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
*p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
+
+ /* Otherwise, sort the fields by bit position and put them into their own
+ record, before the others, if we also have fields without rep clauses. */
else if (gnu_our_rep_list)
{
- /* Otherwise, sort the fields by bit position and put them into their
- own record if we have any fields without rep clauses. */
tree gnu_rep_type
= (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
- int len = list_length (gnu_our_rep_list);
+ int i, len = list_length (gnu_our_rep_list);
tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
- int i;
- for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
+ for (gnu_field = gnu_our_rep_list, i = 0;
+ gnu_field;
gnu_field = TREE_CHAIN (gnu_field), i++)
gnu_arr[i] = gnu_field;
if (gnu_field_list)
{
- finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, false);
- gnu_field = create_field_decl (get_identifier ("REP"), gnu_rep_type,
- gnu_record_type, 0, 0, 0, 1);
+ finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, debug_info_p);
+ gnu_field
+ = create_field_decl (get_identifier ("REP"), gnu_rep_type,
+ gnu_record_type, 0, NULL_TREE, NULL_TREE, 1);
DECL_INTERNAL_P (gnu_field) = 1;
gnu_field_list = chainon (gnu_field_list, gnu_field);
}
TYPE_ALIGN (gnu_record_type) = 0;
finish_record_type (gnu_record_type, nreverse (gnu_field_list),
- layout_with_rep ? 1 : 0, do_not_finalize);
+ layout_with_rep ? 1 : 0, debug_info_p && !maybe_unused);
}
\f
/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
case EQ_EXPR: tcode = Eq_Expr; break;
case NE_EXPR: tcode = Ne_Expr; break;
+ case CALL_EXPR:
+ {
+ tree t = maybe_inline_call_in_expr (gnu_size);
+ if (t)
+ return annotate_value (t);
+ }
+
+ /* Fall through... */
+
default:
return No_Uint;
}
return ret;
}
-/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding
- GCC type, set Component_Bit_Offset and Esize to the position and size
- used by Gigi. */
+/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
+ and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
+ size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
+ BY_REF is true if the object is used by reference. */
+
+void
+annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
+{
+ if (by_ref)
+ {
+ if (TYPE_IS_FAT_POINTER_P (gnu_type))
+ gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
+ else
+ gnu_type = TREE_TYPE (gnu_type);
+ }
+
+ if (Unknown_Esize (gnat_entity))
+ {
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
+ size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
+ else if (!size)
+ size = TYPE_SIZE (gnu_type);
+
+ if (size)
+ Set_Esize (gnat_entity, annotate_value (size));
+ }
+
+ if (Unknown_Alignment (gnat_entity))
+ Set_Alignment (gnat_entity,
+ UI_From_Int (TYPE_ALIGN (gnu_type) / BITS_PER_UNIT));
+}
+
+/* Return first element of field list whose TREE_PURPOSE is ELEM or whose
+ DECL_ORIGINAL_FIELD of TREE_PURPOSE is ELEM. Return NULL_TREE if there
+ is no such element in the list. */
+
+static tree
+purpose_member_field (const_tree elem, tree list)
+{
+ while (list)
+ {
+ tree field = TREE_PURPOSE (list);
+ if (elem == field || elem == DECL_ORIGINAL_FIELD (field))
+ return list;
+ list = TREE_CHAIN (list);
+ }
+ return NULL_TREE;
+}
+
+/* Given GNAT_ENTITY, a record type, and GNU_TYPE, its corresponding GCC type,
+ set Component_Bit_Offset and Esize of the components to the position and
+ size used by Gigi. */
static void
annotate_rep (Entity_Id gnat_entity, tree gnu_type)
{
- tree gnu_list;
- tree gnu_entry;
Entity_Id gnat_field;
+ tree gnu_list;
- /* We operate by first making a list of all fields and their positions
- (we can get the sizes easily at any time) by a recursive call
- and then update all the sizes into the tree. */
- gnu_list = compute_field_positions (gnu_type, NULL_TREE,
- size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
+ /* 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
+ = build_position_list (gnu_type, false, size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, NULL_TREE);
- for (gnat_field = First_Entity (gnat_entity); Present (gnat_field);
+ for (gnat_field = First_Entity (gnat_entity);
+ Present (gnat_field);
gnat_field = Next_Entity (gnat_field))
- if ((Ekind (gnat_field) == E_Component
- || (Ekind (gnat_field) == E_Discriminant
- && !Is_Unchecked_Union (Scope (gnat_field)))))
+ if (Ekind (gnat_field) == E_Component
+ || (Ekind (gnat_field) == E_Discriminant
+ && !Is_Unchecked_Union (Scope (gnat_field))))
{
- tree parent_offset = bitsize_zero_node;
-
- gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
- gnu_list);
-
- if (gnu_entry)
+ tree t = purpose_member_field (gnat_to_gnu_field_decl (gnat_field),
+ gnu_list);
+ if (t)
{
+ tree parent_offset;
+
if (type_annotate_only && Is_Tagged_Type (gnat_entity))
{
- /* In this mode the tag and parent components have not been
+ /* In this mode the tag and parent components are not
generated, so we add the appropriate offset to each
component. 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
- = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
- bitsizetype);
- else
- parent_offset = bitsize_int (POINTER_SIZE);
+ if (Is_Derived_Type (gnat_entity)
+ && Original_Record_Component (gnat_field) == gnat_field)
+ parent_offset
+ = UI_To_gnu (Esize (Etype (Base_Type (gnat_entity))),
+ bitsizetype);
+ else
+ parent_offset = bitsize_int (POINTER_SIZE);
}
+ else
+ parent_offset = bitsize_zero_node;
- Set_Component_Bit_Offset
- (gnat_field,
- annotate_value
- (size_binop (PLUS_EXPR,
- bit_from_pos (TREE_PURPOSE (TREE_VALUE (gnu_entry)),
- TREE_VALUE (TREE_VALUE
- (TREE_VALUE (gnu_entry)))),
- parent_offset)));
+ Set_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)));
Set_Esize (gnat_field,
- annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
+ annotate_value (DECL_SIZE (TREE_PURPOSE (t))));
}
- else if (Is_Tagged_Type (gnat_entity)
- && Is_Derived_Type (gnat_entity))
+ else if (Is_Tagged_Type (gnat_entity) && Is_Derived_Type (gnat_entity))
{
- /* If there is no gnu_entry, this is an inherited component whose
+ /* 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)));
+
Set_Esize (gnat_field,
Esize (Original_Record_Component (gnat_field)));
}
}
}
-
-/* Scan all fields in GNU_TYPE and build entries where TREE_PURPOSE is the
- FIELD_DECL and TREE_VALUE a TREE_LIST with TREE_PURPOSE being the byte
- position and TREE_VALUE being a TREE_LIST with TREE_PURPOSE the value to be
- placed into DECL_OFFSET_ALIGN and TREE_VALUE the bit position. GNU_POS is
- to be added to the position, GNU_BITPOS to the bit position, OFFSET_ALIGN is
- the present value of DECL_OFFSET_ALIGN and GNU_LIST is a list of the entries
- so far. */
+\f
+/* Scan all fields in GNU_TYPE and return a TREE_LIST where TREE_PURPOSE is
+ the FIELD_DECL and TREE_VALUE a TREE_VEC containing the byte position, the
+ value to be placed into DECL_OFFSET_ALIGN and the bit position. The list
+ of fields is flattened, except for variant parts if DO_NOT_FLATTEN_VARIANT
+ is set to true. GNU_POS is to be added to the position, GNU_BITPOS to the
+ bit position, OFFSET_ALIGN is the present offset alignment. GNU_LIST is a
+ pre-existing list to be chained to the newly created entries. */
static tree
-compute_field_positions (tree gnu_type, tree gnu_list, tree gnu_pos,
- tree gnu_bitpos, unsigned int offset_align)
+build_position_list (tree gnu_type, bool do_not_flatten_variant, tree gnu_pos,
+ tree gnu_bitpos, unsigned int offset_align, tree gnu_list)
{
tree gnu_field;
- tree gnu_result = gnu_list;
- for (gnu_field = TYPE_FIELDS (gnu_type); gnu_field;
+ for (gnu_field = TYPE_FIELDS (gnu_type);
+ gnu_field;
gnu_field = TREE_CHAIN (gnu_field))
{
tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
DECL_FIELD_OFFSET (gnu_field));
unsigned int our_offset_align
= MIN (offset_align, DECL_OFFSET_ALIGN (gnu_field));
+ tree v = make_tree_vec (3);
- gnu_result
- = tree_cons (gnu_field,
- tree_cons (gnu_our_offset,
- tree_cons (size_int (our_offset_align),
- gnu_our_bitpos, NULL_TREE),
- NULL_TREE),
- gnu_result);
+ TREE_VEC_ELT (v, 0) = gnu_our_offset;
+ TREE_VEC_ELT (v, 1) = size_int (our_offset_align);
+ TREE_VEC_ELT (v, 2) = gnu_our_bitpos;
+ gnu_list = tree_cons (gnu_field, v, gnu_list);
+ /* Recurse on internal fields, flattening the nested fields except for
+ those in the variant part, if requested. */
if (DECL_INTERNAL_P (gnu_field))
- gnu_result
- = compute_field_positions (TREE_TYPE (gnu_field), gnu_result,
+ {
+ tree gnu_field_type = TREE_TYPE (gnu_field);
+ if (do_not_flatten_variant
+ && TREE_CODE (gnu_field_type) == QUAL_UNION_TYPE)
+ gnu_list
+ = build_position_list (gnu_field_type, do_not_flatten_variant,
+ size_zero_node, bitsize_zero_node,
+ BIGGEST_ALIGNMENT, gnu_list);
+ else
+ gnu_list
+ = build_position_list (gnu_field_type, do_not_flatten_variant,
gnu_our_offset, gnu_our_bitpos,
- our_offset_align);
+ our_offset_align, gnu_list);
+ }
+ }
+
+ return gnu_list;
+}
+
+/* Return a TREE_LIST describing the substitutions needed to reflect the
+ discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
+ be in any order. TREE_PURPOSE gives the tree for the discriminant and
+ TREE_VALUE is the replacement value. They are in the form of operands
+ to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
+ of GNAT_SUBTYPE. */
+
+static tree
+build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
+{
+ tree gnu_list = NULL_TREE;
+ Entity_Id gnat_discrim;
+ Node_Id gnat_value;
+
+ for (gnat_discrim = First_Stored_Discriminant (gnat_type),
+ gnat_value = First_Elmt (Stored_Constraint (gnat_subtype));
+ Present (gnat_discrim);
+ gnat_discrim = Next_Stored_Discriminant (gnat_discrim),
+ gnat_value = Next_Elmt (gnat_value))
+ /* Ignore access discriminants. */
+ if (!Is_Access_Type (Etype (Node (gnat_value))))
+ {
+ tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
+ gnu_list = tree_cons (gnu_field,
+ convert (TREE_TYPE (gnu_field),
+ elaborate_expression
+ (Node (gnat_value), gnat_subtype,
+ get_entity_name (gnat_discrim),
+ definition, true, false)),
+ gnu_list);
+ }
+
+ return gnu_list;
+}
+
+/* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
+ variants of QUAL_UNION_TYPE that are still relevant after applying the
+ substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
+ variant and TREE_VALUE is a TREE_VEC containing the field, the new value
+ of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
+ list to be chained to the newly created entries. */
+
+static tree
+build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
+{
+ tree gnu_field;
+
+ for (gnu_field = TYPE_FIELDS (qual_union_type);
+ gnu_field;
+ gnu_field = TREE_CHAIN (gnu_field))
+ {
+ tree t, qual = DECL_QUALIFIER (gnu_field);
+
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
+
+ /* If the new qualifier is not unconditionally false, its variant may
+ still be accessed. */
+ if (!integer_zerop (qual))
+ {
+ tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
+ tree v = make_tree_vec (3);
+ TREE_VEC_ELT (v, 0) = gnu_field;
+ TREE_VEC_ELT (v, 1) = qual;
+ TREE_VEC_ELT (v, 2) = NULL_TREE;
+ gnu_list = tree_cons (variant_type, v, gnu_list);
+
+ /* Recurse on the variant subpart of the variant, if any. */
+ variant_subpart = get_variant_part (variant_type);
+ if (variant_subpart)
+ gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
+ subst_list, gnu_list);
+
+ /* If the new qualifier is unconditionally true, the subsequent
+ variants cannot be accessed. */
+ if (integer_onep (qual))
+ break;
+ }
}
- return gnu_result;
+ return gnu_list;
}
\f
/* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
else
gnat_error_node = gnat_object;
- /* Return 0 if no size was specified, either because Esize was not Present or
- the specified size was zero. */
+ /* Return 0 if no size was specified, either because Esize was not Present
+ or the specified size was zero. */
if (No (uint_size) || uint_size == No_Uint)
return NULL_TREE;
- /* Get the size as a tree. Give an error if a size was specified, but cannot
- be represented as in sizetype. */
+ /* Get the size as a tree. Issue an error if a size was specified but
+ cannot be represented in sizetype. */
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
}
/* Ignore a negative size since that corresponds to our back-annotation.
- Also ignore a zero size unless a size clause exists. */
- else if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
+ Also ignore a zero size if it is not permitted. */
+ if (tree_int_cst_sgn (size) < 0 || (integer_zerop (size) && !zero_ok))
return NULL_TREE;
/* The size of objects is always a multiple of a byte. */
/* If this is an integral type or a packed array type, the front-end has
verified the size, so we need not do it here (which would entail
- checking against the bounds). However, if this is an aliased object, it
- may not be smaller than the type of the object. */
+ checking against the bounds). However, if this is an aliased object,
+ it may not be smaller than the type of the object. */
if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
&& !(kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
/* If this is an access type or a fat pointer, the minimum size is that given
by the smallest integral mode that's valid for pointers. */
- if ((TREE_CODE (gnu_type) == POINTER_TYPE) || TYPE_FAT_POINTER_P (gnu_type))
+ if (TREE_CODE (gnu_type) == POINTER_TYPE || TYPE_IS_FAT_POINTER_P (gnu_type))
{
enum machine_mode p_mode;
return size;
}
\f
-/* Similarly, but both validate and process a value of RM_Size. This
+/* Similarly, but both validate and process a value of RM size. This
routine is only called for types. */
static void
set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
{
- /* Only give an error if a Value_Size clause was explicitly given.
+ /* Only issue an error if a Value_Size clause was explicitly given.
Otherwise, we'd be duplicating an error on the Size clause. */
Node_Id gnat_attr_node
= Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
- tree old_size = rm_size (gnu_type);
- tree size;
+ tree old_size = rm_size (gnu_type), size;
- /* Get the size as a tree. Do nothing if none was specified, either
- because RM_Size was not Present or if the specified size was zero.
- Give an error if a size was specified, but cannot be represented as
- in sizetype. */
+ /* Do nothing if no size was specified, either because RM size was not
+ Present or if the specified size was zero. */
if (No (uint_size) || uint_size == No_Uint)
return;
+ /* Get the size as a tree. Issue an error if a size was specified but
+ cannot be represented in sizetype. */
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
if (Present (gnat_attr_node))
post_error_ne ("Value_Size of & is too large", gnat_attr_node,
gnat_entity);
-
return;
}
/* Ignore a negative size since that corresponds to our back-annotation.
- Also ignore a zero size unless a size clause exists, a Value_Size
- clause exists, or this is an integer type, in which case the
- front end will have always set it. */
- else if (tree_int_cst_sgn (size) < 0
- || (integer_zerop (size) && No (gnat_attr_node)
- && !Has_Size_Clause (gnat_entity)
- && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
+ Also ignore a zero size unless a Value_Size clause exists, or a size
+ clause exists, or this is an integer type, in which case the front-end
+ will have always set it. */
+ if (tree_int_cst_sgn (size) < 0
+ || (integer_zerop (size)
+ && No (gnat_attr_node)
+ && !Has_Size_Clause (gnat_entity)
+ && !Is_Discrete_Or_Fixed_Point_Type (gnat_entity)))
return;
/* If the old size is self-referential, get the maximum size. */
if (CONTAINS_PLACEHOLDER_P (old_size))
old_size = max_size (old_size, true);
- /* If the size of the object is a constant, the new size must not be
- smaller (the front end checks this for scalar types). */
+ /* If the size of the object is a constant, the new size must not be smaller
+ (the front-end has verified this for scalar and packed array types). */
if (TREE_CODE (old_size) != INTEGER_CST
|| TREE_OVERFLOW (old_size)
|| (AGGREGATE_TYPE_P (gnu_type)
+ && !(TREE_CODE (gnu_type) == ARRAY_TYPE
+ && TYPE_PACKED_ARRAY_TYPE_P (gnu_type))
+ && !(TYPE_IS_PADDING_P (gnu_type)
+ && TREE_CODE (TREE_TYPE (TYPE_FIELDS (gnu_type))) == ARRAY_TYPE
+ && TYPE_PACKED_ARRAY_TYPE_P (TREE_TYPE (TYPE_FIELDS (gnu_type))))
&& tree_int_cst_lt (size, old_size)))
{
if (Present (gnat_attr_node))
post_error_ne_tree
("Value_Size for& too small{, minimum allowed is ^}",
gnat_attr_node, gnat_entity, old_size);
-
return;
}
- /* Otherwise, set the RM_Size. */
- if (TREE_CODE (gnu_type) == INTEGER_TYPE
- && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
- TYPE_RM_SIZE_NUM (gnu_type) = size;
- else if (TREE_CODE (gnu_type) == ENUMERAL_TYPE
- || TREE_CODE (gnu_type) == BOOLEAN_TYPE)
- TYPE_RM_SIZE_NUM (gnu_type) = size;
+ /* Otherwise, set the RM size proper for integral types... */
+ if ((TREE_CODE (gnu_type) == INTEGER_TYPE
+ && Is_Discrete_Or_Fixed_Point_Type (gnat_entity))
+ || (TREE_CODE (gnu_type) == ENUMERAL_TYPE
+ || TREE_CODE (gnu_type) == BOOLEAN_TYPE))
+ SET_TYPE_RM_SIZE (gnu_type, size);
+
+ /* ...or the Ada size for record and union types. */
else if ((TREE_CODE (gnu_type) == RECORD_TYPE
|| TREE_CODE (gnu_type) == UNION_TYPE
|| TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type))
+ && !TYPE_FAT_POINTER_P (gnu_type))
SET_TYPE_ADA_SIZE (gnu_type, size);
}
\f
biased_p = (TREE_CODE (type) == INTEGER_TYPE
&& TYPE_BIASED_REPRESENTATION_P (type));
+ /* Integer types with precision 0 are forbidden. */
+ if (size == 0)
+ size = 1;
+
/* Only do something if the type is not a packed array type and
doesn't already have the proper size. */
if (TYPE_PACKED_ARRAY_TYPE_P (type)
break;
biased_p |= for_biased;
- size = MIN (size, LONG_LONG_TYPE_SIZE);
+ if (size > LONG_LONG_TYPE_SIZE)
+ size = LONG_LONG_TYPE_SIZE;
if (TYPE_UNSIGNED (type) || biased_p)
new_type = make_unsigned_type (size);
else
new_type = make_signed_type (size);
TREE_TYPE (new_type) = TREE_TYPE (type) ? TREE_TYPE (type) : type;
- TYPE_MIN_VALUE (new_type)
- = convert (TREE_TYPE (new_type), TYPE_MIN_VALUE (type));
- TYPE_MAX_VALUE (new_type)
- = convert (TREE_TYPE (new_type), TYPE_MAX_VALUE (type));
+ SET_TYPE_RM_MIN_VALUE (new_type,
+ convert (TREE_TYPE (new_type),
+ TYPE_MIN_VALUE (type)));
+ SET_TYPE_RM_MAX_VALUE (new_type,
+ convert (TREE_TYPE (new_type),
+ TYPE_MAX_VALUE (type)));
/* Propagate the name to avoid creating a fake subrange type. */
if (TYPE_NAME (type))
{
TYPE_NAME (new_type) = TYPE_NAME (type);
}
TYPE_BIASED_REPRESENTATION_P (new_type) = biased_p;
- TYPE_RM_SIZE_NUM (new_type) = bitsize_int (size);
+ SET_TYPE_RM_SIZE (new_type, bitsize_int (size));
return new_type;
case RECORD_TYPE:
/* Do something if this is a fat pointer, in which case we
may need to return the thin pointer. */
- if (TYPE_IS_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
+ if (TYPE_FAT_POINTER_P (type) && size < POINTER_SIZE * 2)
{
enum machine_mode p_mode = mode_for_size (size, MODE_INT, 0);
if (!targetm.valid_pointer_mode (p_mode))
case POINTER_TYPE:
/* Only do something if this is a thin pointer, in which case we
may need to return the fat pointer. */
- if (TYPE_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
+ if (TYPE_IS_THIN_POINTER_P (type) && size >= POINTER_SIZE * 2)
return
build_pointer_type (TYPE_UNCONSTRAINED_ARRAY (TREE_TYPE (type)));
break;
if (Error_Posted (gnat_entity) && !Has_Alignment_Clause (gnat_entity))
return align;
- /* Post the error on the alignment clause if any. */
+ /* Post the error on the alignment clause if any. Note, for the implicit
+ base type of an array type, the alignment clause is on the first
+ subtype. */
if (Present (Alignment_Clause (gnat_entity)))
gnat_error_node = Expression (Alignment_Clause (gnat_entity));
+
+ else if (Is_Itype (gnat_entity)
+ && Is_Array_Type (gnat_entity)
+ && Etype (gnat_entity) == gnat_entity
+ && Present (Alignment_Clause (First_Subtype (gnat_entity))))
+ gnat_error_node =
+ Expression (Alignment_Clause (First_Subtype (gnat_entity)));
+
else
gnat_error_node = gnat_entity;
else if (!(Present (Alignment_Clause (gnat_entity))
&& From_At_Mod (Alignment_Clause (gnat_entity)))
&& new_align * BITS_PER_UNIT < align)
- post_error_ne_num ("alignment for& must be at least ^",
- gnat_error_node, gnat_entity,
- align / BITS_PER_UNIT);
+ {
+ unsigned int double_align;
+ bool is_capped_double, align_clause;
+
+ /* If the default alignment of "double" or larger scalar types is
+ specifically capped and the new alignment is above the cap, do
+ not post an error and change the alignment only if there is an
+ alignment clause; this makes it possible to have the associated
+ GCC type overaligned by default for performance reasons. */
+ if ((double_align = double_float_alignment) > 0)
+ {
+ Entity_Id gnat_type
+ = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
+ is_capped_double
+ = is_double_float_or_array (gnat_type, &align_clause);
+ }
+ else if ((double_align = double_scalar_alignment) > 0)
+ {
+ Entity_Id gnat_type
+ = Is_Type (gnat_entity) ? gnat_entity : Etype (gnat_entity);
+ is_capped_double
+ = is_double_scalar_or_array (gnat_type, &align_clause);
+ }
+ else
+ is_capped_double = align_clause = false;
+
+ if (is_capped_double && new_align >= double_align)
+ {
+ if (align_clause)
+ align = new_align * BITS_PER_UNIT;
+ }
+ else
+ {
+ if (is_capped_double)
+ align = double_align * BITS_PER_UNIT;
+
+ post_error_ne_num ("alignment for& must be at least ^",
+ gnat_error_node, gnat_entity,
+ align / BITS_PER_UNIT);
+ }
+ }
else
{
new_align = (new_align > 0 ? new_align * BITS_PER_UNIT : 1);
OBJECT is either a type or a decl. */
if (TYPE_P (object))
{
+ /* If this is an anonymous base type, nothing to check. Error will be
+ reported on the source type. */
+ if (!Comes_From_Source (gnat_entity))
+ return;
+
mode = TYPE_MODE (object);
align = TYPE_ALIGN (object);
size = TYPE_SIZE (object);
return 1;
}
\f
-/* Given a type T, a FIELD_DECL F, and a replacement value R, return a new
- type with all size expressions that contain F updated by replacing F
- with R. If F is NULL_TREE, always make a new RECORD_TYPE, even if
- nothing has changed. */
+/* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
+ and RECORD_TYPE is the type of the parent. If SIZE is nonzero, it is the
+ specified size for this field. POS_LIST is a position list describing
+ the layout of OLD_FIELD and SUBST_LIST a substitution list to be applied
+ to this layout. */
+
+static tree
+create_field_decl_from (tree old_field, tree field_type, tree record_type,
+ tree size, tree pos_list, tree subst_list)
+{
+ tree t = TREE_VALUE (purpose_member (old_field, pos_list));
+ tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
+ unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
+ tree new_pos, new_field;
+
+ if (CONTAINS_PLACEHOLDER_P (pos))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
+
+ /* If the position is now a constant, we can set it as the position of the
+ field when we make it. Otherwise, we need to deal with it specially. */
+ if (TREE_CONSTANT (pos))
+ new_pos = bit_from_pos (pos, bitpos);
+ else
+ new_pos = NULL_TREE;
+
+ new_field
+ = create_field_decl (DECL_NAME (old_field), field_type, record_type,
+ DECL_PACKED (old_field), size, new_pos,
+ !DECL_NONADDRESSABLE_P (old_field));
+
+ if (!new_pos)
+ {
+ normalize_offset (&pos, &bitpos, offset_align);
+ DECL_FIELD_OFFSET (new_field) = pos;
+ DECL_FIELD_BIT_OFFSET (new_field) = bitpos;
+ SET_DECL_OFFSET_ALIGN (new_field, offset_align);
+ DECL_SIZE (new_field) = size;
+ DECL_SIZE_UNIT (new_field)
+ = convert (sizetype,
+ size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node));
+ layout_decl (new_field, DECL_OFFSET_ALIGN (new_field));
+ }
+
+ DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
+ t = DECL_ORIGINAL_FIELD (old_field);
+ SET_DECL_ORIGINAL_FIELD (new_field, t ? t : old_field);
+ DECL_DISCRIMINANT_NUMBER (new_field) = DECL_DISCRIMINANT_NUMBER (old_field);
+ TREE_THIS_VOLATILE (new_field) = TREE_THIS_VOLATILE (old_field);
+
+ return new_field;
+}
+
+/* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
+
+static tree
+get_rep_part (tree record_type)
+{
+ tree field = TYPE_FIELDS (record_type);
+
+ /* The REP part is the first field, internal, another record, and its name
+ doesn't start with an underscore (i.e. is not generated by the FE). */
+ if (DECL_INTERNAL_P (field)
+ && TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
+ && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
+ return field;
+
+ return NULL_TREE;
+}
+
+/* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
+
+static tree
+get_variant_part (tree record_type)
+{
+ tree field;
+
+ /* The variant part is the only internal field that is a qualified union. */
+ for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+ if (DECL_INTERNAL_P (field)
+ && TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
+ return field;
+
+ return NULL_TREE;
+}
+
+/* Return a new variant part modeled on OLD_VARIANT_PART. VARIANT_LIST is
+ 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. */
+
+static tree
+create_variant_part_from (tree old_variant_part, tree variant_list,
+ tree record_type, tree pos_list, tree subst_list)
+{
+ tree offset = DECL_FIELD_OFFSET (old_variant_part);
+ tree bitpos = DECL_FIELD_BIT_OFFSET (old_variant_part);
+ tree old_union_type = TREE_TYPE (old_variant_part);
+ tree new_union_type, new_variant_part, t;
+ tree union_field_list = NULL_TREE;
+
+ /* First create the type of the variant part from that of the old one. */
+ new_union_type = make_node (QUAL_UNION_TYPE);
+ TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
+
+ /* 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 && TREE_CODE (bitpos) == INTEGER_CST)
+ {
+ tree first_bit = bit_from_pos (offset, bitpos);
+ TYPE_SIZE (new_union_type)
+ = size_binop (MINUS_EXPR, TYPE_SIZE (record_type), first_bit);
+ TYPE_SIZE_UNIT (new_union_type)
+ = size_binop (MINUS_EXPR, TYPE_SIZE_UNIT (record_type),
+ byte_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);
+ relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
+ }
+ else
+ copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
+
+ /* Now finish up the new variants and populate the union type. */
+ for (t = variant_list; t; t = TREE_CHAIN (t))
+ {
+ tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
+ tree old_variant, old_variant_subpart, new_variant, field_list;
+
+ /* Skip variants that don't belong to this nesting level. */
+ if (DECL_CONTEXT (old_field) != old_union_type)
+ continue;
+
+ /* Retrieve the list of fields already added to the new variant. */
+ new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ field_list = TYPE_FIELDS (new_variant);
+
+ /* If the old variant had a variant subpart, we need to create a new
+ variant subpart and add it to the field list. */
+ old_variant = TREE_PURPOSE (t);
+ old_variant_subpart = get_variant_part (old_variant);
+ if (old_variant_subpart)
+ {
+ tree new_variant_subpart
+ = create_variant_part_from (old_variant_subpart, variant_list,
+ new_variant, pos_list, subst_list);
+ TREE_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, NULL,
+ true, false, Empty);
+
+ new_field
+ = create_field_decl_from (old_field, new_variant, new_union_type,
+ TYPE_SIZE (new_variant),
+ pos_list, subst_list);
+ DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
+ DECL_INTERNAL_P (new_field) = 1;
+ TREE_CHAIN (new_field) = union_field_list;
+ 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. */
+ 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, NULL,
+ true, false, Empty);
+
+ new_variant_part
+ = create_field_decl_from (old_variant_part, new_union_type, record_type,
+ TYPE_SIZE (new_union_type),
+ pos_list, subst_list);
+ DECL_INTERNAL_P (new_variant_part) = 1;
+
+ /* With multiple discriminants it is possible for an inner variant to be
+ statically selected while outer ones are not; in this case, the list
+ of fields of the inner variant is not flattened and we end up with a
+ qualified union with a single member. Drop the useless container. */
+ if (!TREE_CHAIN (union_field_list))
+ {
+ DECL_CONTEXT (union_field_list) = record_type;
+ DECL_FIELD_OFFSET (union_field_list)
+ = DECL_FIELD_OFFSET (new_variant_part);
+ DECL_FIELD_BIT_OFFSET (union_field_list)
+ = DECL_FIELD_BIT_OFFSET (new_variant_part);
+ SET_DECL_OFFSET_ALIGN (union_field_list,
+ DECL_OFFSET_ALIGN (new_variant_part));
+ new_variant_part = union_field_list;
+ }
+
+ return new_variant_part;
+}
+
+/* Copy the size (and alignment and alias set) from OLD_TYPE to NEW_TYPE,
+ which are both RECORD_TYPE, after applying the substitutions described
+ in SUBST_LIST. */
+
+static void
+copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
+{
+ tree t;
+
+ 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);
+ relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ TYPE_SIZE (new_type)
+ = SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t));
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ TYPE_SIZE_UNIT (new_type)
+ = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t));
+
+ if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
+ for (t = subst_list; t; t = TREE_CHAIN (t))
+ SET_TYPE_ADA_SIZE
+ (new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
+ TREE_PURPOSE (t),
+ TREE_VALUE (t)));
+
+ /* Finalize the size. */
+ TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
+ TYPE_SIZE_UNIT (new_type) = variable_size (TYPE_SIZE_UNIT (new_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.
+
+ 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
+ value R must itself contain a PLACEHOLDER_EXPR. */
tree
substitute_in_type (tree t, tree f, tree r)
{
- tree new = t;
- tree tem;
+ tree nt;
+
+ gcc_assert (CONTAINS_PLACEHOLDER_P (r));
switch (TREE_CODE (t))
{
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
- if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
- || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
+ case REAL_TYPE:
+
+ /* First the domain types of arrays. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_GCC_MIN_VALUE (t))
+ || CONTAINS_PLACEHOLDER_P (TYPE_GCC_MAX_VALUE (t)))
{
- tree low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
- tree high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
+ tree low = SUBSTITUTE_IN_EXPR (TYPE_GCC_MIN_VALUE (t), f, r);
+ tree high = SUBSTITUTE_IN_EXPR (TYPE_GCC_MAX_VALUE (t), f, r);
- if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
+ if (low == TYPE_GCC_MIN_VALUE (t) && high == TYPE_GCC_MAX_VALUE (t))
return t;
- new = build_range_type (TREE_TYPE (t), low, high);
- if (TYPE_INDEX_TYPE (t))
+ nt = copy_type (t);
+ TYPE_GCC_MIN_VALUE (nt) = low;
+ TYPE_GCC_MAX_VALUE (nt) = high;
+
+ if (TREE_CODE (t) == INTEGER_TYPE && TYPE_INDEX_TYPE (t))
SET_TYPE_INDEX_TYPE
- (new, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
- return new;
- }
+ (nt, substitute_in_type (TYPE_INDEX_TYPE (t), f, r));
- return t;
+ return nt;
+ }
- case REAL_TYPE:
- if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
- || CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
+ /* Then the subtypes. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_RM_MIN_VALUE (t))
+ || CONTAINS_PLACEHOLDER_P (TYPE_RM_MAX_VALUE (t)))
{
- tree low = NULL_TREE, high = NULL_TREE;
+ tree low = SUBSTITUTE_IN_EXPR (TYPE_RM_MIN_VALUE (t), f, r);
+ tree high = SUBSTITUTE_IN_EXPR (TYPE_RM_MAX_VALUE (t), f, r);
- if (TYPE_MIN_VALUE (t))
- low = SUBSTITUTE_IN_EXPR (TYPE_MIN_VALUE (t), f, r);
- if (TYPE_MAX_VALUE (t))
- high = SUBSTITUTE_IN_EXPR (TYPE_MAX_VALUE (t), f, r);
-
- if (low == TYPE_MIN_VALUE (t) && high == TYPE_MAX_VALUE (t))
+ if (low == TYPE_RM_MIN_VALUE (t) && high == TYPE_RM_MAX_VALUE (t))
return t;
- t = copy_type (t);
- TYPE_MIN_VALUE (t) = low;
- TYPE_MAX_VALUE (t) = high;
+ nt = copy_type (t);
+ SET_TYPE_RM_MIN_VALUE (nt, low);
+ SET_TYPE_RM_MAX_VALUE (nt, high);
+
+ return nt;
}
+
return t;
case COMPLEX_TYPE:
- tem = substitute_in_type (TREE_TYPE (t), f, r);
- if (tem == TREE_TYPE (t))
+ nt = substitute_in_type (TREE_TYPE (t), f, r);
+ if (nt == TREE_TYPE (t))
return t;
- return build_complex_type (tem);
+ return build_complex_type (nt);
case OFFSET_TYPE:
case METHOD_TYPE:
case FUNCTION_TYPE:
case LANG_TYPE:
- /* Don't know how to do these yet. */
+ /* These should never show up here. */
gcc_unreachable ();
case ARRAY_TYPE:
if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
return t;
- new = build_array_type (component, domain);
- TYPE_SIZE (new) = 0;
- TYPE_NONALIASED_COMPONENT (new) = TYPE_NONALIASED_COMPONENT (t);
- TYPE_MULTI_ARRAY_P (new) = TYPE_MULTI_ARRAY_P (t);
- TYPE_CONVENTION_FORTRAN_P (new) = TYPE_CONVENTION_FORTRAN_P (t);
- layout_type (new);
- TYPE_ALIGN (new) = TYPE_ALIGN (t);
- TYPE_USER_ALIGN (new) = TYPE_USER_ALIGN (t);
-
- /* If we had bounded the sizes of T by a constant, bound the sizes of
- NEW by the same constant. */
- if (TREE_CODE (TYPE_SIZE (t)) == MIN_EXPR)
- TYPE_SIZE (new)
- = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE (t), 1),
- TYPE_SIZE (new));
- if (TREE_CODE (TYPE_SIZE_UNIT (t)) == MIN_EXPR)
- TYPE_SIZE_UNIT (new)
- = size_binop (MIN_EXPR, TREE_OPERAND (TYPE_SIZE_UNIT (t), 1),
- TYPE_SIZE_UNIT (new));
- return new;
+ nt = build_array_type (component, domain);
+ 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);
+ return nt;
}
case RECORD_TYPE:
case UNION_TYPE:
case QUAL_UNION_TYPE:
{
+ bool changed_field = false;
tree field;
- bool changed_field
- = (f == NULL_TREE && !TREE_CONSTANT (TYPE_SIZE (t)));
- bool field_has_rep = false;
- tree last_field = NULL_TREE;
-
- tree new = copy_type (t);
/* Start out with no fields, make new fields, and chain them
in. If we haven't actually changed the type of any field,
discard everything we've done and return the old type. */
-
- TYPE_FIELDS (new) = NULL_TREE;
- TYPE_SIZE (new) = NULL_TREE;
+ nt = copy_type (t);
+ TYPE_FIELDS (nt) = NULL_TREE;
for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
{
- tree new_field = copy_node (field);
-
- TREE_TYPE (new_field)
- = substitute_in_type (TREE_TYPE (new_field), f, r);
-
- if (DECL_HAS_REP_P (field) && !DECL_INTERNAL_P (field))
- field_has_rep = true;
- else if (TREE_TYPE (new_field) != TREE_TYPE (field))
- changed_field = true;
-
- /* If this is an internal field and the type of this field is
- a UNION_TYPE or RECORD_TYPE with no elements, ignore it. If
- the type just has one element, treat that as the field.
- But don't do this if we are processing a QUAL_UNION_TYPE. */
- if (TREE_CODE (t) != QUAL_UNION_TYPE
- && DECL_INTERNAL_P (new_field)
- && (TREE_CODE (TREE_TYPE (new_field)) == UNION_TYPE
- || TREE_CODE (TREE_TYPE (new_field)) == RECORD_TYPE))
+ tree new_field = copy_node (field), new_n;
+
+ new_n = substitute_in_type (TREE_TYPE (field), f, r);
+ if (new_n != TREE_TYPE (field))
{
- if (!TYPE_FIELDS (TREE_TYPE (new_field)))
- continue;
+ TREE_TYPE (new_field) = new_n;
+ changed_field = true;
+ }
- if (!TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (new_field))))
- {
- tree next_new_field
- = copy_node (TYPE_FIELDS (TREE_TYPE (new_field)));
+ new_n = SUBSTITUTE_IN_EXPR (DECL_FIELD_OFFSET (field), f, r);
+ if (new_n != DECL_FIELD_OFFSET (field))
+ {
+ DECL_FIELD_OFFSET (new_field) = new_n;
+ changed_field = true;
+ }
- /* Make sure omitting the union doesn't change
- the layout. */
- DECL_ALIGN (next_new_field) = DECL_ALIGN (new_field);
- new_field = next_new_field;
+ /* Do the substitution inside the qualifier, if any. */
+ if (TREE_CODE (t) == QUAL_UNION_TYPE)
+ {
+ new_n = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
+ if (new_n != DECL_QUALIFIER (field))
+ {
+ DECL_QUALIFIER (new_field) = new_n;
+ changed_field = true;
}
}
- DECL_CONTEXT (new_field) = new;
+ DECL_CONTEXT (new_field) = nt;
SET_DECL_ORIGINAL_FIELD (new_field,
(DECL_ORIGINAL_FIELD (field)
? DECL_ORIGINAL_FIELD (field) : field));
- /* If the size of the old field was set at a constant,
- propagate the size in case the type's size was variable.
- (This occurs in the case of a variant or discriminated
- record with a default size used as a field of another
- record.) */
- DECL_SIZE (new_field)
- = TREE_CODE (DECL_SIZE (field)) == INTEGER_CST
- ? DECL_SIZE (field) : NULL_TREE;
- DECL_SIZE_UNIT (new_field)
- = TREE_CODE (DECL_SIZE_UNIT (field)) == INTEGER_CST
- ? DECL_SIZE_UNIT (field) : NULL_TREE;
-
- if (TREE_CODE (t) == QUAL_UNION_TYPE)
- {
- tree new_q = SUBSTITUTE_IN_EXPR (DECL_QUALIFIER (field), f, r);
-
- if (new_q != DECL_QUALIFIER (new_field))
- changed_field = true;
-
- /* Do the substitution inside the qualifier and if we find
- that this field will not be present, omit it. */
- DECL_QUALIFIER (new_field) = new_q;
-
- if (integer_zerop (DECL_QUALIFIER (new_field)))
- continue;
- }
-
- if (!last_field)
- TYPE_FIELDS (new) = new_field;
- else
- TREE_CHAIN (last_field) = new_field;
-
- last_field = new_field;
-
- /* If this is a qualified type and this field will always be
- present, we are done. */
- if (TREE_CODE (t) == QUAL_UNION_TYPE
- && integer_onep (DECL_QUALIFIER (new_field)))
- break;
+ TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
+ TYPE_FIELDS (nt) = new_field;
}
- /* If this used to be a qualified union type, but we now know what
- field will be present, make this a normal union. */
- if (changed_field && TREE_CODE (new) == QUAL_UNION_TYPE
- && (!TYPE_FIELDS (new)
- || integer_onep (DECL_QUALIFIER (TYPE_FIELDS (new)))))
- TREE_SET_CODE (new, UNION_TYPE);
- else if (!changed_field)
+ if (!changed_field)
return t;
- gcc_assert (!field_has_rep);
- layout_type (new);
-
- /* If the size was originally a constant use it. */
- if (TYPE_SIZE (t) && TREE_CODE (TYPE_SIZE (t)) == INTEGER_CST
- && TREE_CODE (TYPE_SIZE (new)) != INTEGER_CST)
- {
- TYPE_SIZE (new) = TYPE_SIZE (t);
- TYPE_SIZE_UNIT (new) = TYPE_SIZE_UNIT (t);
- SET_TYPE_ADA_SIZE (new, TYPE_ADA_SIZE (t));
- }
-
- return new;
+ TYPE_FIELDS (nt) = nreverse (TYPE_FIELDS (nt));
+ TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
+ TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
+ SET_TYPE_ADA_SIZE (nt, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (t), f, r));
+ return nt;
}
default:
}
}
\f
-/* Return the "RM size" of GNU_TYPE. This is the actual number of bits
+/* Return the RM size of GNU_TYPE. This is the actual number of bits
needed to represent the object. */
tree
rm_size (tree gnu_type)
{
- /* For integer types, this is the precision. For record types, we store
- the size explicitly. For other types, this is just the size. */
-
+ /* For integral types, we store the RM size explicitly. */
if (INTEGRAL_TYPE_P (gnu_type) && TYPE_RM_SIZE (gnu_type))
return TYPE_RM_SIZE (gnu_type);
- else if (TREE_CODE (gnu_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- /* Return the rm_size of the actual data plus the size of the template. */
+
+ /* Return the RM size of the actual data plus the size of the template. */
+ if (TREE_CODE (gnu_type) == RECORD_TYPE
+ && TYPE_CONTAINS_TEMPLATE_P (gnu_type))
return
size_binop (PLUS_EXPR,
rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
DECL_SIZE (TYPE_FIELDS (gnu_type)));
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
- && !TYPE_IS_FAT_POINTER_P (gnu_type)
- && TYPE_ADA_SIZE (gnu_type))
+
+ /* For record types, we store the size explicitly. */
+ if ((TREE_CODE (gnu_type) == RECORD_TYPE
+ || TREE_CODE (gnu_type) == UNION_TYPE
+ || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
+ && !TYPE_FAT_POINTER_P (gnu_type)
+ && TYPE_ADA_SIZE (gnu_type))
return TYPE_ADA_SIZE (gnu_type);
- else
- return TYPE_SIZE (gnu_type);
+
+ /* For other types, this is just the size. */
+ return TYPE_SIZE (gnu_type);
}
\f
+/* Return the name to be used for GNAT_ENTITY. If a type, create a
+ fully-qualified name, possibly with type information encoding.
+ Otherwise, return the name. */
+
+tree
+get_entity_name (Entity_Id gnat_entity)
+{
+ Get_Encoded_Name (gnat_entity);
+ return get_identifier_with_length (Name_Buffer, Name_Len);
+}
+
/* Return an identifier representing the external name to be used for
GNAT_ENTITY. If SUFFIX is specified, the name is followed by "___"
and the specified suffix. */
{
Entity_Kind kind = Ekind (gnat_entity);
- const char *str = (!suffix ? "" : suffix);
- String_Template temp = {1, strlen (str)};
- Fat_Pointer fp = {str, &temp};
-
- Get_External_Name_With_Suffix (gnat_entity, fp);
+ if (suffix)
+ {
+ String_Template temp = {1, strlen (suffix)};
+ Fat_Pointer fp = {suffix, &temp};
+ Get_External_Name_With_Suffix (gnat_entity, fp);
+ }
+ else
+ Get_External_Name (gnat_entity, 0);
- /* A variable using the Stdcall convention (meaning we are running
- on a Windows box) live in a DLL. Here we adjust its name to use
- the jump-table, the _imp__NAME contains the address for the NAME
- variable. */
+ /* A variable using the Stdcall convention lives in a DLL. We adjust
+ its name to use the jump table, the _imp__NAME contains the address
+ for the NAME variable. */
if ((kind == E_Variable || kind == E_Constant)
&& Has_Stdcall_Convention (gnat_entity))
{
- const char *prefix = "_imp__";
- int k, plen = strlen (prefix);
-
- for (k = 0; k <= Name_Len; k++)
- Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
- strncpy (Name_Buffer, prefix, plen);
+ const int len = 6 + Name_Len;
+ char *new_name = (char *) alloca (len + 1);
+ strcpy (new_name, "_imp__");
+ strcat (new_name, Name_Buffer);
+ return get_identifier_with_length (new_name, len);
}
- return get_identifier (Name_Buffer);
+ return get_identifier_with_length (Name_Buffer, Name_Len);
}
-/* Return the name to be used for GNAT_ENTITY. If a type, create a
- fully-qualified name, possibly with type information encoding.
- Otherwise, return the name. */
-
-tree
-get_entity_name (Entity_Id gnat_entity)
-{
- Get_Encoded_Name (gnat_entity);
- return get_identifier (Name_Buffer);
-}
-
-/* Given GNU_ID, an IDENTIFIER_NODE containing a name and SUFFIX, a
+/* Given GNU_NAME, an IDENTIFIER_NODE containing a name and SUFFIX, a
string, return a new IDENTIFIER_NODE that is the concatenation of
- the name in GNU_ID and SUFFIX. */
+ the name followed by "___" and the specified suffix. */
tree
-concat_id_with_name (tree gnu_id, const char *suffix)
+concat_name (tree gnu_name, const char *suffix)
{
- int len = IDENTIFIER_LENGTH (gnu_id);
-
- strncpy (Name_Buffer, IDENTIFIER_POINTER (gnu_id), len);
- strncpy (Name_Buffer + len, "___", 3);
- len += 3;
- strcpy (Name_Buffer + len, suffix);
- return get_identifier (Name_Buffer);
+ const int len = IDENTIFIER_LENGTH (gnu_name) + 3 + strlen (suffix);
+ char *new_name = (char *) alloca (len + 1);
+ strcpy (new_name, IDENTIFIER_POINTER (gnu_name));
+ strcat (new_name, "___");
+ strcat (new_name, suffix);
+ return get_identifier_with_length (new_name, len);
}
#include "gt-ada-decl.h"
OSDN Git Service
