* *
* C Implementation File *
* *
- * Copyright (C) 1992-2004, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2006, 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- *
* or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License *
* for more details. You should have received a copy of the GNU General *
* Public License distributed with GNAT; see file COPYING. If not, write *
- * to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, *
- * MA 02111-1307, USA. *
+ * to the Free Software Foundation, 51 Franklin Street, Fifth Floor, *
+ * Boston, MA 02110-1301, USA. *
* *
* GNAT was originally developed by the GNAT team at New York University. *
* Extensive contributions were provided by Ada Core Technologies Inc. *
#include "ggc.h"
#include "obstack.h"
#include "target.h"
+#include "expr.h"
#include "ada.h"
#include "types.h"
#include "ada-tree.h"
#include "gigi.h"
-/* Provide default values for the macros controlling stack checking.
- This is copied from GCC's expr.h. */
+/* Convention_Stdcall should be processed in a specific way on Windows targets
+ only. The macro below is a helper to avoid having to check for a Windows
+ specific attribute throughout this unit. */
-#ifndef STACK_CHECK_BUILTIN
-#define STACK_CHECK_BUILTIN 0
-#endif
-#ifndef STACK_CHECK_PROBE_INTERVAL
-#define STACK_CHECK_PROBE_INTERVAL 4096
-#endif
-#ifndef STACK_CHECK_MAX_FRAME_SIZE
-#define STACK_CHECK_MAX_FRAME_SIZE \
- (STACK_CHECK_PROBE_INTERVAL - UNITS_PER_WORD)
-#endif
-#ifndef STACK_CHECK_MAX_VAR_SIZE
-#define STACK_CHECK_MAX_VAR_SIZE (STACK_CHECK_MAX_FRAME_SIZE / 100)
+#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
+#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
+#else
+#define Has_Stdcall_Convention(E) (0)
#endif
/* These two variables are used to defer recursively expanding incomplete
Entity_Id full_type;
} *defer_incomplete_list = 0;
+/* These two variables are used to defer emission of debug information for
+ nested incomplete record types */
+
+static int defer_debug_level = 0;
+static tree defer_debug_incomplete_list;
+
static void copy_alias_set (tree, tree);
static tree substitution_list (Entity_Id, Entity_Id, tree, bool);
static bool allocatable_size_p (tree, bool);
-static struct attrib *build_attr_list (Entity_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 make_packable_type (tree);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool);
+static bool same_discriminant_p (Entity_Id, Entity_Id);
static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
- bool, bool);
+ bool, bool, bool, bool);
static int compare_field_bitpos (const PTR, const PTR);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree make_type_from_size (tree, tree, bool);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static void check_ok_for_atomic (tree, Entity_Id, bool);
-\f
+static int compatible_signatures_p (tree ftype1, tree ftype2);
+
/* Given GNAT_ENTITY, an entity in the incoming GNAT tree, return a
GCC type corresponding to that entity. GNAT_ENTITY is assumed to
refer to an Ada type. */
/* Convert the ada entity type into a GCC TYPE_DECL node. */
gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
- if (TREE_CODE (gnu_decl) != TYPE_DECL)
- abort ();
-
+ gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
return TREE_TYPE (gnu_decl);
}
\f
DEFINITION is nonzero if this call is intended for a definition. This is
used for separate compilation where it necessary to know whether an
external declaration or a definition should be created if the GCC equivalent
- was not created previously. The value of 1 is normally used for a non-zero
+ was not created previously. The value of 1 is normally used for a nonzero
DEFINITION, but a value of 2 is used in special circumstances, defined in
the code. */
bool saved = false;
/* Nonzero if we incremented defer_incomplete_level. */
bool this_deferred = false;
+ /* Nonzero if we incremented defer_debug_level. */
+ bool debug_deferred = false;
/* Nonzero if we incremented force_global. */
bool this_global = false;
/* Nonzero if we should check to see if elaborated during processing. */
/* This abort means the entity "gnat_entity" has an incorrect scope,
i.e. that its scope does not correspond to the subprogram in which
it is declared */
- abort ();
+ gcc_unreachable ();
}
/* If this is entity 0, something went badly wrong. */
- if (No (gnat_entity))
- abort ();
+ 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.
/* If this is a numeric or enumeral type, or an access type, a nonzero
Esize must be specified unless it was specified by the programmer. */
- if ((IN (kind, Numeric_Kind) || IN (kind, Enumeration_Kind)
- || (IN (kind, Access_Kind)
- && kind != E_Access_Protected_Subprogram_Type
- && kind != E_Access_Subtype))
- && Unknown_Esize (gnat_entity)
- && !Has_Size_Clause (gnat_entity))
- abort ();
+ gcc_assert (!Unknown_Esize (gnat_entity)
+ || Has_Size_Clause (gnat_entity)
+ || (!IN (kind, Numeric_Kind) && !IN (kind, Enumeration_Kind)
+ && (!IN (kind, Access_Kind)
+ || kind == E_Access_Protected_Subprogram_Type
+ || kind == E_Access_Subtype)));
/* Likewise, RM_Size must be specified for all discrete and fixed-point
types. */
- if (IN (kind, Discrete_Or_Fixed_Point_Kind)
- && Unknown_RM_Size (gnat_entity))
- abort ();
+ gcc_assert (!IN (kind, Discrete_Or_Fixed_Point_Kind)
+ || !Unknown_RM_Size (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. */
/* 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. */
- if (!definition && ! Is_Public (gnat_entity)
- && !type_annotate_only
- && kind != E_Discriminant && kind != E_Component
- && kind != E_Label
- && !(kind == E_Constant && Present (Full_View (gnat_entity)))
-#if 1
- && !IN (kind, Type_Kind)
-#endif
- )
- abort ();
+ 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
&& (kind == E_Function || kind == E_Procedure)))
force_global++, this_global = true;
- /* Handle any attributes. */
+ /* Handle any attributes directly attached to the entity. */
if (Has_Gigi_Rep_Item (gnat_entity))
- attr_list = build_attr_list (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);
switch (kind)
{
stored discriminant. Also use Original_Record_Component
if the record has a private extension. */
- if ((Base_Type (gnat_record) == gnat_record
- || Ekind (Scope (gnat_entity)) == E_Private_Subtype
- || Ekind (Scope (gnat_entity)) == E_Record_Subtype_With_Private
- || Ekind (Scope (gnat_entity)) == E_Record_Type_With_Private)
- && Present (Original_Record_Component (gnat_entity))
+ if (Present (Original_Record_Component (gnat_entity))
&& Original_Record_Component (gnat_entity) != gnat_entity)
{
gnu_decl
{
/* A tagged record has no explicit stored discriminants. */
- if (First_Discriminant (gnat_record)
- != First_Stored_Discriminant (gnat_record))
- abort ();
-
+ gcc_assert (First_Discriminant (gnat_record)
+ == First_Stored_Discriminant (gnat_record));
gnu_decl
= gnat_to_gnu_entity (Corresponding_Discriminant (gnat_entity),
gnu_expr, definition);
else if (Present (Corresponding_Discriminant (gnat_entity))
&& (First_Discriminant (gnat_record)
!= First_Stored_Discriminant (gnat_record)))
- abort ();
+ gcc_unreachable ();
/* Otherwise, if we are not defining this and we have no GCC type
for the containing record, make one for it. Then we should
/* Here we have no GCC type and this is a reference rather than a
definition. This should never happen. Most likely the cause is a
reference before declaration in the gnat tree for gnat_entity. */
- abort ();
+ gcc_unreachable ();
}
case E_Loop_Parameter:
|| Present (Renamed_Object (gnat_entity))));
bool inner_const_flag = const_flag;
bool static_p = Is_Statically_Allocated (gnat_entity);
+ bool mutable_p = false;
tree gnu_ext_name = NULL_TREE;
+ tree renamed_obj = NULL_TREE;
if (Present (Renamed_Object (gnat_entity)) && !definition)
{
|| TYPE_IS_DUMMY_P (gnu_type)
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
- if (type_annotate_only)
- return error_mark_node;
- else
- abort ();
+ gcc_assert (type_annotate_only);
+ if (this_global)
+ force_global--;
+ 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 (kind != E_Exception && Known_Alignment (gnat_entity))
+ {
+ gcc_assert (Present (Alignment (gnat_entity)));
+ align = validate_alignment (Alignment (gnat_entity), gnat_entity,
+ TYPE_ALIGN (gnu_type));
+ gnu_type = maybe_pad_type (gnu_type, NULL_TREE, align,
+ gnat_entity, "PAD", 0, definition, 1);
}
/* If we are defining the object, see if it has a Size value and
(Etype
(Expression (Declaration_Node (gnat_entity)))));
else
- gnu_size = max_size (TYPE_SIZE (gnu_type), true);
+ {
+ gnu_size = max_size (TYPE_SIZE (gnu_type), true);
+ mutable_p = true;
+ }
}
/* If the size is zero bytes, make it one byte since some linkers have
&& !Present (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
- /* If an alignment is specified, use it if valid. Note that
- exceptions are objects but don't have alignments. */
- if (kind != E_Exception && Known_Alignment (gnat_entity))
- {
- if (No (Alignment (gnat_entity)))
- abort ();
-
- align = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (gnu_type));
- }
-
/* If this is an atomic object with no specified size and alignment,
but where the size of the type is a constant, set the alignment to
the lowest power of two greater than the size, or to the
{
tree gnu_fat
= TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
- tree gnu_temp_type
- = TREE_TYPE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat))));
gnu_type
- = build_unc_object_type (gnu_temp_type, gnu_type,
+ = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
concat_id_with_name (gnu_entity_id,
"UNC"));
}
(TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))))
gnu_expr = convert (gnu_type, gnu_expr);
- /* See if this is a renaming. If this is a constant renaming, treat
- it as a normal variable whose initial value is what is being
- renamed. We cannot do this if the type is unconstrained or
- class-wide.
+ /* See if this is a renaming, and handle appropriately depending on
+ what is renamed and in which context. There are three major
+ cases:
- Otherwise, if what we are renaming is a reference, we can simply
- return a stabilized version of that reference, after forcing any
- SAVE_EXPRs to be evaluated. But, if this is at global level, we
- can only do this if we know no SAVE_EXPRs will be made.
+ 1/ This is a constant renaming and we can just make an object
+ with what is renamed as its initial value,
- Otherwise, make this into a constant pointer to the object we are
- to rename. */
+ 2/ We can reuse a stabilized version of what is renamed in place
+ of the renaming,
+
+ 3/ If neither 1 or 2 applies, we make the renaming entity a constant
+ pointer to what is being renamed. */
if (Present (Renamed_Object (gnat_entity)))
{
gnu_type = TREE_TYPE (gnu_expr);
}
+ /* Case 1: If this is a constant renaming, treat it as a normal
+ object whose initial value is what is being renamed. We cannot
+ do this if the type is unconstrained or class-wide. */
if (const_flag
+ && !TREE_SIDE_EFFECTS (gnu_expr)
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& TYPE_MODE (gnu_type) != BLKmode
&& Ekind (Etype (gnat_entity)) != E_Class_Wide_Type
&& !Is_Array_Type (Etype (gnat_entity)))
;
- /* If this is a declaration or reference that we can stabilize,
- just use that declaration or reference as this entity unless
- the latter has to be materialized. */
- else if ((DECL_P (gnu_expr)
- || (REFERENCE_CLASS_P (gnu_expr) == tcc_reference))
- && !Materialize_Entity (gnat_entity)
- && (!global_bindings_p ()
- || (staticp (gnu_expr)
- && !TREE_SIDE_EFFECTS (gnu_expr))))
+ /* Otherwise, see if we can proceed with a stabilized version of
+ the renamed entity or if we need to make a pointer. */
+ else
{
- gnu_decl = gnat_stabilize_reference (gnu_expr, true);
- save_gnu_tree (gnat_entity, gnu_decl, true);
- saved = true;
- break;
- }
+ bool stabilized = false;
+ tree maybe_stable_expr = NULL_TREE;
+
+ /* Case 2: If the renaming entity need not be materialized and
+ the renamed expression is something we can stabilize, use
+ that for the renaming. At the global level, we can only do
+ this if we know no SAVE_EXPRs need be made, because the
+ expression we return might be used in arbitrary conditional
+ branches so we must force the SAVE_EXPRs evaluation
+ immediately and this requires a function context. */
+ if (!Materialize_Entity (gnat_entity)
+ && (!global_bindings_p ()
+ || (staticp (gnu_expr)
+ && !TREE_SIDE_EFFECTS (gnu_expr))))
+ {
+ maybe_stable_expr
+ = maybe_stabilize_reference (gnu_expr, true, false,
+ &stabilized);
- /* Otherwise, make this into a constant pointer to the object we
- are to rename.
+ if (stabilized)
+ {
+ gnu_decl = maybe_stable_expr;
+ save_gnu_tree (gnat_entity, gnu_decl, true);
+ saved = true;
+ break;
+ }
- Stabilize it if we are not at the global level since in this
- case the renaming evaluation may directly dereference the
- initial value we make here instead of the pointer we will
- assign it to. We don't want variables in the expression to be
- evaluated every time the renaming is used, since the value of
- these variables may change in between.
+ /* The stabilization failed. Keep maybe_stable_expr
+ untouched here to let the pointer case below know
+ about that failure. */
+ }
- If we are at the global level and the value is not constant,
- create_var_decl generates a mere elaboration assignment and
- does not attach the initial expression to the declaration.
- There is no possible direct initial-value dereference then. */
- else
- {
- inner_const_flag = TREE_READONLY (gnu_expr);
- const_flag = true;
- gnu_type = build_reference_type (gnu_type);
- gnu_expr = build_unary_op (ADDR_EXPR, gnu_type, gnu_expr);
+ /* Case 3: Make this into a constant pointer to the object we
+ are to rename and attach the object to the pointer if it is
+ an lvalue that can be stabilized.
+
+ From the proper scope, attached objects will be referenced
+ directly instead of indirectly via the pointer to avoid
+ subtle aliasing problems with non addressable entities.
+ They have to be stable because we must not evaluate the
+ variables in the expression every time the renaming is used.
+ They also have to be lvalues because the context in which
+ they are reused sometimes requires so. We call pointers
+ with an attached object "renaming" pointers.
+
+ In the rare cases where we cannot stabilize the renamed
+ object, we just make a "bare" pointer, and the renamed
+ entity is always accessed indirectly through it. */
+ {
+ bool expr_has_side_effects = TREE_SIDE_EFFECTS (gnu_expr);
+
+ inner_const_flag = TREE_READONLY (gnu_expr);
+ const_flag = true;
+ gnu_type = build_reference_type (gnu_type);
+
+ /* If a previous attempt at unrestricted stabilization
+ failed, there is no point trying again and we can reuse
+ the result without attaching it to the pointer. */
+ if (maybe_stable_expr)
+ ;
+
+ /* Otherwise, try to stabilize now, restricting to
+ lvalues only, and attach the expression to the pointer
+ if the stabilization succeeds.
+
+ Note that this might introduce SAVE_EXPRs and we don't
+ check whether we're at the global level or not. This is
+ fine since we are building a pointer initializer and
+ neither the pointer nor the initializing expression can
+ be accessed before the pointer elaboration has taken
+ place in a correct program.
+
+ SAVE_EXPRs will be evaluated at the right spots by either
+ create_var_decl->expand_decl_init for the non-global case
+ or build_unit_elab for the global case, and will be
+ attached to the elaboration procedure by the RTL expander
+ in the latter case. We have no need to force an early
+ evaluation here. */
+ else
+ {
+ maybe_stable_expr
+ = maybe_stabilize_reference (gnu_expr, true, true,
+ &stabilized);
+
+ if (stabilized)
+ renamed_obj = maybe_stable_expr;
+ /* Attaching is actually performed downstream, as soon
+ as we have a DECL for the pointer we make. */
+ }
- if (!global_bindings_p ())
- {
- gnu_expr = gnat_stabilize_reference (gnu_expr, true);
- add_stmt (gnu_expr);
- }
+ gnu_expr
+ = build_unary_op (ADDR_EXPR, gnu_type, maybe_stable_expr);
+
+ /* If the initial expression has side effects, we might
+ still have an unstabilized version at this point (for
+ instance if it involves a function call). Wrap the
+ result into a SAVE_EXPR now, in case it happens to be
+ referenced several times. */
+ if (expr_has_side_effects && ! stabilized)
+ gnu_expr = save_expr (gnu_expr);
- gnu_size = NULL_TREE;
- used_by_ref = true;
+ gnu_size = NULL_TREE;
+ used_by_ref = true;
+ }
}
}
}
/* If this is a pointer and it does not have an initializing
- expression, initialize it to NULL, unless the obect is
+ expression, initialize it to NULL, unless the object is
imported. */
if (definition
&& (POINTER_TYPE_P (gnu_type) || TYPE_FAT_POINTER_P (gnu_type))
imported. */
if ((!definition && Present (Address_Clause (gnat_entity)))
|| (Is_Imported (gnat_entity)
- && Convention (gnat_entity) == Convention_Stdcall))
+ && Has_Stdcall_Convention (gnat_entity)))
{
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
+
+ gnu_expr = NULL_TREE;
+ /* No point in taking the address of an initializing expression
+ that isn't going to be used. */
+
used_by_ref = true;
}
If we have a template initializer only (that we made above),
pretend there is none and rely on what build_allocator creates
again anyway. Otherwise (if we have a full initializer), get
- the data part and feed that to build_allocator. */
+ the data part and feed that to build_allocator.
+
+ If we are elaborating a mutable object, tell build_allocator to
+ ignore a possibly simpler size from the initializer, if any, as
+ we must allocate the maximum possible size in this case. */
if (definition)
{
= TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
if (TREE_CODE (gnu_expr) == CONSTRUCTOR
- &&
- TREE_CHAIN (CONSTRUCTOR_ELTS (gnu_expr)) == NULL_TREE)
+ && 1 == VEC_length (constructor_elt,
+ CONSTRUCTOR_ELTS (gnu_expr)))
gnu_expr = 0;
else
gnu_expr
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);
+ gnu_expr = build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
+ 0, 0, gnat_entity, mutable_p);
}
else
{
gnu_new_var
= create_var_decl (create_concat_name (gnat_entity, "ALIGN"),
- NULL_TREE, gnu_new_type, gnu_expr, false,
+ NULL_TREE, gnu_new_type, NULL_TREE, false,
false, false, false, NULL, gnat_entity);
if (gnu_expr)
const_flag = true;
}
+ if (const_flag)
+ gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
+ | TYPE_QUAL_CONST));
+
/* Convert the expression to the type of the object except in the
case where the object's type is unconstrained or the object's type
is a padded record whose field is of self-referential size. In
|| Is_Exported (gnat_entity)))))
gnu_ext_name = create_concat_name (gnat_entity, 0);
- if (const_flag)
- {
- gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
- | TYPE_QUAL_CONST));
- if (gnu_expr)
- gnu_expr = convert (gnu_type, gnu_expr);
- }
-
/* If this is constant initialized to a static constant and the
- object has an aggregrate type, force it to be statically
+ object has an aggregate type, force it to be statically
allocated. */
if (const_flag && gnu_expr && TREE_CONSTANT (gnu_expr)
&& host_integerp (TYPE_SIZE_UNIT (gnu_type), 1)
static_p, attr_list, gnat_entity);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
+ if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
+ {
+ SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
+ DECL_RENAMING_GLOBAL_P (gnu_decl) = global_bindings_p ();
+ }
/* If we have an address clause and we've made this indirect, it's
not enough to merely mark the type as volatile since volatile
SET_DECL_CONST_CORRESPONDING_VAR (gnu_decl, gnu_corr_var);
}
- /* If this is declared in a block that contains an block with an
+ /* If this is declared in a block that contains a block with an
exception handler, we must force this variable in memory to
suppress an invalid optimization. */
if (Has_Nested_Block_With_Handler (Scope (gnat_entity))
- && Exception_Mechanism != GCC_ZCX)
+ && Exception_Mechanism != Back_End_Exceptions)
TREE_ADDRESSABLE (gnu_decl) = 1;
/* Back-annotate the Alignment of the object if not already in the
tree. Likewise for Esize if the object is of a constant size.
But if the "object" is actually a pointer to an object, the
- alignment and size are the same as teh type, so don't back-annotate
+ alignment and size are the same as the type, so don't back-annotate
the values for the pointer. */
if (!used_by_ref && Unknown_Alignment (gnat_entity))
Set_Alignment (gnat_entity,
layout_type (gnu_type);
+ /* Inherit our alias set from what we're a subtype of. Subtypes
+ are not different types and a pointer can designate any instance
+ within a subtype hierarchy. */
+ copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
+
/* If the type we are dealing with is to represent a 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
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, "LJM");
+ TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "JM");
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
+ /* Create 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);
+
/* 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. */
finish_record_type (gnu_type, gnu_field, false, false);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
SET_TYPE_ADA_SIZE (gnu_type, bitsize_int (esize));
+
+ copy_alias_set (gnu_type, gnu_field_type);
}
break;
}
layout_type (gnu_type);
+
+ /* Inherit our alias set from what we're a subtype of, as for
+ integer subtypes. */
+ copy_alias_set (gnu_type, TREE_TYPE (gnu_type));
}
break;
TYPE_READONLY (gnu_template_type) = 1;
/* Make a node for the array. If we are not defining the array
- suppress expanding incomplete types and save the node as the type
- for GNAT_ENTITY. */
+ suppress expanding incomplete types. */
gnu_type = make_node (UNCONSTRAINED_ARRAY_TYPE);
+
if (!definition)
- {
- defer_incomplete_level++;
- this_deferred = this_made_decl = true;
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- saved = 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
if (No (Packed_Array_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
- if (No (Alignment (gnat_entity)))
- abort ();
-
+ gcc_assert (Present (Alignment (gnat_entity)));
TYPE_ALIGN (tem)
= validate_alignment (Alignment (gnat_entity), gnat_entity,
TYPE_ALIGN (tem));
}
/* Abort if packed array with no packed array type field set. */
- else if (Is_Packed (gnat_entity))
- abort ();
+ else
+ gcc_assert (!Is_Packed (gnat_entity));
break;
gnu_type
= build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
gnu_index_type);
+ copy_alias_set (gnu_type, gnu_string_type);
}
break;
|| Present (Record_Extension_Part (record_definition)))
record_definition = Record_Extension_Part (record_definition);
- if (!type_annotate_only && No (Parent_Subtype (gnat_entity)))
- abort ();
+ gcc_assert (type_annotate_only
+ || Present (Parent_Subtype (gnat_entity)));
}
/* Make a node for the record. If we are not defining the record,
- suppress expanding incomplete types and save the node as the type
- for GNAT_ENTITY. We use the same RECORD_TYPE as for a dummy type
- and reset TYPE_DUMMY_P to show it's no longer a dummy.
+ suppress expanding incomplete types. We use the same RECORD_TYPE
+ as for a dummy type and reset TYPE_DUMMY_P to show it's no longer
+ a dummy.
It is very tempting to delay resetting this bit until we are done
with completing the type, e.g. to let possible intermediate
TYPE_PACKED (gnu_type) = packed || has_rep;
if (!definition)
- {
- defer_incomplete_level++;
- this_deferred = true;
- gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- this_made_decl = saved = true;
- }
+ 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. */
else if (Is_Atomic (gnat_entity))
TYPE_ALIGN (gnu_type)
= (esize >= BITS_PER_WORD ? BITS_PER_WORD
- : 1 << ((floor_log2 (esize) - 1) + 1));
+ : 1 << (floor_log2 (esize - 1) + 1));
/* If we have a Parent_Subtype, make a field for the parent. If
this record has rep clauses, force the position to zero. */
if (Present (Parent_Subtype (gnat_entity)))
{
+ Entity_Id gnat_parent = Parent_Subtype (gnat_entity);
tree gnu_parent;
/* A major complexity here is that the parent subtype will
- reference our discriminants. But those must reference
- the parent component of this record. So here we will
- initialize each of those components to a COMPONENT_REF.
- The first operand of that COMPONENT_REF is another
- COMPONENT_REF which will be filled in below, once
- the parent type can be safely built. */
-
+ reference our discriminants in its Discriminant_Constraint
+ list. But those must reference the parent component of this
+ record which is of the parent subtype we have not built yet!
+ To break the circle we first build a dummy COMPONENT_REF which
+ represents the "get to the parent" operation and initialize
+ each of those discriminants to a COMPONENT_REF of the above
+ dummy parent referencing the corresponding discriminant of the
+ 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,
build3 (COMPONENT_REF,
get_unpadded_type (Etype (gnat_field)),
gnu_get_parent,
- gnat_to_gnu_entity (Corresponding_Discriminant
- (gnat_field),
- NULL_TREE, 0),
+ gnat_to_gnu_field_decl (Corresponding_Discriminant
+ (gnat_field)),
NULL_TREE),
true);
- gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_entity));
+ /* Then we build the parent subtype. */
+ 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)))
+ {
+ 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
= create_field_decl (get_identifier
(Get_Name_String (Name_uParent)),
has_rep ? TYPE_SIZE (gnu_parent) : 0,
has_rep ? bitsize_zero_node : 0, 1);
DECL_INTERNAL_P (gnu_field_list) = 1;
-
- TREE_TYPE (gnu_get_parent) = gnu_parent;
TREE_OPERAND (gnu_get_parent, 1) = gnu_field_list;
}
- /* Add the fields for the discriminants into the record. */
- if (!Is_Unchecked_Union (gnat_entity)
- && Has_Discriminants (gnat_entity))
+ /* Make the fields for the discriminants and put them into the record
+ unless it's an Unchecked_Union. */
+ if (Has_Discriminants (gnat_entity))
for (gnat_field = First_Stored_Discriminant (gnat_entity);
Present (gnat_field);
gnat_field = Next_Stored_Discriminant (gnat_field))
gnu_field, NULL_TREE),
true);
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
+ if (!Is_Unchecked_Union (gnat_entity))
+ {
+ TREE_CHAIN (gnu_field) = gnu_field_list;
+ gnu_field_list = gnu_field;
+ }
}
/* Put the discriminants into the record (backwards), so we can
/* Add the listed fields into the record and finish up. */
components_to_record (gnu_type, Component_List (record_definition),
gnu_field_list, packed, definition, NULL,
- false, all_rep);
+ false, all_rep, this_deferred,
+ Is_Unchecked_Union (gnat_entity));
+
+ if (this_deferred)
+ {
+ debug_deferred = true;
+ defer_debug_level++;
+
+ defer_debug_incomplete_list
+ = tree_cons (NULL_TREE, gnu_type,
+ defer_debug_incomplete_list);
+ }
+
+ /* 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 this is an extension type, reset the tree for any
- inherited discriminants. Also remove the PLACEHOLDER_EXPR
- for non-inherited discriminants. */
- if (!Is_Unchecked_Union (gnat_entity)
- && Has_Discriminants (gnat_entity))
- for (gnat_field = First_Stored_Discriminant (gnat_entity);
- Present (gnat_field);
- gnat_field = Next_Stored_Discriminant (gnat_field))
- {
- if (Present (Parent_Subtype (gnat_entity))
- && Present (Corresponding_Discriminant (gnat_field)))
- save_gnu_tree (gnat_field, NULL_TREE, false);
- else
- {
- gnu_field = get_gnu_tree (gnat_field);
- save_gnu_tree (gnat_field, NULL_TREE, false);
- save_gnu_tree (gnat_field, TREE_OPERAND (gnu_field, 1),
- false);
- }
- }
-
/* 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. */
&& Present (Discriminant_Constraint (gnat_entity)))
{
Entity_Id gnat_field;
- Entity_Id gnat_root_type;
tree gnu_field_list = 0;
tree gnu_pos_list
= compute_field_positions (gnu_orig_type, NULL_TREE,
definition);
tree gnu_temp;
- /* If this is a derived type, we may be seeing fields from any
- original records, so add those positions and discriminant
- substitutions to our lists. */
- for (gnat_root_type = gnat_base_type;
- Underlying_Type (Etype (gnat_root_type)) != gnat_root_type;
- gnat_root_type = Underlying_Type (Etype (gnat_root_type)))
- {
- gnu_pos_list
- = compute_field_positions
- (gnat_to_gnu_type (Etype (gnat_root_type)),
- gnu_pos_list, size_zero_node, bitsize_zero_node,
- BIGGEST_ALIGNMENT);
-
- if (Present (Parent_Subtype (gnat_root_type)))
- gnu_subst_list
- = substitution_list (Parent_Subtype (gnat_root_type),
- Empty, gnu_subst_list, definition);
- }
-
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_id;
TYPE_STUB_DECL (gnu_type)
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)
+ if ((Ekind (gnat_field) == E_Component
+ || Ekind (gnat_field) == E_Discriminant)
+ && (Underlying_Type (Scope (Original_Record_Component
+ (gnat_field)))
+ == gnat_base_type)
+ && (No (Corresponding_Discriminant (gnat_field))
+ || !Is_Tagged_Type (gnat_base_type)))
{
tree gnu_old_field
- = gnat_to_gnu_entity
- (Original_Record_Component (gnat_field), NULL_TREE, 0);
+ = gnat_to_gnu_field_decl (Original_Record_Component
+ (gnat_field));
tree gnu_offset
= TREE_VALUE (purpose_member (gnu_old_field,
gnu_pos_list));
save_gnu_tree (gnat_field, gnu_field, false);
}
+ /* Now go through the entities again looking for Itypes that
+ we have not elaborated but should (e.g., Etypes of fields
+ that have Original_Components). */
+ for (gnat_field = First_Entity (gnat_entity);
+ Present (gnat_field); gnat_field = Next_Entity (gnat_field))
+ if ((Ekind (gnat_field) == E_Discriminant
+ || Ekind (gnat_field) == E_Component)
+ && !present_gnu_tree (Etype (gnat_field)))
+ gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
+
finish_record_type (gnu_type, nreverse (gnu_field_list),
true, false);
&& !Is_Unchecked_Union (gnat_base_type))
|| Ekind (gnat_temp) == E_Component)
save_gnu_tree (gnat_temp,
- get_gnu_tree
+ gnat_to_gnu_field_decl
(Original_Record_Component (gnat_temp)), false);
}
break;
/* If we are pointing to an incomplete type whose completion is an
unconstrained array, make a fat pointer type instead of a pointer
to VOID. The two types in our fields will be pointers to VOID and
- will be replaced in update_pointer_to. Similiarly, if the type
+ will be replaced in update_pointer_to. Similarly, if the type
itself is a dummy type or an unconstrained array. Also make
a dummy TYPE_OBJECT_RECORD_TYPE in case we have any thin
pointers to it. */
p->next = defer_incomplete_list;
defer_incomplete_list = p;
}
- else if
- (IN (Ekind (Base_Type (Directly_Designated_Type (gnat_entity))),
- Incomplete_Or_Private_Kind))
- { ;}
+ else if (IN (Ekind (Base_Type
+ (Directly_Designated_Type (gnat_entity))),
+ Incomplete_Or_Private_Kind))
+ ;
else
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
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;
+ /* 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;
Entity_Id gnat_param;
bool inline_flag = Is_Inlined (gnat_entity);
bool public_flag = Is_Public (gnat_entity);
break;
}
+ /* If this subprogram is expectedly bound to a GCC builtin, fetch the
+ corresponding DECL node.
+
+ We still want the parameter associations to take place because the
+ proper generation of calls depends on it (a GNAT parameter without
+ a corresponding GCC tree has a very specific meaning), so we don't
+ just break here. */
+ if (Convention (gnat_entity) == Convention_Intrinsic)
+ gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
+
+ /* ??? What if we don't find the builtin node above ? warn ? err ?
+ In the current state we neither warn nor err, and calls will just
+ be handled as for regular subprograms. */
+
if (kind == E_Function || kind == E_Subprogram_Type)
gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
a function that returns that type. This usage doesn't make
sense anyway, so give an error here. */
if (TYPE_SIZE_UNIT (gnu_return_type)
+ && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
&& TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
{
post_error ("cannot return type whose size overflows",
bool copy_in_copy_out_flag = false;
bool req_by_copy = false, req_by_ref = false;
- /* See if a Mechanism was supplied that forced this
+ /* Builtins are expanded inline and there is no real call sequence
+ involved. so the type expected by the underlying expander is
+ always the type of each argument "as is". */
+ if (gnu_builtin_decl)
+ req_by_copy = 1;
+
+ /* Otherwise, see if a Mechanism was supplied that forced this
parameter to be passed one way or another. */
- if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
+ else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
req_by_copy = true;
else if (Mechanism (gnat_param) == Default)
;
post_error ("unsupported mechanism for&", gnat_param);
/* If this is either a foreign function or if the
- underlying type won't be passed by refererence, strip off
+ 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)
&& (req_by_ref || Has_Foreign_Convention (gnat_entity)
- || !must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
- (gnu_param_type)))))
+ || (!must_pass_by_ref (TREE_TYPE (TYPE_FIELDS
+ (gnu_param_type)))
+ && (req_by_copy
+ || !default_pass_by_ref (TREE_TYPE
+ (TYPE_FIELDS
+ (gnu_param_type)))))))
gnu_param_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
/* If this is an IN parameter it is read-only, so make a variant
{
if (!has_copy_in_out)
{
- if (TREE_CODE (gnu_return_type) != VOID_TYPE)
- abort ();
-
+ gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
gnu_return_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
has_copy_in_out = true;
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),
- false, false);
+ {
+ /* If all types are not complete, defer emission of debug
+ information for this record types. Otherwise, we risk emitting
+ debug information for a dummy type contained in the fields
+ for that record. */
+ finish_record_type (gnu_return_type, nreverse (gnu_field_list),
+ false, defer_incomplete_level);
+
+ if (defer_incomplete_level)
+ {
+ debug_deferred = true;
+ defer_debug_level++;
+
+ defer_debug_incomplete_list
+ = tree_cons (NULL_TREE, gnu_return_type,
+ defer_debug_incomplete_list);
+ }
+ }
/* If we have a CICO list but it has only one entry, we convert
this function into a function that simply returns that one
if (list_length (gnu_return_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_return_list));
-#ifdef _WIN32
- if (Convention (gnat_entity) == Convention_Stdcall)
+ if (Has_Stdcall_Convention (gnat_entity))
{
struct attrib *attr
= (struct attrib *) xmalloc (sizeof (struct attrib));
attr->next = attr_list;
attr->type = ATTR_MACHINE_ATTRIBUTE;
attr->name = get_identifier ("stdcall");
- attr->arg = NULL_TREE;
+ attr->args = NULL_TREE;
attr->error_point = gnat_entity;
attr_list = attr;
}
-#endif
/* Both lists ware built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
if (TREE_CODE (gnu_return_type) == VOID_TYPE)
pure_flag = false;
+ /* The semantics of "pure" in Ada essentially matches that of "const"
+ in the back-end. In particular, both properties are orthogonal to
+ the "nothrow" property. But this is true only if the EH circuitry
+ is explicit in the internal representation of the back-end. If we
+ are to completely hide the EH circuitry from it, we need to declare
+ that calls to pure Ada subprograms that can throw have side effects
+ since they can trigger an "abnormal" transfer of control flow; thus
+ they can be neither "const" nor "pure" in the back-end sense. */
gnu_type
= build_qualified_type (gnu_type,
- (TYPE_QUALS (gnu_type)
- | (TYPE_QUAL_CONST * pure_flag)
- | (TYPE_QUAL_VOLATILE * volatile_flag)));
+ TYPE_QUALS (gnu_type)
+ | (Exception_Mechanism == Back_End_Exceptions
+ ? TYPE_QUAL_CONST * pure_flag : 0)
+ | (TYPE_QUAL_VOLATILE * volatile_flag));
Sloc_to_locus (Sloc (gnat_entity), &input_location);
+ /* If we have a builtin decl for that function, check the signatures
+ compatibilities. If the signatures are compatible, use the builtin
+ decl. If they are not, we expect the checker predicate to have
+ posted the appropriate errors, and just continue with what we have
+ so far. */
+ if (gnu_builtin_decl)
+ {
+ tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
+
+ if (compatible_signatures_p (gnu_type, gnu_builtin_type))
+ {
+ gnu_decl = gnu_builtin_decl;
+ gnu_type = gnu_builtin_type;
+ break;
+ }
+ }
+
/* If 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. */
else if (kind == E_Subprogram_Type)
gnu_decl = create_type_decl (gnu_entity_id, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
+ debug_info_p && !defer_incomplete_level,
+ gnat_entity);
else
{
gnu_decl = create_subprog_decl (gnu_entity_id, gnu_ext_name,
inline_flag, public_flag,
extern_flag, attr_list,
gnat_entity);
+
DECL_STUBBED_P (gnu_decl)
= Convention (gnat_entity) == Convention_Stubbed;
}
compiling, then just get the type from its Etype. */
if (No (Full_View (gnat_entity)))
{
- /* If this is an incomplete type with no full view, it must
- be a Taft Amendement type, so just return a dummy type. */
+ /* If this is an incomplete type with no full view, it must be
+ either a limited view brought in by a limited_with clause, in
+ which case we use the non-limited view, or a Taft Amendement
+ type, in which case we just return a dummy type. */
if (kind == E_Incomplete_Type)
- gnu_type = make_dummy_type (gnat_entity);
+ {
+ if (From_With_Type (gnat_entity)
+ && Present (Non_Limited_View (gnat_entity)))
+ gnu_decl = gnat_to_gnu_entity (Non_Limited_View (gnat_entity),
+ NULL_TREE, 0);
+ else
+ gnu_type = make_dummy_type (gnat_entity);
+ }
- else if (Present (Underlying_Full_View (gnat_entity)))
- gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
- NULL_TREE, 0);
+ else if (Present (Underlying_Full_View (gnat_entity)))
+ gnu_decl = gnat_to_gnu_entity (Underlying_Full_View (gnat_entity),
+ NULL_TREE, 0);
else
{
gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
break;
default:
- abort ();
+ gcc_unreachable ();
}
/* If we had a case where we evaluated another type and it might have
DECL_ARTIFICIAL (gnu_decl) = 1;
if (!debug_info_p && DECL_P (gnu_decl)
- && TREE_CODE (gnu_decl) != FUNCTION_DECL)
+ && TREE_CODE (gnu_decl) != FUNCTION_DECL
+ && No (Renamed_Object (gnat_entity)))
DECL_IGNORED_P (gnu_decl) = 1;
/* If we haven't already, associate the ..._DECL node that we just made with
}
}
+ /* If there are no incomplete types and we have deferred emission
+ of debug information, check whether we have finished defining
+ all nested records.
+ If so, handle the list now. */
+
+ if (debug_deferred)
+ defer_debug_level--;
+
+ if (defer_debug_incomplete_list
+ && !defer_incomplete_level
+ && !defer_debug_level)
+ {
+ tree c, n;
+
+ defer_debug_incomplete_list = nreverse (defer_debug_incomplete_list);
+
+ for (c = defer_debug_incomplete_list; c; c = n)
+ {
+ n = TREE_CHAIN (c);
+ write_record_type_debug_info (TREE_VALUE (c));
+ }
+
+ defer_debug_incomplete_list = 0;
+ }
+
if (this_global)
force_global--;
return gnu_decl;
}
+
+/* Similar, but if the returned value is a COMPONENT_REF, return the
+ FIELD_DECL. */
+
+tree
+gnat_to_gnu_field_decl (Entity_Id gnat_entity)
+{
+ tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+
+ if (TREE_CODE (gnu_field) == COMPONENT_REF)
+ gnu_field = TREE_OPERAND (gnu_field, 1);
+
+ return gnu_field;
+}
+
+/* Return true if DISCR1 and DISCR2 represent the same discriminant. */
+
+static
+bool same_discriminant_p (Entity_Id discr1, Entity_Id discr2)
+{
+ while (Present (Corresponding_Discriminant (discr1)))
+ discr1 = Corresponding_Discriminant (discr1);
+
+ while (Present (Corresponding_Discriminant (discr2)))
+ discr2 = Corresponding_Discriminant (discr2);
+
+ return
+ Original_Record_Component (discr1) == Original_Record_Component (discr2);
+}
\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 constaint error expression
+ /* ??? Tests for avoiding static constraint error expression
is needed until the front stops generating bogus conversions
on bounds of real types. */
static void
copy_alias_set (tree gnu_new_type, tree gnu_old_type)
{
+ /* Remove any padding from GNU_OLD_TYPE. It doesn't matter in the case
+ of a one-dimensional array, since the padding has the same alias set
+ as the field type, but if it's a multi-dimensional array, we need to
+ 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)))
+ gnu_old_type = TREE_TYPE (TYPE_FIELDS (gnu_old_type));
+
+ /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
+ array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
+ so we need to go down to what does. */
+ if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
+ gnu_old_type
+ = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
+
if (TREE_CODE (gnu_new_type) == ARRAY_TYPE
&& TREE_CODE (TREE_TYPE (gnu_new_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_new_type)))
- {
- /* We need to be careful here in case GNU_OLD_TYPE is an unconstrained
- array. In that case, it doesn't have the same shape as GNU_NEW_TYPE,
- so we need to go down to what does. */
- if (TREE_CODE (gnu_old_type) == UNCONSTRAINED_ARRAY_TYPE)
- gnu_old_type
- = TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_old_type))));
-
- copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
- }
+ copy_alias_set (TREE_TYPE (gnu_new_type), TREE_TYPE (gnu_old_type));
TYPE_ALIAS_SET (gnu_new_type) = get_alias_set (gnu_old_type);
record_component_aliases (gnu_new_type);
/* 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 substitions can be in any order. TREE_PURPOSE
+ 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. */
gnat_value = Next_Elmt (gnat_value))
/* Ignore access discriminants. */
if (!Is_Access_Type (Etype (Node (gnat_value))))
- gnu_list = tree_cons (gnat_to_gnu_entity (gnat_discrim, NULL_TREE, 0),
- elaborate_expression
+ 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),
{
Entity_Id gnat_underlying;
tree gnu_type;
+ enum tree_code code;
/* Find a full type for GNAT_TYPE, taking into account any class wide
types. */
return dummy_node_table[gnat_underlying];
/* If this is a record, make this a RECORD_TYPE or UNION_TYPE; else make
- it a VOID_TYPE. */
+ it an ENUMERAL_TYPE. */
if (Is_Record_Type (gnat_underlying))
- gnu_type = make_node (Is_Unchecked_Union (gnat_underlying)
- ? UNION_TYPE : RECORD_TYPE);
+ {
+ Node_Id component_list
+ = Component_List (Type_Definition
+ (Declaration_Node
+ (Implementation_Base_Type (gnat_underlying))));
+ Node_Id component;
+
+ /* Make this a UNION_TYPE unless it's either not an Unchecked_Union or
+ we have a non-discriminant field outside a variant. In either case,
+ it's a RECORD_TYPE. */
+ code = UNION_TYPE;
+ if (!Is_Unchecked_Union (gnat_underlying))
+ code = RECORD_TYPE;
+ else
+ for (component = First_Non_Pragma (Component_Items (component_list));
+ Present (component); component = Next_Non_Pragma (component))
+ if (Ekind (Defining_Entity (component)) == E_Component)
+ code = RECORD_TYPE;
+ }
else
- gnu_type = make_node (ENUMERAL_TYPE);
+ code = ENUMERAL_TYPE;
+ gnu_type = make_node (code);
TYPE_NAME (gnu_type) = get_entity_name (gnat_type);
TYPE_DUMMY_P (gnu_type) = 1;
if (AGGREGATE_TYPE_P (gnu_type))
return (int) our_size == our_size;
}
\f
-/* Return a list of attributes for GNAT_ENTITY, if any. */
+/* Prepend to ATTR_LIST the list of attributes for GNAT_ENTITY, if any. */
-static struct attrib *
-build_attr_list (Entity_Id gnat_entity)
+static void
+prepend_attributes (Entity_Id gnat_entity, struct attrib ** attr_list)
{
- struct attrib *attr_list = 0;
Node_Id gnat_temp;
for (gnat_temp = First_Rep_Item (gnat_entity); Present (gnat_temp);
if (Nkind (gnat_temp) == N_Pragma)
{
struct attrib *attr;
- tree gnu_arg0 = 0, gnu_arg1 = 0;
+ tree gnu_arg0 = NULL_TREE, gnu_arg1 = NULL_TREE;
Node_Id gnat_assoc = Pragma_Argument_Associations (gnat_temp);
enum attr_type etype;
etype = ATTR_LINK_SECTION;
break;
+ case Pragma_Linker_Constructor:
+ etype = ATTR_LINK_CONSTRUCTOR;
+ break;
+
+ case Pragma_Linker_Destructor:
+ etype = ATTR_LINK_DESTRUCTOR;
+ break;
+
case Pragma_Weak_External:
etype = ATTR_WEAK_EXTERNAL;
break;
}
attr = (struct attrib *) xmalloc (sizeof (struct attrib));
- attr->next = attr_list;
+ attr->next = *attr_list;
attr->type = etype;
attr->name = gnu_arg0;
- attr->arg = gnu_arg1;
+
+ /* If we have an argument specified together with an attribute name,
+ make it a single TREE_VALUE entry in a list of arguments, as GCC
+ expects it. */
+ if (gnu_arg1 != NULL_TREE)
+ attr->args = build_tree_list (NULL_TREE, gnu_arg1);
+ else
+ attr->args = NULL_TREE;
+
attr->error_point
= Present (Next (First (gnat_assoc)))
? Expression (Next (First (gnat_assoc))) : gnat_temp;
- attr_list = attr;
+ *attr_list = attr;
}
-
- return attr_list;
}
\f
/* Get the unpadded version of a GNAT type. */
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 discriment, we
+ /* 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)
&& Ekind (Entity (gnat_expr)) == E_Discriminant)))
return 0;
- /* Otherwise, convert this tree to its GCC equivalant. */
+ /* 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);
gnu_decl
= create_var_decl (create_concat_name (gnat_entity,
IDENTIFIER_POINTER (gnu_name)),
- NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true,
- Is_Public (gnat_entity), !definition, false, NULL,
- gnat_entity);
+ NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
+ !need_debug, Is_Public (gnat_entity),
+ !definition, false, NULL, gnat_entity);
/* We only need to use this variable if we are in global context since GCC
can do the right thing in the local case. */
/* The bit position is obtained by "and"ing the alignment minus 1
with the two's complement of the address and multiplying
by the number of bits per unit. Do all this in sizetype. */
-
pos = size_binop (MULT_EXPR,
convert (bitsizetype,
size_binop (BIT_AND_EXPR,
- 1))),
bitsize_unit_node);
- field = create_field_decl (get_identifier ("F"), type, record_type,
- 1, size, pos, 1);
- DECL_BIT_FIELD (field) = 0;
+ /* Create the field, with -1 as the 'addressable' indication to avoid the
+ creation of a bitfield. We don't need one, it would have damaging
+ consequences on the alignment computation, and create_field_decl would
+ make one without this special argument, for instance because of the
+ complex position expression. */
+ field = create_field_decl (get_identifier ("F"), type, record_type, 1, size,
+ pos, -1);
finish_record_type (record_type, field, true, false);
TYPE_ALIGN (record_type) = BIGGEST_ALIGNMENT;
DECL_INTERNAL_P (field) = 1;
TYPE_SIZE (record) = size ? size : orig_size;
TYPE_SIZE_UNIT (record)
- = convert (sizetype,
- size_binop (CEIL_DIV_EXPR, TYPE_SIZE (record),
- bitsize_unit_node));
+ = (size ? convert (sizetype,
+ size_binop (CEIL_DIV_EXPR, size, bitsize_unit_node))
+ : TYPE_SIZE_UNIT (type));
+
TYPE_ALIGN (record) = align;
TYPE_IS_PADDING_P (record) = 1;
TYPE_VOLATILE (record)
if (size && TREE_CODE (size) != INTEGER_CST && definition)
create_var_decl (concat_id_with_name (name, "XVZ"), NULL_TREE,
- sizetype, TYPE_SIZE (record), false, false, false,
+ bitsizetype, TYPE_SIZE (record), false, false, false,
false, NULL, gnat_entity);
}
break;
default:
- abort ();
+ gcc_unreachable ();
}
result = build_binary_op (TRUTH_ORIF_EXPR, integer_type_node,
{
tree gnu_field_id = get_entity_name (gnat_field);
tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
- tree gnu_orig_field_type = gnu_field_type;
tree gnu_pos = 0;
tree gnu_size = 0;
tree gnu_field;
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
- /* If the field's type is justified modular, the wrapper can prevent
- packing so we make the field the type of the inner object unless the
- situation forbids it. We may not do that when the field is addressable_p,
- typically because in that case this field may later be passed by-ref for
- a formal argument expecting the justification. The condition below
- is then matching the addressable_p code for COMPONENT_REF. */
- if (!Is_Aliased (gnat_field) && flag_strict_aliasing
- && TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type))
- gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
-
- /* If we are packing this record, have a specified size that's smaller than
- that of the field type, or a position is specified, and the field type
- is also a record that's BLKmode and with a small constant size, see if
- we can get a better form of the type that allows more packing. If we
- can, show a size was specified for it if there wasn't one so we know to
- make this a bitfield and avoid making things wider. */
+ /* 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 also a record that's
+ BLKmode and with a small constant size, see if we can get an integral
+ mode form of the type when appropriate. 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 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 references, because
+ GCC does not handle BLKmode bitfields properly.
+
+ 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_MODE (gnu_field_type) == BLKmode
&& host_integerp (TYPE_SIZE (gnu_field_type), 1)
&& compare_tree_int (TYPE_SIZE (gnu_field_type), BIGGEST_ALIGNMENT) <= 0
- && (packed
- || (gnu_size && tree_int_cst_lt (gnu_size,
- TYPE_SIZE (gnu_field_type)))
- || Present (Component_Clause (gnat_field))))
+ && (packed == 1
+ || (gnu_size
+ && tree_int_cst_lt (gnu_size, TYPE_SIZE (gnu_field_type)))
+ || (Present (Component_Clause (gnat_field)) && gnu_size != 0)))
{
- gnu_field_type = make_packable_type (gnu_field_type);
-
- if (gnu_field_type != gnu_orig_field_type && !gnu_size)
- gnu_size = rm_size (gnu_field_type);
+ /* See what the alternate type and size would be. */
+ tree gnu_packable_type = make_packable_type (gnu_field_type);
+
+ bool has_byte_aligned_clause
+ = Present (Component_Clause (gnat_field))
+ && (UI_To_Int (Component_Bit_Offset (gnat_field))
+ % BITS_PER_UNIT == 0);
+
+ /* Compute whether we should avoid the substitution. */
+ int 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)
+ {
+ gnu_field_type = gnu_packable_type;
+
+ if (gnu_size == 0)
+ gnu_size = rm_size (gnu_field_type);
+ }
}
/* If we are packing the record and the field is BLKmode, round the
consistent with the alignment. */
if (needs_strict_alignment)
{
- tree gnu_min_size = round_up (rm_size (gnu_field_type),
- TYPE_ALIGN (gnu_field_type));
+ tree gnu_rounded_size = round_up (rm_size (gnu_field_type),
+ TYPE_ALIGN (gnu_field_type));
TYPE_ALIGN (gnu_record_type)
= MAX (TYPE_ALIGN (gnu_record_type), TYPE_ALIGN (gnu_field_type));
- /* If Atomic, the size must match exactly and if aliased, the size
- must not be less than the rounded size. */
+ /* If Atomic, the size must match exactly that of the field. */
if ((Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
&& !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
{
gnu_size = NULL_TREE;
}
+ /* If Aliased, the size must match exactly the rounded size. We
+ used to be more accommodating here and accept greater sizes, but
+ fully supporting this case on big-endian platforms would require
+ switching to a more involved layout for the field. */
else if (Is_Aliased (gnat_field)
- && gnu_size && tree_int_cst_lt (gnu_size, gnu_min_size))
+ && gnu_size
+ && ! operand_equal_p (gnu_size, gnu_rounded_size, 0))
{
post_error_ne_tree
- ("size of aliased field& too small{, minimum required is ^}",
+ ("size of aliased field& must be ^ bits",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
- gnu_min_size);
+ gnu_rounded_size);
gnu_size = NULL_TREE;
}
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
else
- abort ();
+ gcc_unreachable ();
gnu_pos = NULL_TREE;
}
gnu_pos = NULL_TREE;
else
{
- /* Unless this field is aliased, we can remove any justified
- modular type since it's only needed in the unchecked conversion
- case, which doesn't apply here. */
+ /* If the field's type is justified modular, we would need to remove
+ the wrapper to (better) meet the layout requirements. However we
+ can do so only if the field is not aliased to preserve the unique
+ layout and if the prescribed size is not greater than that of the
+ packed array to preserve the justification. */
if (!needs_strict_alignment
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type))
+ && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
+ && tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
+ <= 0)
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
gnu_field_type
"PAD", false, definition, true);
}
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_CONTAINS_TEMPLATE_P (gnu_field_type))
- abort ();
+ gcc_assert (TREE_CODE (gnu_field_type) != RECORD_TYPE
+ || !TYPE_CONTAINS_TEMPLATE_P (gnu_field_type));
/* Now create the decl for the field. */
gnu_field = create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
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.
+ DEFER_DEBUG, if true, means that the debugging routines should not be
+ called when finishing constructing the record type.
+
+ UNCHECKED_UNION, if tree, means that we are building a type for a record
+ with a Pragma Unchecked_Union.
+
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. */
components_to_record (tree gnu_record_type, Node_Id component_list,
tree gnu_field_list, int packed, bool definition,
tree *p_gnu_rep_list, bool cancel_alignment,
- bool all_rep)
+ bool all_rep, bool defer_debug, bool unchecked_union)
{
Node_Id component_decl;
Entity_Id gnat_field;
Node_Id variant_part;
- Node_Id variant;
tree gnu_our_rep_list = NULL_TREE;
tree gnu_field, gnu_last;
bool layout_with_rep = false;
/* At the end of the component list there may be a variant part. */
variant_part = Variant_Part (component_list);
- /* If this is an unchecked union, each variant must have exactly one
- component, each of which becomes one component of this union. */
- if (TREE_CODE (gnu_record_type) == UNION_TYPE && Present (variant_part))
- for (variant = First_Non_Pragma (Variants (variant_part));
- Present (variant);
- variant = Next_Non_Pragma (variant))
- {
- component_decl
- = First_Non_Pragma (Component_Items (Component_List (variant)));
- gnat_field = Defining_Entity (component_decl);
- gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
- definition);
- TREE_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- save_gnu_tree (gnat_field, gnu_field, false);
- }
-
/* 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
to treat each variant as a record whose elements are created from the
component list for the variant. So here we create the records from the
- lists for the variants and put them all into the QUAL_UNION_TYPE. */
- else if (Present (variant_part))
+ lists for the variants and put them all into the QUAL_UNION_TYPE.
+ If this is an Unchecked_Union, we make a UNION_TYPE instead or
+ use GNU_RECORD_TYPE if there are no fields so far. */
+ if (Present (variant_part))
{
tree gnu_discriminant = gnat_to_gnu (Name (variant_part));
Node_Id variant;
- tree gnu_union_type = make_node (QUAL_UNION_TYPE);
- tree gnu_union_field;
- tree gnu_variant_list = NULL_TREE;
tree gnu_name = TYPE_NAME (gnu_record_type);
tree gnu_var_name
- = concat_id_with_name
- (get_identifier (Get_Name_String (Chars (Name (variant_part)))),
- "XVN");
+ = concat_id_with_name (get_identifier (Get_Name_String
+ (Chars (Name (variant_part)))),
+ "XVN");
+ tree gnu_union_type;
+ tree gnu_union_name;
+ tree gnu_union_field;
+ tree gnu_variant_list = NULL_TREE;
if (TREE_CODE (gnu_name) == TYPE_DECL)
gnu_name = DECL_NAME (gnu_name);
- TYPE_NAME (gnu_union_type)
- = concat_id_with_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
- TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
+ gnu_union_name = concat_id_with_name (gnu_name,
+ IDENTIFIER_POINTER (gnu_var_name));
+
+ if (!gnu_field_list && TREE_CODE (gnu_record_type) == UNION_TYPE)
+ gnu_union_type = gnu_record_type;
+ else
+ {
+
+ gnu_union_type
+ = make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
+
+ TYPE_NAME (gnu_union_type) = gnu_union_name;
+ TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
+ }
for (variant = First_Non_Pragma (Variants (variant_part));
Present (variant);
Get_Variant_Encoding (variant);
gnu_inner_name = get_identifier (Name_Buffer);
TYPE_NAME (gnu_variant_type)
- = concat_id_with_name (TYPE_NAME (gnu_union_type),
+ = concat_id_with_name (gnu_union_name,
IDENTIFIER_POINTER (gnu_inner_name));
/* Set the alignment of the inner type in case we need to make
= TYPE_SIZE_UNIT (gnu_record_type);
}
+ /* Create the record for the variant. Note that we defer emitting
+ debug info for it until after we are sure to actually use it. */
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
- &gnu_our_rep_list, !all_rep_and_size, all_rep);
+ &gnu_our_rep_list, !all_rep_and_size, all_rep,
+ true, unchecked_union);
gnu_qual = choices_to_gnu (gnu_discriminant,
Discrete_Choices (variant));
Set_Present_Expr (variant, annotate_value (gnu_qual));
- gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
- gnu_union_type, 0,
- (all_rep_and_size
- ? TYPE_SIZE (gnu_record_type) : 0),
- (all_rep_and_size
- ? bitsize_zero_node : 0),
- 0);
- DECL_INTERNAL_P (gnu_field) = 1;
- DECL_QUALIFIER (gnu_field) = gnu_qual;
+ /* If this is an Unchecked_Union and we have exactly one field,
+ use that field here. */
+ if (unchecked_union && TYPE_FIELDS (gnu_variant_type)
+ && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
+ gnu_field = TYPE_FIELDS (gnu_variant_type);
+ else
+ {
+ /* Emit debug info for the record. We used to throw away
+ empty records but we no longer do that because we need
+ them to generate complete debug info for the variant;
+ otherwise, the union type definition will be lacking
+ the fields associated with these empty variants. */
+ write_record_type_debug_info (gnu_variant_type);
+
+ gnu_field = create_field_decl (gnu_inner_name, gnu_variant_type,
+ gnu_union_type, 0,
+ (all_rep_and_size
+ ? TYPE_SIZE (gnu_record_type)
+ : 0),
+ (all_rep_and_size
+ ? bitsize_zero_node : 0),
+ 0);
+
+ DECL_INTERNAL_P (gnu_field) = 1;
+
+ if (!unchecked_union)
+ DECL_QUALIFIER (gnu_field) = gnu_qual;
+ }
+
TREE_CHAIN (gnu_field) = gnu_variant_list;
gnu_variant_list = gnu_field;
}
- /* We use to delete the empty variants from the end. However,
- we no longer do that because we need them to generate complete
- debugging information for the variant record. Otherwise,
- the union type definition will be missing the fields associated
- to these empty variants. */
-
/* Only make the QUAL_UNION_TYPE if there are any non-empty variants. */
if (gnu_variant_list)
{
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
all_rep_and_size, false);
+ /* 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. */
+ if (gnu_union_type == gnu_record_type)
+ {
+ gcc_assert (!gnu_field_list && unchecked_union);
+ return;
+ }
+
gnu_union_field
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
packed,
/* 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. Otherwise, sort the fields by bit position
- and put them into their own record if we have any fields without
- rep clauses. */
+ set it and ignore the items. */
if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
*p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
else if (gnu_our_rep_list)
{
+ /* 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);
tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
int i;
- /* Set DECL_SECTION_NAME to increasing integers so we have a
- stable sort. */
for (i = 0, gnu_field = gnu_our_rep_list; gnu_field;
gnu_field = TREE_CHAIN (gnu_field), i++)
- {
- gnu_arr[i] = gnu_field;
- DECL_SECTION_NAME (gnu_field) = size_int (i);
- }
+ gnu_arr[i] = gnu_field;
qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
gnu_our_rep_list = gnu_arr[i];
DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
- DECL_SECTION_NAME (gnu_arr[i]) = NULL_TREE;
}
if (gnu_field_list)
TYPE_ALIGN (gnu_record_type) = 0;
finish_record_type (gnu_record_type, nreverse (gnu_field_list),
- layout_with_rep, false);
+ layout_with_rep, defer_debug);
}
\f
/* Called via qsort from the above. Returns -1, 1, depending on the
- bit positions and ordinals of the two fields. */
+ bit positions and ordinals of the two fields. Use DECL_UID to ensure
+ a stable sort. */
static int
compare_field_bitpos (const PTR rt1, const PTR rt2)
tree *t2 = (tree *) rt2;
if (tree_int_cst_equal (bit_position (*t1), bit_position (*t2)))
- return
- (tree_int_cst_lt (DECL_SECTION_NAME (*t1), DECL_SECTION_NAME (*t2))
- ? -1 : 1);
+ return DECL_UID (*t1) < DECL_UID (*t2) ? -1 : 1;
else if (tree_int_cst_lt (bit_position (*t1), bit_position (*t2)))
return -1;
else
int i;
int size;
- /* If back annotation is suppressed by the front end, return No_Uint */
- if (!Back_Annotate_Rep_Info)
- return No_Uint;
-
/* See if we've already saved the value for this node. */
if (EXPR_P (gnu_size) && TREE_COMPLEXITY (gnu_size))
return (Node_Ref_Or_Val) TREE_COMPLEXITY (gnu_size);
/* For negative values, use NEGATE_EXPR of the supplied value. */
if (tree_int_cst_sgn (gnu_size) < 0)
{
- /* The rediculous code below is to handle the case of the largest
+ /* The ridiculous code below is to handle the case of the largest
negative integer. */
tree negative_size = size_diffop (bitsize_zero_node, gnu_size);
bool adjust = false;
case TRUTH_OR_EXPR: tcode = Truth_Or_Expr; break;
case TRUTH_XOR_EXPR: tcode = Truth_Xor_Expr; break;
case TRUTH_NOT_EXPR: tcode = Truth_Not_Expr; break;
+ case BIT_AND_EXPR: tcode = Bit_And_Expr; break;
case LT_EXPR: tcode = Lt_Expr; break;
case LE_EXPR: tcode = Le_Expr; break;
case GT_EXPR: tcode = Gt_Expr; break;
tree gnu_entry;
Entity_Id gnat_field;
- /* We operate by first making a list of all field and their positions
+ /* 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,
{
tree parent_offset = bitsize_zero_node;
- gnu_entry
- = purpose_member (gnat_to_gnu_entity (gnat_field, NULL_TREE, 0),
- gnu_list);
+ gnu_entry = purpose_member (gnat_to_gnu_field_decl (gnat_field),
+ gnu_list);
if (gnu_entry)
{
Set_Esize (gnat_field,
annotate_value (DECL_SIZE (TREE_PURPOSE (gnu_entry))));
}
- else if (type_annotate_only
- && Is_Tagged_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
gnat_error_point, gnat_entity);
}
\f
+/* Check if FTYPE1 and FTYPE2, two potentially different function type nodes,
+ have compatible signatures so that a call using one type may be safely
+ issued if the actual target function type is the other. Return 1 if it is
+ the case, 0 otherwise, and post errors on the incompatibilities.
+
+ This is used when an Ada subprogram is mapped onto a GCC builtin, to ensure
+ that calls to the subprogram will have arguments suitable for the later
+ underlying builtin expansion. */
+
+static int
+compatible_signatures_p (tree ftype1, tree ftype2)
+{
+ /* As of now, we only perform very trivial tests and consider it's the
+ programmer's responsibility to ensure the type correctness in the Ada
+ declaration, as in the regular Import cases.
+
+ Mismatches typically result in either error messages from the builtin
+ expander, internal compiler errors, or in a real call sequence. This
+ should be refined to issue diagnostics helping error detection and
+ correction. */
+
+ /* Almost fake test, ensuring a use of each argument. */
+ if (ftype1 == ftype2)
+ return 1;
+
+ 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.
This is identical to GCC's substitute_in_type except that it knows about
case INTEGER_TYPE:
case ENUMERAL_TYPE:
case BOOLEAN_TYPE:
- case CHAR_TYPE:
if (CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (t))
|| CONTAINS_PLACEHOLDER_P (TYPE_MAX_VALUE (t)))
{
case OFFSET_TYPE:
case METHOD_TYPE:
- case FILE_TYPE:
- case SET_TYPE:
case FUNCTION_TYPE:
case LANG_TYPE:
/* Don't know how to do these yet. */
- abort ();
+ gcc_unreachable ();
case ARRAY_TYPE:
{
else if (!changed_field)
return t;
- if (field_has_rep)
- abort ();
-
+ gcc_assert (!field_has_rep);
layout_type (new);
/* If the size was originally a constant use it. */
tree
create_concat_name (Entity_Id gnat_entity, const char *suffix)
{
+ Entity_Kind kind = Ekind (gnat_entity);
+
const char *str = (!suffix ? "" : suffix);
String_Template temp = {1, strlen (str)};
Fat_Pointer fp = {str, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
-#ifdef _WIN32
/* 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. */
- {
- Entity_Kind kind = Ekind (gnat_entity);
- const char *prefix = "_imp__";
- int plen = strlen (prefix);
+ if ((kind == E_Variable || kind == E_Constant)
+ && Has_Stdcall_Convention (gnat_entity))
+ {
+ const char *prefix = "_imp__";
+ int k, plen = strlen (prefix);
- if ((kind == E_Variable || kind == E_Constant)
- && Convention (gnat_entity) == Convention_Stdcall)
- {
- int k;
- for (k = 0; k <= Name_Len; k++)
- Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
- strncpy (Name_Buffer, prefix, plen);
- }
- }
-#endif
+ for (k = 0; k <= Name_Len; k++)
+ Name_Buffer [Name_Len - k + plen] = Name_Buffer [Name_Len - k];
+ strncpy (Name_Buffer, prefix, plen);
+ }
return get_identifier (Name_Buffer);
}
OSDN Git Service
