* *
* 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);
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. */
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. */
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
|| 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)
{
|| TREE_CODE (gnu_type) == VOID_TYPE)
{
gcc_assert (type_annotate_only);
+ if (this_global)
+ force_global--;
return error_mark_node;
}
(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
{
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:
+
+ 1/ This is a constant renaming and we can just make an object
+ with what is renamed as its initial value,
- 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.
+ 2/ We can reuse a stabilized version of what is renamed in place
+ of the renaming,
- Otherwise, make this into a constant pointer to the object we are
- to rename. */
+ 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);
- gnu_size = NULL_TREE;
- used_by_ref = true;
+ /* 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;
+ }
}
}
}
/* 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
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
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;
}
/* 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
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->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),
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))
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;
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. */
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);
}
{
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 and the size of the packed
- array it wraps is the same as that of the field, we can make the field
- the type of the inner object. Note that we may need to do so if the
- record is packed or the field has a component clause, but these cases
- are handled later. */
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
- && TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
- && tree_int_cst_equal (TYPE_SIZE (gnu_field_type),
- TYPE_ADA_SIZE (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;
}
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 FUNCTION_TYPE:
case LANG_TYPE:
/* Don't know how to do these yet. */
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
