* *
* C Implementation File *
* *
- * Copyright (C) 1992-2010, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2012, 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- *
* *
****************************************************************************/
-/* FIXME: Still need to include rtl.h here (via expr.h) because this file
- actually generates RTL (search for gen_rtx_* in gnat_to_gnu_entity). */
-#undef IN_GCC_FRONTEND
-
#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "toplev.h"
#include "ggc.h"
#include "target.h"
-#include "expr.h"
#include "tree-inline.h"
#include "ada.h"
#include "ada-tree.h"
#include "gigi.h"
-#ifndef MAX_FIXED_MODE_SIZE
-#define MAX_FIXED_MODE_SIZE GET_MODE_BITSIZE (DImode)
-#endif
-
-/* 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. */
+/* "stdcall" and "thiscall" conventions should be processed in a specific way
+ on 32-bit x86/Windows only. The macros below are helpers to avoid having
+ to check for a Windows specific attribute throughout this unit. */
#if TARGET_DLLIMPORT_DECL_ATTRIBUTES
+#ifdef TARGET_64BIT
+#define Has_Stdcall_Convention(E) \
+ (!TARGET_64BIT && Convention (E) == Convention_Stdcall)
+#define Has_Thiscall_Convention(E) \
+ (!TARGET_64BIT && is_cplusplus_method (E))
+#else
#define Has_Stdcall_Convention(E) (Convention (E) == Convention_Stdcall)
+#define Has_Thiscall_Convention(E) (is_cplusplus_method (E))
+#endif
#else
-#define Has_Stdcall_Convention(E) (0)
+#define Has_Stdcall_Convention(E) 0
+#define Has_Thiscall_Convention(E) 0
#endif
-/* Stack realignment for functions with foreign conventions is provided on a
- per back-end basis now, as it is handled by the prologue expanders and not
- as part of the function's body any more. It might be requested by way of a
- dedicated function type attribute on the targets that support it.
-
- We need a way to avoid setting the attribute on the targets that don't
- support it and use FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN for this purpose.
-
- It is defined on targets where the circuitry is available, and indicates
- whether the realignment is needed for 'main'. We use this to decide for
- foreign subprograms as well.
-
- It is not defined on targets where the circuitry is not implemented, and
- we just never set the attribute in these cases.
+/* Stack realignment is necessary for functions with foreign conventions when
+ the ABI doesn't mandate as much as what the compiler assumes - that is, up
+ to PREFERRED_STACK_BOUNDARY.
- Whether it is defined on all targets that would need it in theory is
- not entirely clear. We currently trust the base GCC settings for this
- purpose. */
+ Such realignment can be requested with a dedicated function type attribute
+ on the targets that support it. We define FOREIGN_FORCE_REALIGN_STACK to
+ characterize the situations where the attribute should be set. We rely on
+ compiler configuration settings for 'main' to decide. */
-#ifndef FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
-#define FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN 0
+#ifdef MAIN_STACK_BOUNDARY
+#define FOREIGN_FORCE_REALIGN_STACK \
+ (MAIN_STACK_BOUNDARY < PREFERRED_STACK_BOUNDARY)
+#else
+#define FOREIGN_FORCE_REALIGN_STACK 0
#endif
struct incomplete
static int defer_finalize_level = 0;
static VEC (tree,heap) *defer_finalize_list;
+typedef struct subst_pair_d {
+ tree discriminant;
+ tree replacement;
+} subst_pair;
+
+DEF_VEC_O(subst_pair);
+DEF_VEC_ALLOC_O(subst_pair,heap);
+
+typedef struct variant_desc_d {
+ /* The type of the variant. */
+ tree type;
+
+ /* The associated field. */
+ tree field;
+
+ /* The value of the qualifier. */
+ tree qual;
+
+ /* The type of the variant after transformation. */
+ tree new_type;
+} variant_desc;
+
+DEF_VEC_O(variant_desc);
+DEF_VEC_ALLOC_O(variant_desc,heap);
+
/* A hash table used to cache the result of annotate_value. */
static GTY ((if_marked ("tree_int_map_marked_p"),
param_is (struct tree_int_map))) htab_t annotate_value_cache;
enum attr_type, tree, tree, Node_Id);
static void prepend_attributes (Entity_Id, struct attrib **);
static tree elaborate_expression (Node_Id, Entity_Id, tree, bool, bool, bool);
-static bool is_variable_size (tree);
+static bool type_has_variable_size (tree);
static tree elaborate_expression_1 (tree, Entity_Id, tree, bool, bool);
static tree elaborate_expression_2 (tree, Entity_Id, tree, bool, bool,
unsigned int);
static bool compile_time_known_address_p (Node_Id);
static bool cannot_be_superflat_p (Node_Id);
static bool constructor_address_p (tree);
-static void components_to_record (tree, Node_Id, tree, int, bool, tree *,
- bool, bool, bool, bool, bool);
+static void components_to_record (tree, Node_Id, tree, int, bool, bool, bool,
+ bool, bool, bool, bool, bool, tree, tree *);
static Uint annotate_value (tree);
static void annotate_rep (Entity_Id, tree);
static tree build_position_list (tree, bool, tree, tree, unsigned int, tree);
-static tree build_subst_list (Entity_Id, Entity_Id, bool);
-static tree build_variant_list (tree, tree, tree);
+static VEC(subst_pair,heap) *build_subst_list (Entity_Id, Entity_Id, bool);
+static VEC(variant_desc,heap) *build_variant_list (tree,
+ VEC(subst_pair,heap) *,
+ VEC(variant_desc,heap) *);
static tree validate_size (Uint, tree, Entity_Id, enum tree_code, bool, bool);
static void set_rm_size (Uint, tree, Entity_Id);
static tree make_type_from_size (tree, tree, bool);
static unsigned int validate_alignment (Uint, Entity_Id, unsigned int);
static unsigned int ceil_alignment (unsigned HOST_WIDE_INT);
static void check_ok_for_atomic (tree, Entity_Id, bool);
-static int compatible_signatures_p (tree, tree);
-static tree create_field_decl_from (tree, tree, tree, tree, tree, tree);
+static tree create_field_decl_from (tree, tree, tree, tree, tree,
+ VEC(subst_pair,heap) *);
+static tree create_rep_part (tree, tree, tree);
static tree get_rep_part (tree);
-static tree get_variant_part (tree);
-static tree create_variant_part_from (tree, tree, tree, tree, tree);
-static void copy_and_substitute_in_size (tree, tree, tree);
+static tree create_variant_part_from (tree, VEC(variant_desc,heap) *, tree,
+ tree, VEC(subst_pair,heap) *);
+static void copy_and_substitute_in_size (tree, tree, VEC(subst_pair,heap) *);
static void rest_of_type_decl_compilation_no_defer (tree);
+
+/* The relevant constituents of a subprogram binding to a GCC builtin. Used
+ to pass around calls performing profile compatibility checks. */
+
+typedef struct {
+ Entity_Id gnat_entity; /* The Ada subprogram entity. */
+ tree ada_fntype; /* The corresponding GCC type node. */
+ tree btin_fntype; /* The GCC builtin function type node. */
+} intrin_binding_t;
+
+static bool intrin_profiles_compatible_p (intrin_binding_t *);
\f
/* Given GNAT_ENTITY, a GNAT defining identifier node, which denotes some Ada
entity, return the equivalent GCC tree for that entity (a ..._DECL node)
another compilation unit) public entities, show we are at global level
for the purpose of computing scopes. Don't do this for components or
discriminants since the relevant test is whether or not the record is
- being defined. */
+ being defined. Don't do this for constants either as we'll look into
+ their defining expression in the local context. */
if (!definition
&& kind != E_Component
&& kind != E_Discriminant
+ && kind != E_Constant
&& Is_Public (gnat_entity)
&& !Is_Statically_Allocated (gnat_entity))
force_global++, this_global = true;
if (esize > max_esize)
esize = max_esize;
}
- else
- esize = LONG_LONG_TYPE_SIZE;
}
switch (kind)
}
/* If we have an external constant that we are not defining, get the
- expression that is was defined to represent. We may throw that
- expression away later if it is not a constant. Do not retrieve the
- expression if it is an aggregate or allocator, because in complex
- instantiation contexts it may not be expanded */
+ expression that is was defined to represent. We may throw it away
+ later if it is not a constant. But do not retrieve the expression
+ if it is an allocator because the designated type might be dummy
+ at this point. */
if (!definition
- && Present (Expression (Declaration_Node (gnat_entity)))
&& !No_Initialization (Declaration_Node (gnat_entity))
- && (Nkind (Expression (Declaration_Node (gnat_entity)))
- != N_Aggregate)
- && (Nkind (Expression (Declaration_Node (gnat_entity)))
- != N_Allocator))
- gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
+ && Present (Expression (Declaration_Node (gnat_entity)))
+ && Nkind (Expression (Declaration_Node (gnat_entity)))
+ != N_Allocator)
+ {
+ bool went_into_elab_proc = false;
+
+ /* The expression may contain N_Expression_With_Actions nodes and
+ thus object declarations from other units. In this case, even
+ though the expression will eventually be discarded since not a
+ constant, the declarations would be stuck either in the global
+ varpool or in the current scope. Therefore we force the local
+ context and create a fake scope that we'll zap at the end. */
+ if (!current_function_decl)
+ {
+ current_function_decl = get_elaboration_procedure ();
+ went_into_elab_proc = true;
+ }
+ gnat_pushlevel ();
+
+ gnu_expr = gnat_to_gnu (Expression (Declaration_Node (gnat_entity)));
+
+ gnat_zaplevel ();
+ if (went_into_elab_proc)
+ current_function_decl = NULL_TREE;
+ }
/* Ignore deferred constant definitions without address clause since
they are processed fully in the front-end. If No_Initialization
&& DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
gnu_type = except_type_node;
- /* For a debug renaming declaration, build a pure debug entity. */
+ /* For a debug renaming declaration, build a debug-only entity. */
if (Present (Debug_Renaming_Link (gnat_entity)))
{
- rtx addr;
+ /* Force a non-null value to make sure the symbol is retained. */
+ tree value = build1 (INDIRECT_REF, gnu_type,
+ build1 (NOP_EXPR,
+ build_pointer_type (gnu_type),
+ integer_minus_one_node));
gnu_decl = build_decl (input_location,
VAR_DECL, gnu_entity_name, gnu_type);
- /* The (MEM (CONST (0))) pattern is prescribed by STABS. */
- if (global_bindings_p ())
- addr = gen_rtx_CONST (VOIDmode, const0_rtx);
- else
- addr = stack_pointer_rtx;
- SET_DECL_RTL (gnu_decl, gen_rtx_MEM (Pmode, addr));
+ SET_DECL_VALUE_EXPR (gnu_decl, value);
+ DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
gnat_pushdecl (gnu_decl, gnat_entity);
break;
}
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));
if (Present (Address_Clause (gnat_entity)))
align = 0;
else
- gnu_type
- = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
- false, false, definition, true);
+ {
+ tree orig_type = gnu_type;
+
+ gnu_type
+ = maybe_pad_type (gnu_type, NULL_TREE, align, gnat_entity,
+ false, false, definition, true);
+
+ /* If a padding record was made, declare it now since it will
+ never be declared otherwise. This is necessary to ensure
+ that its subtrees are properly marked. */
+ if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
+ create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
+ debug_info_p, gnat_entity);
+ }
}
/* If we are defining the object, see if it has a Size and validate it
gnu_size = max_size (TYPE_SIZE (gnu_type), true);
mutable_p = true;
}
+
+ /* If we are at global level and the size isn't constant, call
+ elaborate_expression_1 to make a variable for it rather than
+ calculating it each time. */
+ if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
+ gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
+ get_identifier ("SIZE"),
+ definition, false);
}
/* If the size is zero byte, make it one byte since some linkers have
&& No (Address_Clause (gnat_entity))))
&& TREE_CODE (TYPE_SIZE (gnu_type)) == INTEGER_CST)
{
- /* No point in jumping through all the hoops needed in order
+ unsigned int size_cap, align_cap;
+
+ /* No point in promoting the alignment if this doesn't prevent
+ BLKmode access to the object, in particular block copy, as
+ this will for example disable the NRV optimization for it.
+ No point in jumping through all the hoops needed in order
to support BIGGEST_ALIGNMENT if we don't really have to.
So we cap to the smallest alignment that corresponds to
a known efficient memory access pattern of the target. */
- unsigned int align_cap = Is_Atomic (gnat_entity)
- ? BIGGEST_ALIGNMENT
- : get_mode_alignment (ptr_mode);
+ if (Is_Atomic (gnat_entity))
+ {
+ size_cap = UINT_MAX;
+ align_cap = BIGGEST_ALIGNMENT;
+ }
+ else
+ {
+ size_cap = MAX_FIXED_MODE_SIZE;
+ align_cap = get_mode_alignment (ptr_mode);
+ }
if (!host_integerp (TYPE_SIZE (gnu_type), 1)
- || compare_tree_int (TYPE_SIZE (gnu_type), align_cap) >= 0)
+ || compare_tree_int (TYPE_SIZE (gnu_type), size_cap) > 0)
+ align = 0;
+ else if (compare_tree_int (TYPE_SIZE (gnu_type), align_cap) > 0)
align = align_cap;
else
align = ceil_alignment (tree_low_cst (TYPE_SIZE (gnu_type), 1));
if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
&& Is_Array_Type (Etype (gnat_entity))
&& !type_annotate_only)
- {
- tree gnu_fat
- = TREE_TYPE (gnat_to_gnu_type (Base_Type (Etype (gnat_entity))));
-
- gnu_type
- = build_unc_object_type_from_ptr (gnu_fat, gnu_type,
- concat_name (gnu_entity_name,
- "UNC"),
- debug_info_p);
- }
+ {
+ tree gnu_array
+ = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+ gnu_type
+ = build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
+ gnu_type,
+ concat_name (gnu_entity_name,
+ "UNC"),
+ debug_info_p);
+ }
#ifdef MINIMUM_ATOMIC_ALIGNMENT
/* If the size is a constant and no alignment is specified, force
size of the object. */
gnu_object_size = gnu_size ? gnu_size : TYPE_SIZE (gnu_type);
if (gnu_size || align > 0)
- gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
- false, false, definition,
- gnu_size ? true : false);
+ {
+ tree orig_type = gnu_type;
+
+ gnu_type = maybe_pad_type (gnu_type, gnu_size, align, gnat_entity,
+ false, false, definition,
+ gnu_size ? true : false);
+
+ /* If a padding record was made, declare it now since it will
+ never be declared otherwise. This is necessary to ensure
+ that its subtrees are properly marked. */
+ if (gnu_type != orig_type && !DECL_P (TYPE_NAME (gnu_type)))
+ create_type_decl (TYPE_NAME (gnu_type), gnu_type, NULL, true,
+ debug_info_p, gnat_entity);
+ }
/* If this is a renaming, avoid as much as possible to create a new
object. However, in several cases, creating it is required.
if ((TREE_CODE (gnu_expr) == COMPONENT_REF
&& TYPE_IS_PADDING_P (TREE_TYPE (TREE_OPERAND (gnu_expr, 0))))
/* Strip useless conversions around the object. */
- || (TREE_CODE (gnu_expr) == NOP_EXPR
- && gnat_types_compatible_p
- (TREE_TYPE (gnu_expr),
- TREE_TYPE (TREE_OPERAND (gnu_expr, 0)))))
+ || gnat_useless_type_conversion (gnu_expr))
{
gnu_expr = TREE_OPERAND (gnu_expr, 0);
gnu_type = TREE_TYPE (gnu_expr);
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. */
+ branches so we must force the evaluation of the SAVE_EXPRs
+ immediately and this requires a proper function context.
+ Note that an external constant is at the global level. */
if (!Materialize_Entity (gnat_entity)
- && (!global_bindings_p ()
+ && (!((!definition && kind == E_Constant)
+ || global_bindings_p ())
|| (staticp (gnu_expr)
&& !TREE_SIDE_EFFECTS (gnu_expr))))
{
{
/* ??? No DECL_EXPR is created so we need to mark
the expression manually lest it is shared. */
- if (global_bindings_p ())
+ if ((!definition && kind == E_Constant)
+ || global_bindings_p ())
MARK_VISITED (maybe_stable_expr);
gnu_decl = maybe_stable_expr;
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE,
- false);
+ false, false);
+ /* This assertion will fail if the renamed object
+ isn't aligned enough as to make it possible to
+ honor the alignment set on the renaming. */
+ if (align)
+ {
+ unsigned int renamed_align
+ = DECL_P (gnu_decl)
+ ? DECL_ALIGN (gnu_decl)
+ : TYPE_ALIGN (TREE_TYPE (gnu_decl));
+ gcc_assert (renamed_align >= align);
+ }
break;
}
entity is always accessed indirectly through it. */
else
{
+ /* We need to preserve the volatileness of the renamed
+ object through the indirection. */
+ if (TREE_THIS_VOLATILE (gnu_expr)
+ && !TYPE_VOLATILE (gnu_type))
+ gnu_type
+ = build_qualified_type (gnu_type,
+ (TYPE_QUALS (gnu_type)
+ | TYPE_QUAL_VOLATILE));
gnu_type = build_reference_type (gnu_type);
inner_const_flag = TREE_READONLY (gnu_expr);
const_flag = true;
= TYPE_PADDING_P (gnu_type)
? TYPE_FIELDS (TREE_TYPE (TYPE_FIELDS (gnu_type)))
: TYPE_FIELDS (gnu_type);
- gnu_expr
- = gnat_build_constructor
- (gnu_type,
- tree_cons
- (template_field,
- build_template (TREE_TYPE (template_field),
- TREE_TYPE (TREE_CHAIN (template_field)),
- NULL_TREE),
- NULL_TREE));
+ VEC(constructor_elt,gc) *v = VEC_alloc (constructor_elt, gc, 1);
+ tree t = build_template (TREE_TYPE (template_field),
+ TREE_TYPE (DECL_CHAIN (template_field)),
+ NULL_TREE);
+ CONSTRUCTOR_APPEND_ELT (v, template_field, t);
+ gnu_expr = gnat_build_constructor (gnu_type, v);
}
/* Convert the expression to the type of the object except in the
is a padded record whose field is of self-referential size. In
the former case, converting will generate unnecessary evaluations
of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. */
+ want to only copy the actual data. Also don't convert to a record
+ type with a variant part from a record type without one, to keep
+ the object simpler. */
if (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& !(TYPE_IS_PADDING_P (gnu_type)
&& CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
+ && !(TREE_CODE (gnu_type) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
+ && get_variant_part (gnu_type) != NULL_TREE
+ && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this is a pointer that doesn't have an initializing expression,
gnu_type = build_reference_type (gnu_type);
gnu_size = NULL_TREE;
used_by_ref = true;
- const_flag = true;
/* In case this was a aliased object whose nominal subtype is
unconstrained, the pointer above will be a thin pointer and
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)
+ if (definition && !imported_p)
{
tree gnu_alloc_type = TREE_TYPE (gnu_type);
&& TYPE_CONTAINS_TEMPLATE_P (gnu_alloc_type))
{
gnu_alloc_type
- = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
+ = TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
if (TREE_CODE (gnu_expr) == CONSTRUCTOR
&& 1 == VEC_length (constructor_elt,
gnu_expr
= build_component_ref
(gnu_expr, NULL_TREE,
- TREE_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
+ DECL_CHAIN (TYPE_FIELDS (TREE_TYPE (gnu_expr))),
false);
}
if (TREE_CODE (TYPE_SIZE_UNIT (gnu_alloc_type)) == INTEGER_CST
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type))
- && !Is_Imported (gnat_entity))
+ && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_alloc_type)))
post_error ("?`Storage_Error` will be raised at run time!",
gnat_entity);
gnu_expr
= build_allocator (gnu_alloc_type, gnu_expr, gnu_type,
Empty, Empty, gnat_entity, mutable_p);
+ const_flag = true;
}
else
{
const_flag = true;
}
+ /* If this is an aliased object with an unconstrained nominal subtype,
+ we make its type a thin reference, i.e. the reference counterpart
+ of a thin pointer, so that it points to the array part. This is
+ aimed at making it easier for the debugger to decode the object.
+ Note that we have to do that this late because of the couple of
+ allocation adjustments that might be made just above. */
+ if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && Is_Array_Type (Etype (gnat_entity))
+ && !type_annotate_only)
+ {
+ tree gnu_array
+ = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+
+ /* In case the object with the template has already been allocated
+ just above, we have nothing to do here. */
+ if (!TYPE_IS_THIN_POINTER_P (gnu_type))
+ {
+ gnu_size = NULL_TREE;
+ used_by_ref = true;
+
+ if (definition && !imported_p)
+ {
+ tree gnu_unc_var
+ = create_var_decl (concat_name (gnu_entity_name, "UNC"),
+ NULL_TREE, gnu_type, gnu_expr,
+ const_flag, Is_Public (gnat_entity),
+ false, static_p, NULL, gnat_entity);
+ gnu_expr
+ = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_unc_var);
+ TREE_CONSTANT (gnu_expr) = 1;
+ const_flag = true;
+ }
+ else
+ {
+ gnu_expr = NULL_TREE;
+ const_flag = false;
+ }
+ }
+
+ gnu_type
+ = build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
+ }
+
if (const_flag)
gnu_type = build_qualified_type (gnu_type, (TYPE_QUALS (gnu_type)
| TYPE_QUAL_CONST));
is a padded record whose field is of self-referential size. In
the former case, converting will generate unnecessary evaluations
of the CONSTRUCTOR to compute the size and in the latter case, we
- want to only copy the actual data. */
+ want to only copy the actual data. Also don't convert to a record
+ type with a variant part from a record type without one, to keep
+ the object simpler. */
if (gnu_expr
&& TREE_CODE (gnu_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
&& !(TYPE_IS_PADDING_P (gnu_type)
&& CONTAINS_PLACEHOLDER_P
- (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type))))))
+ (TYPE_SIZE (TREE_TYPE (TYPE_FIELDS (gnu_type)))))
+ && !(TREE_CODE (gnu_type) == RECORD_TYPE
+ && TREE_CODE (TREE_TYPE (gnu_expr)) == RECORD_TYPE
+ && get_variant_part (gnu_type) != NULL_TREE
+ && get_variant_part (TREE_TYPE (gnu_expr)) == NULL_TREE))
gnu_expr = convert (gnu_type, gnu_expr);
/* If this name is external or there was a name specified, use it,
gnat_entity);
DECL_BY_REF_P (gnu_decl) = used_by_ref;
DECL_POINTS_TO_READONLY_P (gnu_decl) = used_by_ref && inner_const_flag;
+ DECL_CAN_NEVER_BE_NULL_P (gnu_decl) = Can_Never_Be_Null (gnat_entity);
/* If we are defining an Out parameter and optimization isn't enabled,
create a fake PARM_DECL for debugging purposes and make it point to
TREE_ADDRESSABLE (gnu_decl) = 1;
}
+ /* If this is a loop parameter, set the corresponding flag. */
+ else if (kind == E_Loop_Parameter)
+ DECL_LOOP_PARM_P (gnu_decl) = 1;
+
/* If this is a renaming pointer, attach the renamed object to it and
- register it if we are at top level. */
- if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
+ register it if we are at the global level. Note that an external
+ constant is at the global level. */
+ else if (TREE_CODE (gnu_decl) == VAR_DECL && renamed_obj)
{
SET_DECL_RENAMED_OBJECT (gnu_decl, renamed_obj);
- if (global_bindings_p ())
+ if ((!definition && kind == E_Constant) || global_bindings_p ())
{
DECL_RENAMING_GLOBAL_P (gnu_decl) = 1;
record_global_renaming_pointer (gnu_decl);
|| (flag_stack_check == GENERIC_STACK_CHECK
&& compare_tree_int (DECL_SIZE_UNIT (gnu_decl),
STACK_CHECK_MAX_VAR_SIZE) > 0)))
- add_stmt_with_node (build_call_1_expr
- (update_setjmp_buf_decl,
+ add_stmt_with_node (build_call_n_expr
+ (update_setjmp_buf_decl, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
get_block_jmpbuf_decl ())),
gnat_entity);
type of the object and not on the object directly, and makes it
possible to support all confirming representation clauses. */
annotate_object (gnat_entity, TREE_TYPE (gnu_decl), gnu_object_size,
- used_by_ref);
+ used_by_ref, false);
}
break;
= create_var_decl (get_entity_name (gnat_literal), NULL_TREE,
gnu_type, gnu_value, true, false, false,
false, NULL, gnat_literal);
-
+ /* Do not generate debug info for individual enumerators. */
+ DECL_IGNORED_P (gnu_literal) = 1;
save_gnu_tree (gnat_literal, gnu_literal, false);
gnu_literal_list = tree_cons (DECL_NAME (gnu_literal),
gnu_value, gnu_literal_list);
/* Note that the bounds are updated at the end of this function
to avoid an infinite recursion since they refer to the type. */
}
- break;
+ goto discrete_type;
case E_Signed_Integer_Type:
case E_Ordinary_Fixed_Point_Type:
/* For integer types, just make a signed type the appropriate number
of bits. */
gnu_type = make_signed_type (esize);
- break;
+ goto discrete_type;
case E_Modular_Integer_Type:
{
gnu_type = gnu_subtype;
}
}
- break;
+ goto discrete_type;
case E_Signed_Integer_Subtype:
case E_Enumeration_Subtype:
gnat_to_gnu_type
(Original_Array_Type (gnat_entity)));
+ discrete_type:
+
/* We have to handle clauses that under-align the type specially. */
if ((Present (Alignment_Clause (gnat_entity))
|| (Is_Packed_Array_Type (gnat_entity)
relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
- /* Don't notify the field as "addressable", since we won't be taking
- it's address and it would prevent create_field_decl from making a
- bitfield. */
+ /* Don't declare the field as addressable since we won't be taking
+ its address and this would prevent create_field_decl from making
+ a bitfield. */
gnu_field
= create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
TYPE_ALIGN (gnu_type) = align;
relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
- /* Don't notify the field as "addressable", since we won't be taking
- it's address and it would prevent create_field_decl from making a
- bitfield. */
+ /* Don't declare the field as addressable since we won't be taking
+ its address and this would prevent create_field_decl from making
+ a bitfield. */
gnu_field
= create_field_decl (get_identifier ("F"), gnu_field_type,
gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
case E_String_Type:
case E_Array_Type:
{
- Entity_Id gnat_index, gnat_name;
const bool convention_fortran_p
= (Convention (gnat_entity) == Convention_Fortran);
const int ndim = Number_Dimensions (gnat_entity);
- tree gnu_template_fields = NULL_TREE;
- tree gnu_template_type = make_node (RECORD_TYPE);
- tree gnu_template_reference;
- tree gnu_ptr_template = build_pointer_type (gnu_template_type);
- tree gnu_fat_type = make_node (RECORD_TYPE);
- tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
- tree *gnu_temp_fields = (tree *) alloca (ndim * sizeof (tree));
- tree gnu_max_size = size_one_node, gnu_max_size_unit, tem;
+ tree gnu_template_type;
+ tree gnu_ptr_template;
+ tree gnu_template_reference, gnu_template_fields, gnu_fat_type;
+ tree *gnu_index_types = XALLOCAVEC (tree, ndim);
+ tree *gnu_temp_fields = XALLOCAVEC (tree, ndim);
+ tree gnu_max_size = size_one_node, gnu_max_size_unit, tem, t;
+ Entity_Id gnat_index, gnat_name;
int index;
+ tree comp_type;
- TYPE_NAME (gnu_template_type)
- = create_concat_name (gnat_entity, "XUB");
+ /* Create the type for the component now, as it simplifies breaking
+ type reference loops. */
+ comp_type
+ = gnat_to_gnu_component_type (gnat_entity, definition, debug_info_p);
+ if (present_gnu_tree (gnat_entity))
+ {
+ /* As a side effect, the type may have been translated. */
+ maybe_present = true;
+ break;
+ }
+
+ /* We complete an existing dummy fat pointer type in place. This both
+ avoids further complex adjustments in update_pointer_to and yields
+ better debugging information in DWARF by leveraging the support for
+ incomplete declarations of "tagged" types in the DWARF back-end. */
+ gnu_type = get_dummy_type (gnat_entity);
+ if (gnu_type && TYPE_POINTER_TO (gnu_type))
+ {
+ gnu_fat_type = TYPE_MAIN_VARIANT (TYPE_POINTER_TO (gnu_type));
+ TYPE_NAME (gnu_fat_type) = NULL_TREE;
+ /* Save the contents of the dummy type for update_pointer_to. */
+ TYPE_POINTER_TO (gnu_type) = copy_type (gnu_fat_type);
+ gnu_ptr_template =
+ TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)));
+ gnu_template_type = TREE_TYPE (gnu_ptr_template);
+ }
+ else
+ {
+ gnu_fat_type = make_node (RECORD_TYPE);
+ gnu_template_type = make_node (RECORD_TYPE);
+ gnu_ptr_template = build_pointer_type (gnu_template_type);
+ }
/* Make a node for the array. If we are not defining the array
suppress expanding incomplete types. */
/* Build the fat pointer type. Use a "void *" object instead of
a pointer to the array type since we don't have the array type
yet (it will reference the fat pointer via the bounds). */
- tem = chainon (chainon (NULL_TREE,
- create_field_decl (get_identifier ("P_ARRAY"),
- ptr_void_type_node,
- gnu_fat_type, NULL_TREE,
- NULL_TREE, 0, 0)),
- create_field_decl (get_identifier ("P_BOUNDS"),
- gnu_ptr_template,
- gnu_fat_type, NULL_TREE,
- NULL_TREE, 0, 0));
-
- /* Make sure we can put this into a register. */
- TYPE_ALIGN (gnu_fat_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
-
- /* Do not emit debug info for this record type since the types of its
- fields are still incomplete at this point. */
- finish_record_type (gnu_fat_type, tem, 0, false);
- TYPE_FAT_POINTER_P (gnu_fat_type) = 1;
+ tem
+ = create_field_decl (get_identifier ("P_ARRAY"), ptr_void_type_node,
+ gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
+ DECL_CHAIN (tem)
+ = create_field_decl (get_identifier ("P_BOUNDS"), gnu_ptr_template,
+ gnu_fat_type, NULL_TREE, NULL_TREE, 0, 0);
+
+ if (COMPLETE_TYPE_P (gnu_fat_type))
+ {
+ /* We are going to lay it out again so reset the alias set. */
+ alias_set_type alias_set = TYPE_ALIAS_SET (gnu_fat_type);
+ TYPE_ALIAS_SET (gnu_fat_type) = -1;
+ finish_fat_pointer_type (gnu_fat_type, tem);
+ TYPE_ALIAS_SET (gnu_fat_type) = alias_set;
+ for (t = gnu_fat_type; t; t = TYPE_NEXT_VARIANT (t))
+ {
+ TYPE_FIELDS (t) = tem;
+ SET_TYPE_UNCONSTRAINED_ARRAY (t, gnu_type);
+ }
+ }
+ else
+ {
+ finish_fat_pointer_type (gnu_fat_type, tem);
+ SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
+ }
/* Build a reference to the template from a PLACEHOLDER_EXPR that
is the fat pointer. This will be used to access the individual
fields once we build them. */
tem = build3 (COMPONENT_REF, gnu_ptr_template,
build0 (PLACEHOLDER_EXPR, gnu_fat_type),
- TREE_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
+ DECL_CHAIN (TYPE_FIELDS (gnu_fat_type)), NULL_TREE);
gnu_template_reference
= build_unary_op (INDIRECT_REF, gnu_template_type, tem);
TREE_READONLY (gnu_template_reference) = 1;
+ TREE_THIS_NOTRAP (gnu_template_reference) = 1;
/* Now create the GCC type for each index and add the fields for that
index to the template. */
= create_concat_name (gnat_entity, field_name);
}
+ /* Install all the fields into the template. */
+ TYPE_NAME (gnu_template_type)
+ = create_concat_name (gnat_entity, "XUB");
+ gnu_template_fields = NULL_TREE;
for (index = 0; index < ndim; index++)
gnu_template_fields
= chainon (gnu_template_fields, gnu_temp_fields[index]);
-
- /* Install all the fields into the template. */
finish_record_type (gnu_template_type, gnu_template_fields, 0,
debug_info_p);
TYPE_READONLY (gnu_template_type) = 1;
- /* Now make the array of arrays and update the pointer to the array
- in the fat pointer. Note that it is the first field. */
- tem = gnat_to_gnu_component_type (gnat_entity, definition,
- debug_info_p);
+ /* Now build the array type. */
/* If Component_Size is not already specified, annotate it with the
size of the component. */
if (Unknown_Component_Size (gnat_entity))
- Set_Component_Size (gnat_entity, annotate_value (TYPE_SIZE (tem)));
+ Set_Component_Size (gnat_entity,
+ annotate_value (TYPE_SIZE (comp_type)));
/* Compute the maximum size of the array in units and bits. */
if (gnu_max_size)
{
gnu_max_size_unit = size_binop (MULT_EXPR, gnu_max_size,
- TYPE_SIZE_UNIT (tem));
+ TYPE_SIZE_UNIT (comp_type));
gnu_max_size = size_binop (MULT_EXPR,
convert (bitsizetype, gnu_max_size),
- TYPE_SIZE (tem));
+ TYPE_SIZE (comp_type));
}
else
gnu_max_size_unit = NULL_TREE;
/* Now build the array type. */
+ tem = comp_type;
for (index = ndim - 1; index >= 0; index--)
{
- tem = build_array_type (tem, gnu_index_types[index]);
+ tem = build_nonshared_array_type (tem, gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
if (array_type_has_nonaliased_component (tem, gnat_entity))
TYPE_NONALIASED_COMPONENT (tem) = 1;
}
TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
+
+ /* Adjust the type of the pointer-to-array field of the fat pointer
+ and record the aliasing relationships if necessary. */
TREE_TYPE (TYPE_FIELDS (gnu_fat_type)) = build_pointer_type (tem);
+ if (TYPE_ALIAS_SET_KNOWN_P (gnu_fat_type))
+ record_component_aliases (gnu_fat_type);
/* The result type is an UNCONSTRAINED_ARRAY_TYPE that indicates the
corresponding fat pointer. */
- TREE_TYPE (gnu_type) = TYPE_POINTER_TO (gnu_type)
- = TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
+ TREE_TYPE (gnu_type) = gnu_fat_type;
+ TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
+ TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
SET_TYPE_MODE (gnu_type, BLKmode);
TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
- SET_TYPE_UNCONSTRAINED_ARRAY (gnu_fat_type, gnu_type);
/* If the maximum size doesn't overflow, use it. */
if (gnu_max_size
else
gnat_name = gnat_entity;
create_type_decl (create_concat_name (gnat_name, "XUP"),
- gnu_fat_type, NULL, true,
+ gnu_fat_type, NULL, !Comes_From_Source (gnat_entity),
debug_info_p, gnat_entity);
/* Create the type to be used as what a thin pointer designates:
= (Convention (gnat_entity) == Convention_Fortran);
const int ndim = Number_Dimensions (gnat_entity);
tree gnu_base_type = gnu_type;
- tree *gnu_index_types = (tree *) alloca (ndim * sizeof (tree));
+ tree *gnu_index_types = XALLOCAVEC (tree, ndim);
tree gnu_max_size = size_one_node, gnu_max_size_unit;
bool need_index_type_struct = false;
int index;
/* Now build the array type. */
for (index = ndim - 1; index >= 0; index --)
{
- gnu_type = build_array_type (gnu_type, gnu_index_types[index]);
+ gnu_type = build_nonshared_array_type (gnu_type,
+ gnu_index_types[index]);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
gnu_field = create_field_decl (gnu_index_name, gnu_index,
gnu_bound_rec, NULL_TREE,
NULL_TREE, 0, 0);
- TREE_CHAIN (gnu_field) = gnu_field_list;
+ DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
add_parallel_type (TYPE_STUB_DECL (gnu_type), gnu_bound_rec);
}
- /* Otherwise, for a packed array, make the original array type a
- parallel type. */
- else if (debug_info_p
- && Is_Packed_Array_Type (gnat_entity)
- && present_gnu_tree (Original_Array_Type (gnat_entity)))
- add_parallel_type (TYPE_STUB_DECL (gnu_type),
- gnat_to_gnu_type
- (Original_Array_Type (gnat_entity)));
+ /* If this is a packed array type, make the original array type a
+ parallel type. Otherwise, do it for the base array type if it
+ isn't artificial to make sure it is kept in the debug info. */
+ if (debug_info_p)
+ {
+ if (Is_Packed_Array_Type (gnat_entity)
+ && present_gnu_tree (Original_Array_Type (gnat_entity)))
+ add_parallel_type (TYPE_STUB_DECL (gnu_type),
+ gnat_to_gnu_type
+ (Original_Array_Type (gnat_entity)));
+ else
+ {
+ tree gnu_base_decl
+ = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
+ if (!DECL_ARTIFICIAL (gnu_base_decl))
+ add_parallel_type (TYPE_STUB_DECL (gnu_type),
+ TREE_TYPE (TREE_TYPE (gnu_base_decl)));
+ }
+ }
TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
gnat_entity);
gnu_type
- = build_array_type (gnat_to_gnu_type (Component_Type (gnat_entity)),
- gnu_index_type);
+ = build_nonshared_array_type (gnat_to_gnu_type
+ (Component_Type (gnat_entity)),
+ gnu_index_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
? -1
: (Known_Alignment (gnat_entity)
|| (Strict_Alignment (gnat_entity)
- && Known_Static_Esize (gnat_entity)))
+ && Known_RM_Size (gnat_entity)))
? -2
: 0;
bool has_discr = Has_Discriminants (gnat_entity);
/* 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. */
- if (has_rep && Known_Esize (gnat_entity))
- TYPE_SIZE (gnu_type) = UI_To_gnu (Esize (gnat_entity), sizetype);
+ if (has_rep && Known_RM_Size (gnat_entity))
+ TYPE_SIZE (gnu_type)
+ = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
/* Always set the alignment here so that it can be used to
set the mode, if it is making the alignment stricter. If
type size instead of the RM size (see validate_size). Cap the
alignment, lest it causes this type size to become too large. */
else if (Strict_Alignment (gnat_entity)
- && Known_Static_Esize (gnat_entity))
+ && Known_RM_Size (gnat_entity))
{
- unsigned int raw_size = UI_To_Int (Esize (gnat_entity));
+ unsigned int raw_size = UI_To_Int (RM_Size (gnat_entity));
unsigned int raw_align = raw_size & -raw_size;
if (raw_align < BIGGEST_ALIGNMENT)
TYPE_ALIGN (gnu_type) = raw_align;
if (!is_unchecked_union)
{
- TREE_CHAIN (gnu_field) = gnu_field_list;
+ DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
}
}
/* Add the fields into the record type and finish it up. */
components_to_record (gnu_type, Component_List (record_definition),
- gnu_field_list, packed, definition, NULL,
- false, all_rep, is_unchecked_union,
- debug_info_p, false);
+ gnu_field_list, packed, definition, false,
+ all_rep, is_unchecked_union,
+ !Comes_From_Source (gnat_entity), debug_info_p,
+ false, OK_To_Reorder_Components (gnat_entity),
+ all_rep ? NULL_TREE : bitsize_zero_node, NULL);
/* If it is passed by reference, force BLKmode to ensure that objects
of this type will always be put in memory. */
for (gnu_field = TYPE_FIELDS (gnu_type),
gnu_std_field = TYPE_FIELDS (except_type_node);
gnu_field;
- gnu_field = TREE_CHAIN (gnu_field),
- gnu_std_field = TREE_CHAIN (gnu_std_field))
+ gnu_field = DECL_CHAIN (gnu_field),
+ gnu_std_field = DECL_CHAIN (gnu_std_field))
SET_DECL_ORIGINAL_FIELD_TO_FIELD (gnu_field, gnu_std_field);
gcc_assert (!gnu_std_field);
}
&& Present (Discriminant_Constraint (gnat_entity))
&& Stored_Constraint (gnat_entity) != No_Elist)
{
- tree gnu_subst_list
+ VEC(subst_pair,heap) *gnu_subst_list
= build_subst_list (gnat_entity, gnat_base_type, definition);
tree gnu_unpad_base_type, gnu_rep_part, gnu_variant_part, t;
- tree gnu_variant_list, gnu_pos_list, gnu_field_list = NULL_TREE;
+ tree gnu_pos_list, gnu_field_list = NULL_TREE;
bool selected_variant = false;
Entity_Id gnat_field;
+ VEC(variant_desc,heap) *gnu_variant_list;
gnu_type = make_node (RECORD_TYPE);
TYPE_NAME (gnu_type) = gnu_entity_name;
union for the variants that are still relevant. */
if (gnu_variant_part)
{
+ variant_desc *v;
+ unsigned ix;
+
gnu_variant_list
= build_variant_list (TREE_TYPE (gnu_variant_part),
- gnu_subst_list, NULL_TREE);
+ gnu_subst_list, NULL);
/* If all the qualifiers are unconditionally true, the
innermost variant is statically selected. */
selected_variant = true;
- for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
- if (!integer_onep (TREE_VEC_ELT (TREE_VALUE (t), 1)))
+ FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
+ ix, v)
+ if (!integer_onep (v->qual))
{
selected_variant = false;
break;
/* Otherwise, create the new variants. */
if (!selected_variant)
- for (t = gnu_variant_list; t; t = TREE_CHAIN (t))
+ FOR_EACH_VEC_ELT_REVERSE (variant_desc, gnu_variant_list,
+ ix, v)
{
- tree old_variant = TREE_PURPOSE (t);
+ tree old_variant = v->type;
tree new_variant = make_node (RECORD_TYPE);
+ tree suffix
+ = concat_name (DECL_NAME (gnu_variant_part),
+ IDENTIFIER_POINTER
+ (DECL_NAME (v->field)));
TYPE_NAME (new_variant)
- = DECL_NAME (TYPE_NAME (old_variant));
+ = concat_name (TYPE_NAME (gnu_type),
+ IDENTIFIER_POINTER (suffix));
copy_and_substitute_in_size (new_variant, old_variant,
gnu_subst_list);
- TREE_VEC_ELT (TREE_VALUE (t), 2) = new_variant;
+ v->new_type = new_variant;
}
}
else
{
- gnu_variant_list = NULL_TREE;
+ gnu_variant_list = NULL;
selected_variant = false;
}
== INTEGER_CST)
{
gnu_size = DECL_SIZE (gnu_old_field);
- if (TREE_CODE (gnu_field_type) == RECORD_TYPE
+ if (RECORD_OR_UNION_TYPE_P (gnu_field_type)
&& !TYPE_FAT_POINTER_P (gnu_field_type)
&& host_integerp (TYPE_SIZE (gnu_field_type), 1))
gnu_field_type
gnu_cont_type = gnu_type;
else
{
- t = purpose_member (gnu_context, gnu_variant_list);
+ variant_desc *v;
+ unsigned ix;
+
+ t = NULL_TREE;
+ FOR_EACH_VEC_ELT_REVERSE (variant_desc,
+ gnu_variant_list, ix, v)
+ if (v->type == gnu_context)
+ {
+ t = v->type;
+ break;
+ }
if (t)
{
if (selected_variant)
gnu_cont_type = gnu_type;
else
- gnu_cont_type = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ gnu_cont_type = v->new_type;
}
else
/* The front-end may pass us "ghost" components if
/* Put it in one of the new variants directly. */
if (gnu_cont_type != gnu_type)
{
- TREE_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
+ DECL_CHAIN (gnu_field) = TYPE_FIELDS (gnu_cont_type);
TYPE_FIELDS (gnu_cont_type) = gnu_field;
}
_Parent field. */
else if (gnat_name == Name_uController && gnu_last)
{
- TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
- TREE_CHAIN (gnu_last) = gnu_field;
+ DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
+ DECL_CHAIN (gnu_last) = gnu_field;
}
/* Otherwise, if this is a regular field, put it after
the other fields. */
else
{
- TREE_CHAIN (gnu_field) = gnu_field_list;
+ DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
if (!gnu_last)
gnu_last = gnu_field;
= create_variant_part_from (gnu_variant_part,
gnu_variant_list, gnu_type,
gnu_pos_list, gnu_subst_list);
- TREE_CHAIN (new_variant_part) = gnu_field_list;
+ DECL_CHAIN (new_variant_part) = gnu_field_list;
gnu_field_list = new_variant_part;
}
gnat_entity);
}
+ VEC_free (variant_desc, heap, gnu_variant_list);
+ VEC_free (subst_pair, heap, gnu_subst_list);
+
/* Now we can finalize it. */
rest_of_record_type_compilation (gnu_type);
}
fill it in later. */
if (!definition && defer_incomplete_level != 0)
{
- struct incomplete *p
- = (struct incomplete *) xmalloc (sizeof (struct incomplete));
+ struct incomplete *p = XNEW (struct incomplete);
gnu_type
= build_pointer_type
: In_Extended_Main_Code_Unit (gnat_desig_type));
/* True if we make a dummy type here. */
bool made_dummy = false;
- /* True if the dummy type is a fat pointer. */
- bool got_fat_p = false;
/* The mode to be used for the pointer type. */
enum machine_mode p_mode = mode_for_size (esize, MODE_INT, 0);
/* The GCC type used for the designated type. */
= Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep);
/* If we are pointing to an incomplete type whose completion is an
- unconstrained array, make a fat pointer type. The two types in our
- fields will be pointers to dummy nodes and 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. */
+ unconstrained array, make dummy fat and thin pointer types to it.
+ Likewise if the type itself is dummy or an unconstrained array. */
if (is_unconstrained_array
&& (Present (gnat_desig_full)
|| (present_gnu_tree (gnat_desig_equiv)
&& TYPE_IS_DUMMY_P
(TREE_TYPE (get_gnu_tree (gnat_desig_equiv))))
|| (!in_main_unit
- && defer_incomplete_level
+ && defer_incomplete_level != 0
&& !present_gnu_tree (gnat_desig_equiv))
|| (in_main_unit
&& is_from_limited_with
else
{
gnu_desig_type = make_dummy_type (gnat_desig_rep);
- /* Show the dummy we get will be a fat pointer. */
- got_fat_p = made_dummy = true;
+ made_dummy = true;
}
/* If the call above got something that has a pointer, the pointer
is our type. This could have happened either because the type
was elaborated or because somebody else executed the code. */
+ if (!TYPE_POINTER_TO (gnu_desig_type))
+ build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
gnu_type = TYPE_POINTER_TO (gnu_desig_type);
- if (!gnu_type)
- {
- tree gnu_template_type = make_node (ENUMERAL_TYPE);
- tree gnu_ptr_template = build_pointer_type (gnu_template_type);
- tree gnu_array_type = make_node (ENUMERAL_TYPE);
- tree gnu_ptr_array = build_pointer_type (gnu_array_type);
- tree fields;
-
- TYPE_NAME (gnu_template_type)
- = create_concat_name (gnat_desig_equiv, "XUB");
- TYPE_DUMMY_P (gnu_template_type) = 1;
-
- TYPE_NAME (gnu_array_type)
- = create_concat_name (gnat_desig_equiv, "XUA");
- TYPE_DUMMY_P (gnu_array_type) = 1;
-
- gnu_type = make_node (RECORD_TYPE);
- SET_TYPE_UNCONSTRAINED_ARRAY (gnu_type, gnu_desig_type);
- TYPE_POINTER_TO (gnu_desig_type) = gnu_type;
-
- fields
- = create_field_decl (get_identifier ("P_ARRAY"),
- gnu_ptr_array, gnu_type,
- NULL_TREE, NULL_TREE, 0, 0);
- TREE_CHAIN (fields)
- = create_field_decl (get_identifier ("P_BOUNDS"),
- gnu_ptr_template, gnu_type,
- NULL_TREE, NULL_TREE, 0, 0);
-
- /* Make sure we can place this into a register. */
- TYPE_ALIGN (gnu_type)
- = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
- TYPE_FAT_POINTER_P (gnu_type) = 1;
-
- /* Do not emit debug info for this record type since the types
- of its fields are incomplete. */
- finish_record_type (gnu_type, fields, 0, false);
-
- TYPE_OBJECT_RECORD_TYPE (gnu_desig_type)
- = make_node (RECORD_TYPE);
- TYPE_NAME (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type))
- = create_concat_name (gnat_desig_equiv, "XUT");
- TYPE_DUMMY_P (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type)) = 1;
- }
}
/* If we already know what the full type is, use it. */
access type may be the full view of a private type. Note
that the unconstrained array case is handled above. */
|| ((!in_main_unit || imported_p)
- && defer_incomplete_level
+ && defer_incomplete_level != 0
&& !present_gnu_tree (gnat_desig_equiv)
&& (Is_Record_Type (gnat_desig_rep)
|| Is_Array_Type (gnat_desig_rep)))
break;
}
- /* If we have not done it yet, build the pointer type the usual way. */
+ /* If we haven't done it yet, build the pointer type the usual way. */
if (!gnu_type)
{
/* Modify the designated type if we are pointing only to constant
save our current definition, evaluate the actual type, and replace
the tentative type we made with the actual one. If we are to defer
actually looking up the actual type, make an entry in the deferred
- list. If this is from a limited with, we have to defer to the end
- of the current spec in two cases: first if the designated type is
- in the current unit and second if the access type itself is. */
+ list. If this is from a limited with, we may have to defer to the
+ end of the current unit. */
if ((!in_main_unit || is_from_limited_with) && made_dummy)
{
- bool is_from_limited_with_in_main_unit
- = (is_from_limited_with
- && (in_main_unit
- || In_Extended_Main_Code_Unit (gnat_entity)));
- tree gnu_old_desig_type
- = TYPE_IS_FAT_POINTER_P (gnu_type)
- ? TYPE_UNCONSTRAINED_ARRAY (gnu_type) : TREE_TYPE (gnu_type);
-
- if (esize == POINTER_SIZE
- && (got_fat_p || TYPE_IS_FAT_POINTER_P (gnu_type)))
- gnu_type
- = build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE
- (TYPE_UNCONSTRAINED_ARRAY (gnu_type)));
+ tree gnu_old_desig_type;
+
+ if (TYPE_IS_FAT_POINTER_P (gnu_type))
+ {
+ gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
+ if (esize == POINTER_SIZE)
+ gnu_type = build_pointer_type
+ (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
+ }
+ else
+ gnu_old_desig_type = TREE_TYPE (gnu_type);
gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
!Comes_From_Source (gnat_entity),
Besides, variants of this non-dummy type might have been created
along the way. update_pointer_to is expected to properly take
care of those situations. */
- if (!defer_incomplete_level && !is_from_limited_with_in_main_unit)
- update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
- gnat_to_gnu_type (gnat_desig_equiv));
+ if (defer_incomplete_level == 0 && !is_from_limited_with)
+ {
+ defer_finalize_level++;
+ update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
+ gnat_to_gnu_type (gnat_desig_equiv));
+ defer_finalize_level--;
+ }
else
{
struct incomplete *p = XNEW (struct incomplete);
struct incomplete **head
- = (is_from_limited_with_in_main_unit
+ = (is_from_limited_with
? &defer_limited_with : &defer_incomplete_list);
p->old_type = gnu_old_desig_type;
p->full_type = gnat_desig_equiv;
case E_Access_Subtype:
/* We treat this as identical to its base type; any constraint is
- meaningful only to the front end.
+ meaningful only to the front-end.
The designated type must be elaborated as well, if it does
not have its own freeze node. Designated (sub)types created
for constrained components of records with discriminants are
- not frozen by the front end and thus not elaborated by gigi,
+ not frozen by the front-end and thus not elaborated by gigi,
because their use may appear before the base type is frozen,
and because it is not clear that they are needed anywhere in
- Gigi. With the current model, there is no correct place where
+ gigi. With the current model, there is no correct place where
they could be elaborated. */
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
elaborate it later. */
if (!definition && defer_incomplete_level != 0)
{
- struct incomplete *p
- = (struct incomplete *) xmalloc (sizeof (struct incomplete));
- tree gnu_ptr_type
- = build_pointer_type
- (make_dummy_type (Directly_Designated_Type (gnat_entity)));
+ struct incomplete *p = XNEW (struct incomplete);
- p->old_type = TREE_TYPE (gnu_ptr_type);
+ p->old_type
+ = make_dummy_type (Directly_Designated_Type (gnat_entity));
p->full_type = Directly_Designated_Type (gnat_entity);
p->next = defer_incomplete_list;
defer_incomplete_list = p;
}
else if (!IN (Ekind (Base_Type
- (Directly_Designated_Type (gnat_entity))),
- Incomplete_Or_Private_Kind))
+ (Directly_Designated_Type (gnat_entity))),
+ Incomplete_Or_Private_Kind))
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
NULL_TREE, 0);
}
/* Subprogram Entities
- The following access functions are defined for subprograms (functions
- or procedures):
+ The following access functions are defined for subprograms:
+ Etype Return type or Standard_Void_Type.
First_Formal The first formal parameter.
Is_Imported Indicates that the subprogram has appeared in
an INTERFACE or IMPORT pragma. For now we
Is_Exported Likewise but for an EXPORT pragma.
Is_Inlined True if the subprogram is to be inlined.
- In addition for function subprograms we have:
-
- Etype Return type of the function.
-
Each parameter is first checked by calling must_pass_by_ref on its
type to determine if it is passed by reference. For parameters which
are copied in, if they are Ada In Out or Out parameters, their return
case E_Function:
case E_Procedure:
{
+ /* The type returned by a function or else Standard_Void_Type for a
+ procedure. */
+ Entity_Id gnat_return_type = Etype (gnat_entity);
+ tree gnu_return_type;
/* The first GCC parameter declaration (a PARM_DECL node). The
- PARM_DECL nodes are chained through the TREE_CHAIN field, so this
+ PARM_DECL nodes are chained through the DECL_CHAIN field, so this
actually is the head of this parameter list. */
tree gnu_param_list = NULL_TREE;
/* Likewise for the stub associated with an exported procedure. */
tree gnu_stub_param_list = NULL_TREE;
- /* The type returned by a function. If the subprogram is a procedure
- this type should be void_type_node. */
- tree gnu_return_type = void_type_node;
- /* List of fields in return type of procedure with copy-in copy-out
- parameters. */
- tree gnu_field_list = NULL_TREE;
/* Non-null for subprograms containing parameters passed by copy-in
copy-out (Ada In Out or Out parameters not passed by reference),
in which case it is the list of nodes used to specify the values
corresponding to that field. This list will be saved in the
TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
tree gnu_cico_list = NULL_TREE;
+ /* List of fields in return type of procedure with copy-in copy-out
+ parameters. */
+ tree gnu_field_list = NULL_TREE;
/* If an import pragma asks to map this subprogram to a GCC builtin,
this is the builtin DECL node. */
tree gnu_builtin_decl = NULL_TREE;
bool public_flag = Is_Public (gnat_entity) || imported_p;
bool extern_flag
= (Is_Public (gnat_entity) && !definition) || imported_p;
-
+ bool artificial_flag = !Comes_From_Source (gnat_entity);
/* The semantics of "pure" in Ada essentially matches that of "const"
in the back-end. In particular, both properties are orthogonal to
the "nothrow" property if the EH circuitry is explicit in the
bool const_flag
= (Exception_Mechanism == Back_End_Exceptions
&& Is_Pure (gnat_entity));
-
bool volatile_flag = No_Return (gnat_entity);
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
- bool has_copy_in_out = false;
bool has_stub = false;
int parmnum;
if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
- gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity),
- gnu_expr, 0);
+ gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
/* Elaborate any Itypes in the parameters of this entity. */
for (gnat_temp = First_Formal_With_Extras (gnat_entity);
}
/* If this subprogram is expectedly bound to a GCC builtin, fetch the
- corresponding DECL node.
+ corresponding DECL node. Proper generation of calls later on need
+ proper parameter associations so we don't "break;" here. */
+ if (Convention (gnat_entity) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_entity)))
+ {
+ gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
- 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);
+ /* Inability to find the builtin decl most often indicates a
+ genuine mistake, but imports of unregistered intrinsics are
+ sometimes issued on purpose to allow hooking in alternate
+ bodies. We post a warning conditioned on Wshadow in this case,
+ to let developers be notified on demand without risking false
+ positives with common default sets of options. */
+
+ if (gnu_builtin_decl == NULL_TREE && warn_shadow)
+ post_error ("?gcc intrinsic not found for&!", gnat_entity);
+ }
/* ??? What if we don't find the builtin node above ? warn ? err ?
In the current state we neither warn nor err, and calls will just
be handled as for regular subprograms. */
- if (kind == E_Function || kind == E_Subprogram_Type)
- gnu_return_type = gnat_to_gnu_type (Etype (gnat_entity));
-
- /* If this function returns by reference, make the actual return
- type of this function the pointer and mark the decl. */
- if (Returns_By_Ref (gnat_entity))
+ /* Look into the return type and get its associated GCC tree. If it
+ is not void, compute various flags for the subprogram type. */
+ if (Ekind (gnat_return_type) == E_Void)
+ gnu_return_type = void_type_node;
+ else
{
- gnu_return_type = build_pointer_type (gnu_return_type);
- return_by_direct_ref_p = true;
- }
+ gnu_return_type = gnat_to_gnu_type (gnat_return_type);
- /* If the Mechanism is By_Reference, ensure this function uses the
- target's by-invisible-reference mechanism, which may not be the
- same as above (e.g. it might be passing an extra parameter).
-
- Prior to GCC 4, this was handled by just setting TREE_ADDRESSABLE
- on the result type. Everything required to pass by invisible
- reference using the target's mechanism (e.g. an extra parameter)
- was handled at RTL expansion time.
-
- This doesn't work with GCC 4 any more for several reasons. First,
- the gimplification process might need to create temporaries of this
- type and the gimplifier ICEs on such attempts; that's why the flag
- is now set on the function type instead. Second, the middle-end
- now also relies on a different attribute, DECL_BY_REFERENCE on the
- RESULT_DECL, and expects the by-invisible-reference-ness to be made
- explicit in the function body. */
- else if (kind == E_Function && Mechanism (gnat_entity) == By_Reference)
- return_by_invisi_ref_p = true;
-
- /* If we are supposed to return an unconstrained array, actually return
- a fat pointer and make a note of that. */
- else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_return_type = TREE_TYPE (gnu_return_type);
- return_unconstrained_p = true;
- }
+ /* If this function returns by reference, make the actual return
+ type the pointer type and make a note of that. */
+ if (Returns_By_Ref (gnat_entity))
+ {
+ gnu_return_type = build_pointer_type (gnu_return_type);
+ return_by_direct_ref_p = true;
+ }
- /* If the type requires a transient scope, the result is allocated
- on the secondary stack, so the result type of the function is
- just a pointer. */
- else if (Requires_Transient_Scope (Etype (gnat_entity)))
- {
- gnu_return_type = build_pointer_type (gnu_return_type);
- return_unconstrained_p = true;
- }
+ /* If we are supposed to return an unconstrained array type, make
+ the actual return type the fat pointer type. */
+ else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ gnu_return_type = TREE_TYPE (gnu_return_type);
+ return_unconstrained_p = true;
+ }
- /* If the type is a padded type and the underlying type would not
- be passed by reference or this function has a foreign convention,
- return the underlying type. */
- else if (TYPE_IS_PADDING_P (gnu_return_type)
- && (!default_pass_by_ref (TREE_TYPE
- (TYPE_FIELDS (gnu_return_type)))
- || Has_Foreign_Convention (gnat_entity)))
- gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
-
- /* If the return type is unconstrained, that means it must have a
- maximum size. Use the padded type as the effective return type.
- And ensure the function uses the target's by-invisible-reference
- mechanism to avoid copying too much data when it returns. */
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
- {
- gnu_return_type
- = maybe_pad_type (gnu_return_type,
- max_size (TYPE_SIZE (gnu_return_type), true),
- 0, gnat_entity, false, false, false, true);
- return_by_invisi_ref_p = true;
- }
+ /* Likewise, if the return type requires a transient scope, the
+ return value will be allocated on the secondary stack so the
+ actual return type is the pointer type. */
+ else if (Requires_Transient_Scope (gnat_return_type))
+ {
+ gnu_return_type = build_pointer_type (gnu_return_type);
+ return_unconstrained_p = true;
+ }
- /* If the return type has a size that overflows, we cannot have
- a function that returns that type. This usage doesn't make
- sense anyway, so give an error here. */
- if (TYPE_SIZE_UNIT (gnu_return_type)
- && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
- && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
- {
- post_error ("cannot return type whose size overflows",
- gnat_entity);
- gnu_return_type = copy_node (gnu_return_type);
- TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
- TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
- TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
- TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
- }
+ /* If the Mechanism is By_Reference, ensure this function uses the
+ target's by-invisible-reference mechanism, which may not be the
+ same as above (e.g. it might be passing an extra parameter). */
+ else if (kind == E_Function
+ && Mechanism (gnat_entity) == By_Reference)
+ return_by_invisi_ref_p = true;
+
+ /* Likewise, if the return type is itself By_Reference. */
+ else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
+ return_by_invisi_ref_p = true;
+
+ /* If the type is a padded type and the underlying type would not
+ be passed by reference or the function has a foreign convention,
+ return the underlying type. */
+ else if (TYPE_IS_PADDING_P (gnu_return_type)
+ && (!default_pass_by_ref
+ (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
+ || Has_Foreign_Convention (gnat_entity)))
+ gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
+
+ /* If the return type is unconstrained, that means it must have a
+ maximum size. Use the padded type as the effective return type.
+ And ensure the function uses the target's by-invisible-reference
+ mechanism to avoid copying too much data when it returns. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
+ {
+ gnu_return_type
+ = maybe_pad_type (gnu_return_type,
+ max_size (TYPE_SIZE (gnu_return_type),
+ true),
+ 0, gnat_entity, false, false, false, true);
+
+ /* Declare it now since it will never be declared otherwise.
+ This is necessary to ensure that its subtrees are properly
+ marked. */
+ create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
+ NULL, true, debug_info_p, gnat_entity);
+
+ return_by_invisi_ref_p = true;
+ }
- /* Look at all our parameters and get the type of
- each. While doing this, build a copy-out structure if
- we need one. */
+ /* If the return type has a size that overflows, we cannot have
+ a function that returns that type. This usage doesn't make
+ sense anyway, so give an error here. */
+ if (TYPE_SIZE_UNIT (gnu_return_type)
+ && TREE_CONSTANT (TYPE_SIZE_UNIT (gnu_return_type))
+ && TREE_OVERFLOW (TYPE_SIZE_UNIT (gnu_return_type)))
+ {
+ post_error ("cannot return type whose size overflows",
+ gnat_entity);
+ gnu_return_type = copy_node (gnu_return_type);
+ TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
+ TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
+ TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
+ }
+ }
- /* Loop over the parameters and get their associated GCC tree.
- While doing this, build a copy-out structure if we need one. */
+ /* Loop over the parameters and get their associated GCC tree. While
+ doing this, build a copy-in copy-out structure if we need one. */
for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
gnu_param = NULL_TREE;
}
+ /* The failure of this assertion will very likely come from an
+ order of elaboration issue for the type of the parameter. */
+ gcc_assert (kind == E_Subprogram_Type
+ || !TYPE_IS_DUMMY_P (gnu_param_type)
+ || type_annotate_only);
+
if (gnu_param)
{
/* If it's an exported subprogram, we build a parameter list
if (copy_in_copy_out)
{
- if (!has_copy_in_out)
+ if (!gnu_cico_list)
{
- gcc_assert (TREE_CODE (gnu_return_type) == VOID_TYPE);
- gnu_return_type = make_node (RECORD_TYPE);
+ tree gnu_new_ret_type = make_node (RECORD_TYPE);
+
+ /* If this is a function, we also need a field for the
+ return value to be placed. */
+ if (TREE_CODE (gnu_return_type) != VOID_TYPE)
+ {
+ gnu_field
+ = create_field_decl (get_identifier ("RETVAL"),
+ gnu_return_type,
+ gnu_new_ret_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+ Sloc_to_locus (Sloc (gnat_entity),
+ &DECL_SOURCE_LOCATION (gnu_field));
+ gnu_field_list = gnu_field;
+ gnu_cico_list
+ = tree_cons (gnu_field, void_type_node, NULL_TREE);
+ }
+
+ gnu_return_type = gnu_new_ret_type;
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
- /* Set a default alignment to speed up accesses. */
+ /* Set a default alignment to speed up accesses. But we
+ shouldn't increase the size of the structure too much,
+ lest it doesn't fit in return registers anymore. */
TYPE_ALIGN (gnu_return_type)
= get_mode_alignment (ptr_mode);
- has_copy_in_out = true;
}
gnu_field
0, 0);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_field));
- TREE_CHAIN (gnu_field) = gnu_field_list;
+ DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
gnu_cico_list
= tree_cons (gnu_field, gnu_param, gnu_cico_list);
}
}
- /* Do not compute record for out parameters if subprogram is
- stubbed since structures are incomplete for the back-end. */
- if (gnu_field_list && Convention (gnat_entity) != Convention_Stubbed)
- finish_record_type (gnu_return_type, nreverse (gnu_field_list),
- 0, debug_info_p);
+ if (gnu_cico_list)
+ {
+ /* If we have a CICO list but it has only one entry, we convert
+ this function into a function that returns this object. */
+ if (list_length (gnu_cico_list) == 1)
+ gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
+
+ /* Do not finalize the return type if the subprogram is stubbed
+ since structures are incomplete for the back-end. */
+ else if (Convention (gnat_entity) != Convention_Stubbed)
+ {
+ finish_record_type (gnu_return_type, nreverse (gnu_field_list),
+ 0, false);
+
+ /* Try to promote the mode of the return type if it is passed
+ in registers, again to speed up accesses. */
+ if (TYPE_MODE (gnu_return_type) == BLKmode
+ && !targetm.calls.return_in_memory (gnu_return_type,
+ NULL_TREE))
+ {
+ unsigned int size
+ = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
+ unsigned int i = BITS_PER_UNIT;
+ enum machine_mode mode;
+
+ while (i < size)
+ i <<= 1;
+ mode = mode_for_size (i, MODE_INT, 0);
+ if (mode != BLKmode)
+ {
+ SET_TYPE_MODE (gnu_return_type, mode);
+ TYPE_ALIGN (gnu_return_type)
+ = GET_MODE_ALIGNMENT (mode);
+ TYPE_SIZE (gnu_return_type)
+ = bitsize_int (GET_MODE_BITSIZE (mode));
+ TYPE_SIZE_UNIT (gnu_return_type)
+ = size_int (GET_MODE_SIZE (mode));
+ }
+ }
- /* If we have a CICO list but it has only one entry, we convert
- this function into a function that simply returns that one
- object. */
- if (list_length (gnu_cico_list) == 1)
- gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
+ if (debug_info_p)
+ rest_of_record_type_compilation (gnu_return_type);
+ }
+ }
if (Has_Stdcall_Convention (gnat_entity))
prepend_one_attribute_to
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("stdcall"), NULL_TREE,
gnat_entity);
+ else if (Has_Thiscall_Convention (gnat_entity))
+ prepend_one_attribute_to
+ (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+ get_identifier ("thiscall"), NULL_TREE,
+ gnat_entity);
- /* If we are on a target where stack realignment is needed for 'main'
- to honor GCC's implicit expectations (stack alignment greater than
- what the base ABI guarantees), ensure we do the same for foreign
- convention subprograms as they might be used as callbacks from code
- breaking such expectations. Note that this applies to task entry
- points in particular. */
- if (FORCE_PREFERRED_STACK_BOUNDARY_IN_MAIN
+ /* If we should request stack realignment for a foreign convention
+ subprogram, do so. Note that this applies to task entry points in
+ particular. */
+ if (FOREIGN_FORCE_REALIGN_STACK
&& Has_Foreign_Convention (gnat_entity))
prepend_one_attribute_to
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
gnu_stub_param_list = nreverse (gnu_stub_param_list);
gnu_cico_list = nreverse (gnu_cico_list);
- if (Ekind (gnat_entity) == E_Function)
+ if (kind == E_Function)
Set_Mechanism (gnat_entity, return_unconstrained_p
|| return_by_direct_ref_p
|| return_by_invisi_ref_p
| (TYPE_QUAL_CONST * const_flag)
| (TYPE_QUAL_VOLATILE * volatile_flag));
- /* 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 we have a builtin decl for that function, use it. Check if the
+ profiles are compatible and warn if they are not. The checker is
+ expected to post extra diagnostics in this case. */
if (gnu_builtin_decl)
{
- tree gnu_builtin_type = TREE_TYPE (gnu_builtin_decl);
+ intrin_binding_t inb;
- if (compatible_signatures_p (gnu_type, gnu_builtin_type))
- {
- gnu_decl = gnu_builtin_decl;
- gnu_type = gnu_builtin_type;
- break;
- }
+ inb.gnat_entity = gnat_entity;
+ inb.ada_fntype = gnu_type;
+ inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
+
+ if (!intrin_profiles_compatible_p (&inb))
+ post_error
+ ("?profile of& doesn''t match the builtin it binds!",
+ gnat_entity);
+
+ gnu_decl = gnu_builtin_decl;
+ gnu_type = TREE_TYPE (gnu_builtin_decl);
+ break;
}
/* If there was no specified Interface_Name and the external and
}
else if (kind == E_Subprogram_Type)
- gnu_decl = create_type_decl (gnu_entity_name, gnu_type, attr_list,
- !Comes_From_Source (gnat_entity),
- debug_info_p, gnat_entity);
+ gnu_decl
+ = create_type_decl (gnu_entity_name, gnu_type, attr_list,
+ artificial_flag, debug_info_p, gnat_entity);
else
{
if (has_stub)
gnu_stub_name = gnu_ext_name;
gnu_ext_name = create_concat_name (gnat_entity, "internal");
public_flag = false;
+ artificial_flag = true;
}
- gnu_decl = create_subprog_decl (gnu_entity_name, gnu_ext_name,
- gnu_type, gnu_param_list,
- inline_flag, public_flag,
- extern_flag, attr_list,
- gnat_entity);
+ gnu_decl
+ = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
+ gnu_param_list, inline_flag, public_flag,
+ extern_flag, artificial_flag, attr_list,
+ gnat_entity);
if (has_stub)
{
tree gnu_stub_decl
= create_subprog_decl (gnu_entity_name, gnu_stub_name,
gnu_stub_type, gnu_stub_param_list,
- inline_flag, true,
- extern_flag, attr_list,
- gnat_entity);
+ inline_flag, true, extern_flag,
+ false, attr_list, gnat_entity);
SET_DECL_FUNCTION_STUB (gnu_decl, gnu_stub_decl);
}
full view, whichever is present. This is used in all the tests
below. */
Entity_Id full_view
- = (IN (Ekind (gnat_entity), Incomplete_Kind)
- && From_With_Type (gnat_entity))
+ = (IN (kind, Incomplete_Kind) && From_With_Type (gnat_entity))
? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity))
? Full_View (gnat_entity)
we can do any needed updates when we see it. */
gnu_type = make_dummy_type (gnat_entity);
gnu_decl = TYPE_STUB_DECL (gnu_type);
+ if (Has_Completion_In_Body (gnat_entity))
+ DECL_TAFT_TYPE_P (gnu_decl) = 1;
save_gnu_tree (full_view, gnu_decl, 0);
break;
}
break;
case E_Label:
- gnu_decl = create_label_decl (gnu_entity_name);
+ gnu_decl = create_label_decl (gnu_entity_name, gnat_entity);
break;
case E_Block:
|| Is_Class_Wide_Equivalent_Type (gnat_entity))
TYPE_ALIGN_OK (gnu_type) = 1;
- /* If the type is passed by reference, objects of this type must be
- fully addressable and cannot be copied. */
- if (Is_By_Reference_Type (gnat_entity))
- TREE_ADDRESSABLE (gnu_type) = 1;
+ /* Record whether the type is passed by reference. */
+ if (!VOID_TYPE_P (gnu_type) && Is_By_Reference_Type (gnat_entity))
+ TYPE_BY_REFERENCE_P (gnu_type) = 1;
/* ??? Don't set the size for a String_Literal since it is either
confirming or we don't handle it properly (if the low bound is
non-constant). */
if (!gnu_size && kind != E_String_Literal_Subtype)
- gnu_size = validate_size (Esize (gnat_entity), gnu_type, gnat_entity,
- TYPE_DECL, false,
- Has_Size_Clause (gnat_entity));
+ {
+ Uint gnat_size = Known_Esize (gnat_entity)
+ ? Esize (gnat_entity) : RM_Size (gnat_entity);
+ gnu_size
+ = validate_size (gnat_size, gnu_type, gnat_entity, TYPE_DECL,
+ false, Has_Size_Clause (gnat_entity));
+ }
/* If a size was specified, see if we can make a new type of that size
by rearranging the type, for example from a fat to a thin pointer. */
tree size;
/* If a size was specified, take it into account. Otherwise
- use the RM size for records as the type size has already
- been adjusted to the alignment. */
+ use the RM size for records or unions as the type size has
+ already been adjusted to the alignment. */
if (gnu_size)
size = gnu_size;
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
+ else if (RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type))
size = rm_size (gnu_type);
else
Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
}
- if (!Comes_From_Source (gnat_entity) && DECL_P (gnu_decl))
- DECL_ARTIFICIAL (gnu_decl) = 1;
+ /* If we really have a ..._DECL node, set a couple of flags on it. But we
+ cannot do so if we are reusing the ..._DECL node made for an alias or a
+ renamed object as the predicates don't apply to it but to GNAT_ENTITY. */
+ if (DECL_P (gnu_decl)
+ && !Present (Alias (gnat_entity))
+ && !(Present (Renamed_Object (gnat_entity)) && saved))
+ {
+ if (!Comes_From_Source (gnat_entity))
+ DECL_ARTIFICIAL (gnu_decl) = 1;
- if (!debug_info_p && DECL_P (gnu_decl)
- && TREE_CODE (gnu_decl) != FUNCTION_DECL
- && No (Renamed_Object (gnat_entity)))
- DECL_IGNORED_P (gnu_decl) = 1;
+ if (!debug_info_p)
+ DECL_IGNORED_P (gnu_decl) = 1;
+ }
/* If we haven't already, associate the ..._DECL node that we just made with
the input GNAT entity node. */
SET_TYPE_RM_MIN_VALUE (gnu_scalar_type, gnu_low_bound);
SET_TYPE_RM_MAX_VALUE (gnu_scalar_type, gnu_high_bound);
- /* Write full debugging information. Since this has both a
- typedef and a tag, avoid outputting the name twice. */
- DECL_ARTIFICIAL (gnu_decl) = 1;
+ /* Write full debugging information. */
rest_of_type_decl_compilation (gnu_decl);
}
}
/* If we deferred processing of incomplete types, re-enable it. If there
- were no other disables and we have some to process, do so. */
- if (this_deferred && --defer_incomplete_level == 0)
+ were no other disables and we have deferred types to process, do so. */
+ if (this_deferred
+ && --defer_incomplete_level == 0
+ && defer_incomplete_list)
{
- if (defer_incomplete_list)
- {
- struct incomplete *incp, *next;
-
- /* We are back to level 0 for the deferring of incomplete types.
- But processing these incomplete types below may itself require
- deferring, so preserve what we have and restart from scratch. */
- incp = defer_incomplete_list;
- defer_incomplete_list = NULL;
+ struct incomplete *p, *next;
- /* For finalization, however, all types must be complete so we
- cannot do the same because deferred incomplete types may end up
- referencing each other. Process them all recursively first. */
- defer_finalize_level++;
+ /* We are back to level 0 for the deferring of incomplete types.
+ But processing these incomplete types below may itself require
+ deferring, so preserve what we have and restart from scratch. */
+ p = defer_incomplete_list;
+ defer_incomplete_list = NULL;
- for (; incp; incp = next)
- {
- next = incp->next;
+ /* For finalization, however, all types must be complete so we
+ cannot do the same because deferred incomplete types may end up
+ referencing each other. Process them all recursively first. */
+ defer_finalize_level++;
- if (incp->old_type)
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
- gnat_to_gnu_type (incp->full_type));
- free (incp);
- }
+ for (; p; p = next)
+ {
+ next = p->next;
- defer_finalize_level--;
+ if (p->old_type)
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
+ gnat_to_gnu_type (p->full_type));
+ free (p);
}
- /* All the deferred incomplete types have been processed so we can
- now proceed with the finalization of the deferred types. */
- if (defer_finalize_level == 0 && defer_finalize_list)
- {
- unsigned int i;
- tree t;
+ defer_finalize_level--;
+ }
- for (i = 0; VEC_iterate (tree, defer_finalize_list, i, t); i++)
- rest_of_type_decl_compilation_no_defer (t);
+ /* If all the deferred incomplete types have been processed, we can proceed
+ with the finalization of the deferred types. */
+ if (defer_incomplete_level == 0
+ && defer_finalize_level == 0
+ && defer_finalize_list)
+ {
+ unsigned int i;
+ tree t;
- VEC_free (tree, heap, defer_finalize_list);
- }
+ FOR_EACH_VEC_ELT (tree, defer_finalize_list, i, t)
+ rest_of_type_decl_compilation_no_defer (t);
+
+ VEC_free (tree, heap, defer_finalize_list);
}
- /* If we are not defining this type, see if it's in the incomplete list.
- If so, handle that list entry now. */
- else if (!definition)
+ /* If we are not defining this type, see if it's on one of the lists of
+ incomplete types. If so, handle the list entry now. */
+ if (is_type && !definition)
{
- struct incomplete *incp;
+ struct incomplete *p;
+
+ for (p = defer_incomplete_list; p; p = p->next)
+ if (p->old_type && p->full_type == gnat_entity)
+ {
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
+ TREE_TYPE (gnu_decl));
+ p->old_type = NULL_TREE;
+ }
- for (incp = defer_incomplete_list; incp; incp = incp->next)
- if (incp->old_type && incp->full_type == gnat_entity)
+ for (p = defer_limited_with; p; p = p->next)
+ if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
{
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
TREE_TYPE (gnu_decl));
- incp->old_type = NULL_TREE;
+ p->old_type = NULL_TREE;
}
}
return type;
}
+
+/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
+ type has been changed to that of the parameterless procedure, except if an
+ alias is already present, in which case it is returned instead. */
+
+tree
+get_minimal_subprog_decl (Entity_Id gnat_entity)
+{
+ tree gnu_entity_name, gnu_ext_name;
+ struct attrib *attr_list = NULL;
+
+ /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
+ of the handling applied here. */
+
+ while (Present (Alias (gnat_entity)))
+ {
+ gnat_entity = Alias (gnat_entity);
+ if (present_gnu_tree (gnat_entity))
+ return get_gnu_tree (gnat_entity);
+ }
+
+ gnu_entity_name = get_entity_name (gnat_entity);
+ gnu_ext_name = create_concat_name (gnat_entity, NULL);
+
+ if (Has_Stdcall_Convention (gnat_entity))
+ prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+ get_identifier ("stdcall"), NULL_TREE,
+ gnat_entity);
+ else if (Has_Thiscall_Convention (gnat_entity))
+ prepend_one_attribute_to (&attr_list, ATTR_MACHINE_ATTRIBUTE,
+ get_identifier ("thiscall"), NULL_TREE,
+ gnat_entity);
+
+ if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
+ gnu_ext_name = NULL_TREE;
+
+ return
+ create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
+ false, true, true, true, attr_list, gnat_entity);
+}
\f
/* Wrap up compilation of DECL, a TYPE_DECL, possibly deferring it.
Every TYPE_DECL generated for a type definition must be passed
{
/* We need to defer finalizing the type if incomplete types
are being deferred or if they are being processed. */
- if (defer_incomplete_level || defer_finalize_level)
+ if (defer_incomplete_level != 0 || defer_finalize_level != 0)
VEC_safe_push (tree, heap, defer_finalize_list, decl);
else
rest_of_type_decl_compilation_no_defer (decl);
}
}
-/* Finalize any From_With_Type incomplete types. We do this after processing
- our compilation unit and after processing its spec, if this is a body. */
+/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
+ a C++ imported method or equivalent.
+
+ We use the predicate on 32-bit x86/Windows to find out whether we need to
+ use the "thiscall" calling convention for GNAT_ENTITY. This convention is
+ used for C++ methods (functions with METHOD_TYPE) by the back-end. */
+
+bool
+is_cplusplus_method (Entity_Id gnat_entity)
+{
+ if (Convention (gnat_entity) != Convention_CPP)
+ return False;
+
+ /* This is the main case: C++ method imported as a primitive operation. */
+ if (Is_Dispatching_Operation (gnat_entity))
+ return True;
+
+ /* A thunk needs to be handled like its associated primitive operation. */
+ if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
+ return True;
+
+ /* C++ classes with no virtual functions can be imported as limited
+ record types, but we need to return true for the constructors. */
+ if (Is_Constructor (gnat_entity))
+ return True;
+
+ /* This is set on the E_Subprogram_Type built for a dispatching call. */
+ if (Is_Dispatch_Table_Entity (gnat_entity))
+ return True;
+
+ return False;
+}
+
+/* Finalize the processing of From_With_Type incomplete types. */
void
finalize_from_with_types (void)
{
- struct incomplete *incp = defer_limited_with;
- struct incomplete *next;
+ struct incomplete *p, *next;
+
+ p = defer_limited_with;
+ defer_limited_with = NULL;
- defer_limited_with = 0;
- for (; incp; incp = next)
+ for (; p; p = next)
{
- next = incp->next;
+ next = p->next;
- if (incp->old_type != 0)
- update_pointer_to (TYPE_MAIN_VARIANT (incp->old_type),
- gnat_to_gnu_type (incp->full_type));
- free (incp);
+ if (p->old_type)
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
+ gnat_to_gnu_type (p->full_type));
+ free (p);
}
}
}
gcc_assert (Present (gnat_equiv) || type_annotate_only);
+
return gnat_equiv;
}
gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
bool debug_info_p)
{
- tree gnu_type = gnat_to_gnu_type (Component_Type (gnat_array));
+ const Entity_Id gnat_type = Component_Type (gnat_array);
+ tree gnu_type = gnat_to_gnu_type (gnat_type);
tree gnu_comp_size;
/* Try to get a smaller form of the component if needed. */
|| Has_Component_Size_Clause (gnat_array))
&& !Is_Bit_Packed_Array (gnat_array)
&& !Has_Aliased_Components (gnat_array)
- && !Strict_Alignment (Component_Type (gnat_array))
- && TREE_CODE (gnu_type) == RECORD_TYPE
+ && !Strict_Alignment (gnat_type)
+ && RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& host_integerp (TYPE_SIZE (gnu_type), 1))
gnu_type = make_packable_type (gnu_type, false);
debug_info_p, gnat_array);
}
- if (Has_Volatile_Components (Base_Type (gnat_array)))
+ if (Has_Volatile_Components (gnat_array))
gnu_type
= build_qualified_type (gnu_type,
TYPE_QUALS (gnu_type) | TYPE_QUAL_VOLATILE);
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
- bool by_return = false, by_component_ptr = false, by_ref = false;
+ bool by_return = false, by_component_ptr = false;
+ bool by_ref = false, by_double_ref = false;
tree gnu_param;
/* Copy-return is used only for the first parameter of a valued procedure.
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
+ /* For GCC builtins, pass Address integer types as (void *) */
+ if (Convention (gnat_subprog) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_subprog))
+ && Is_Descendent_Of_Address (Etype (gnat_param)))
+ gnu_param_type = ptr_void_type_node;
+
/* VMS descriptors are themselves passed by reference. */
if (mech == By_Short_Descriptor ||
(mech == By_Descriptor && TARGET_ABI_OPEN_VMS && !TARGET_MALLOC64))
|| (!foreign
&& default_pass_by_ref (gnu_param_type)))))
{
+ /* We take advantage of 6.2(12) by considering that references built for
+ parameters whose type isn't by-ref and for which the mechanism hasn't
+ been forced to by-ref are restrict-qualified in the C sense. */
+ bool restrict_p
+ = !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
gnu_param_type = build_reference_type (gnu_param_type);
+ if (restrict_p)
+ gnu_param_type
+ = build_qualified_type (gnu_param_type, TYPE_QUAL_RESTRICT);
by_ref = true;
+
+ /* In some ABIs, e.g. SPARC 32-bit, fat pointer types are themselves
+ passed by reference. Pass them by explicit reference, this will
+ generate more debuggable code at -O0. */
+ if (TYPE_IS_FAT_POINTER_P (gnu_param_type)
+ && targetm.calls.pass_by_reference (pack_cumulative_args (NULL),
+ TYPE_MODE (gnu_param_type),
+ gnu_param_type,
+ true))
+ {
+ gnu_param_type = build_reference_type (gnu_param_type);
+ by_double_ref = true;
+ }
}
/* Pass In Out or Out parameters using copy-in copy-out mechanism. */
gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
ro_param || by_ref || by_component_ptr);
DECL_BY_REF_P (gnu_param) = by_ref;
+ DECL_BY_DOUBLE_REF_P (gnu_param) = by_double_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_BY_DESCRIPTOR_P (gnu_param) = (mech == By_Descriptor ||
mech == By_Short_Descriptor);
+ /* Note that, in case of a parameter passed by double reference, the
+ DECL_POINTS_TO_READONLY_P flag is meant for the second reference.
+ The first reference always points to read-only, as it points to
+ the second reference, i.e. the reference to the actual parameter. */
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
+ DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
/* Save the alternate descriptor type, if any. */
if (gnu_param_type_alt)
elaborate_expression_1 (tree gnu_expr, Entity_Id gnat_entity, tree gnu_name,
bool definition, bool need_debug)
{
- /* Skip any conversions and simple arithmetics to see if the expression
- is a read-only variable.
- ??? This really should remain read-only, but we have to think about
- the typing of the tree here. */
- tree gnu_inner_expr
- = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
- tree gnu_decl = NULL_TREE;
- bool expr_global = Is_Public (gnat_entity) || global_bindings_p ();
- bool expr_variable;
+ const bool expr_public_p = Is_Public (gnat_entity);
+ const bool expr_global_p = expr_public_p || global_bindings_p ();
+ bool expr_variable_p, use_variable;
/* In most cases, we won't see a naked FIELD_DECL because a discriminant
reference will have been replaced with a COMPONENT_REF when the type
build0 (PLACEHOLDER_EXPR, DECL_CONTEXT (gnu_expr)),
gnu_expr, NULL_TREE);
- /* If GNU_EXPR is neither a placeholder nor a constant, nor a variable
- that is read-only, make a variable that is initialized to contain the
- bound when the package containing the definition is elaborated. If
- this entity is defined at top level and a bound or discriminant value
- isn't a constant or a reference to a discriminant, replace the bound
- by the variable; otherwise use a SAVE_EXPR if needed. Note that we
- rely here on the fact that an expression cannot contain both the
- discriminant and some other variable. */
- expr_variable = (!CONSTANT_CLASS_P (gnu_expr)
- && !(TREE_CODE (gnu_inner_expr) == VAR_DECL
- && (TREE_READONLY (gnu_inner_expr)
- || DECL_READONLY_ONCE_ELAB (gnu_inner_expr)))
- && !CONTAINS_PLACEHOLDER_P (gnu_expr));
-
- /* If GNU_EXPR contains a discriminant, we can't elaborate a variable. */
- if (need_debug && CONTAINS_PLACEHOLDER_P (gnu_expr))
- need_debug = false;
+ /* If GNU_EXPR contains a placeholder, just return it. We rely on the fact
+ that an expression cannot contain both a discriminant and a variable. */
+ if (CONTAINS_PLACEHOLDER_P (gnu_expr))
+ return gnu_expr;
+
+ /* If GNU_EXPR is neither a constant nor based on a read-only variable, make
+ a variable that is initialized to contain the expression when the package
+ containing the definition is elaborated. If this entity is defined at top
+ level, replace the expression by the variable; otherwise use a SAVE_EXPR
+ if this is necessary. */
+ if (CONSTANT_CLASS_P (gnu_expr))
+ expr_variable_p = false;
+ else
+ {
+ /* Skip any conversions and simple arithmetics to see if the expression
+ is based on a read-only variable.
+ ??? This really should remain read-only, but we have to think about
+ the typing of the tree here. */
+ tree inner
+ = skip_simple_arithmetic (remove_conversions (gnu_expr, true));
+
+ if (handled_component_p (inner))
+ {
+ HOST_WIDE_INT bitsize, bitpos;
+ tree offset;
+ enum machine_mode mode;
+ int unsignedp, volatilep;
+
+ inner = get_inner_reference (inner, &bitsize, &bitpos, &offset,
+ &mode, &unsignedp, &volatilep, false);
+ /* If the offset is variable, err on the side of caution. */
+ if (offset)
+ inner = NULL_TREE;
+ }
- /* Now create the variable if we need it. */
- if (need_debug || (expr_variable && expr_global))
- gnu_decl
- = create_var_decl (create_concat_name (gnat_entity,
- IDENTIFIER_POINTER (gnu_name)),
- NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr,
- !need_debug, Is_Public (gnat_entity),
- !definition, false, NULL, gnat_entity);
-
- /* 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 (expr_global && expr_variable)
- return gnu_decl;
-
- return expr_variable ? gnat_save_expr (gnu_expr) : gnu_expr;
+ expr_variable_p
+ = !(inner
+ && TREE_CODE (inner) == VAR_DECL
+ && (TREE_READONLY (inner) || DECL_READONLY_ONCE_ELAB (inner)));
+ }
+
+ /* We only need to use the variable if we are in a global context since GCC
+ can do the right thing in the local case. However, when not optimizing,
+ use it for bounds of loop iteration scheme to avoid code duplication. */
+ use_variable = expr_variable_p
+ && (expr_global_p
+ || (!optimize
+ && Is_Itype (gnat_entity)
+ && Nkind (Associated_Node_For_Itype (gnat_entity))
+ == N_Loop_Parameter_Specification));
+
+ /* Now create it, possibly only for debugging purposes. */
+ if (use_variable || need_debug)
+ {
+ tree gnu_decl
+ = create_var_decl_1
+ (create_concat_name (gnat_entity, IDENTIFIER_POINTER (gnu_name)),
+ NULL_TREE, TREE_TYPE (gnu_expr), gnu_expr, true, expr_public_p,
+ !definition, expr_global_p, !need_debug, NULL, gnat_entity);
+
+ if (use_variable)
+ return gnu_decl;
+ }
+
+ return expr_variable_p ? gnat_save_expr (gnu_expr) : gnu_expr;
}
/* Similar, but take an alignment factor and make it explicit in the tree. */
/* Now copy the fields, keeping the position and size as we don't want
to change the layout by propagating the packedness downwards. */
for (old_field = TYPE_FIELDS (type); old_field;
- old_field = TREE_CHAIN (old_field))
+ old_field = DECL_CHAIN (old_field))
{
tree new_field_type = TREE_TYPE (old_field);
tree new_field, new_size;
- if ((TREE_CODE (new_field_type) == RECORD_TYPE
- || TREE_CODE (new_field_type) == UNION_TYPE
- || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
+ if (RECORD_OR_UNION_TYPE_P (new_field_type)
&& !TYPE_FAT_POINTER_P (new_field_type)
&& host_integerp (TYPE_SIZE (new_field_type), 1))
new_field_type = make_packable_type (new_field_type, true);
/* However, for the last field in a not already packed record type
that is of an aggregate type, we need to use the RM size in the
packable version of the record type, see finish_record_type. */
- if (!TREE_CHAIN (old_field)
+ if (!DECL_CHAIN (old_field)
&& !TYPE_PACKED (type)
- && (TREE_CODE (new_field_type) == RECORD_TYPE
- || TREE_CODE (new_field_type) == UNION_TYPE
- || TREE_CODE (new_field_type) == QUAL_UNION_TYPE)
+ && RECORD_OR_UNION_TYPE_P (new_field_type)
&& !TYPE_FAT_POINTER_P (new_field_type)
&& !TYPE_CONTAINS_TEMPLATE_P (new_field_type)
&& TYPE_ADA_SIZE (new_field_type))
if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
- TREE_CHAIN (new_field) = field_list;
+ DECL_CHAIN (new_field) = field_list;
field_list = new_field;
}
finish_record_type (new_type, nreverse (field_list), 2, false);
relate_alias_sets (new_type, type, ALIAS_SET_COPY);
+ SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
+ DECL_PARALLEL_TYPE (TYPE_STUB_DECL (type)));
/* If this is a padding record, we never want to make the size smaller
than what was specified. For QUAL_UNION_TYPE, also copy the size. */
between them and it might be hard to overcome afterwards, including
at the RTL level when the stand-alone object is accessed as a whole. */
if (align != 0
- && TREE_CODE (type) == RECORD_TYPE
+ && RECORD_OR_UNION_TYPE_P (type)
&& TYPE_MODE (type) == BLKmode
+ && !TYPE_BY_REFERENCE_P (type)
&& TREE_CODE (orig_size) == INTEGER_CST
&& !TREE_OVERFLOW (orig_size)
&& compare_tree_int (orig_size, MAX_FIXED_MODE_SIZE) <= 0
{
Node_Id choice;
Node_Id gnat_temp;
- tree result = integer_zero_node;
+ tree result = boolean_false_node;
tree this_test, low = 0, high = 0, single = 0;
for (choice = First (choices); Present (choice); choice = Next (choice))
break;
case N_Others_Choice:
- this_test = integer_one_node;
+ this_test = boolean_true_node;
break;
default:
because we cannot create temporaries of non-fixed size in case
we need to take the address of the field. See addressable_p and
the notes on the addressability issues for further details. */
- if (is_variable_size (field_type))
+ if (type_has_variable_size (field_type))
return 0;
/* If the alignment of the record is specified and the field type
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
bool definition, bool debug_info_p)
{
+ const Entity_Id gnat_field_type = Etype (gnat_field);
+ tree gnu_field_type = gnat_to_gnu_type (gnat_field_type);
tree gnu_field_id = get_entity_name (gnat_field);
- tree gnu_field_type = gnat_to_gnu_type (Etype (gnat_field));
tree gnu_field, gnu_size, gnu_pos;
+ bool is_volatile
+ = (Treat_As_Volatile (gnat_field) || Treat_As_Volatile (gnat_field_type));
bool needs_strict_alignment
- = (Is_Aliased (gnat_field) || Strict_Alignment (Etype (gnat_field))
- || Treat_As_Volatile (gnat_field));
+ = (is_volatile
+ || Is_Aliased (gnat_field)
+ || Strict_Alignment (gnat_field_type));
/* If this field requires strict alignment, we cannot pack it because
it would very likely be under-aligned in the record. */
/* If a size is specified, use it. Otherwise, if the record type is packed,
use the official RM size. See "Handling of Type'Size Values" in Einfo
for further details. */
- if (Known_Static_Esize (gnat_field))
+ if (Known_Esize (gnat_field))
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
else if (packed == 1)
- gnu_size = validate_size (RM_Size (Etype (gnat_field)), gnu_field_type,
+ gnu_size = validate_size (RM_Size (gnat_field_type), gnu_field_type,
gnat_field, FIELD_DECL, false, true);
else
gnu_size = NULL_TREE;
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. */
if (!needs_strict_alignment
- && TREE_CODE (gnu_field_type) == RECORD_TYPE
+ && RECORD_OR_UNION_TYPE_P (gnu_field_type)
&& !TYPE_FAT_POINTER_P (gnu_field_type)
&& host_integerp (TYPE_SIZE (gnu_field_type), 1)
&& (packed == 1
}
}
- /* If we are packing the record and the field is BLKmode, round the
- size up to a byte boundary. */
- if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
- gnu_size = round_up (gnu_size, BITS_PER_UNIT);
+ if (Is_Atomic (gnat_field))
+ check_ok_for_atomic (gnu_field_type, gnat_field, false);
if (Present (Component_Clause (gnat_field)))
{
if (gnu_size
&& !operand_equal_p (gnu_size, TYPE_SIZE (gnu_field_type), 0))
{
- if (Is_Atomic (gnat_field) || Is_Atomic (Etype (gnat_field)))
+ if (Is_Atomic (gnat_field) || Is_Atomic (gnat_field_type))
post_error_ne_tree
("atomic field& must be natural size of type{ (^)}",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
Last_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_SIZE (gnu_field_type));
- else if (Strict_Alignment (Etype (gnat_field)))
+ else if (Strict_Alignment (gnat_field_type))
post_error_ne_tree
("size of & with aliased or tagged components not ^ bits",
Last_Bit (Component_Clause (gnat_field)), gnat_field,
(TRUNC_MOD_EXPR, gnu_pos,
bitsize_int (TYPE_ALIGN (gnu_field_type)))))
{
- if (Is_Aliased (gnat_field))
- post_error_ne_num
- ("position of aliased field& must be multiple of ^ bits",
- First_Bit (Component_Clause (gnat_field)), gnat_field,
- TYPE_ALIGN (gnu_field_type));
-
- else if (Treat_As_Volatile (gnat_field))
+ if (is_volatile)
post_error_ne_num
("position of volatile field& must be multiple of ^ bits",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
- else if (Strict_Alignment (Etype (gnat_field)))
+ else if (Is_Aliased (gnat_field))
post_error_ne_num
- ("position of & with aliased or tagged components not multiple of ^ bits",
+ ("position of aliased field& must be multiple of ^ bits",
First_Bit (Component_Clause (gnat_field)), gnat_field,
TYPE_ALIGN (gnu_field_type));
+ else if (Strict_Alignment (gnat_field_type))
+ post_error_ne
+ ("position of & is not compatible with alignment required "
+ "by its components",
+ First_Bit (Component_Clause (gnat_field)), gnat_field);
+
else
gcc_unreachable ();
gnu_pos = NULL_TREE;
}
}
-
- if (Is_Atomic (gnat_field))
- check_ok_for_atomic (gnu_field_type, gnat_field, false);
}
/* If the record has rep clauses and this is the tag field, make a rep
}
else
- gnu_pos = NULL_TREE;
+ {
+ gnu_pos = NULL_TREE;
+
+ /* If we are packing the record and the field is BLKmode, round the
+ size up to a byte boundary. */
+ if (packed && TYPE_MODE (gnu_field_type) == BLKmode && gnu_size)
+ gnu_size = round_up (gnu_size, BITS_PER_UNIT);
+ }
/* We need to make the size the maximum for the type if it is
self-referential and an unconstrained type. In that case, we can't
if (TREE_CODE (gnu_field_type) == RECORD_TYPE
&& !gnu_size
&& CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_field_type))
- && !Is_Constrained (Underlying_Type (Etype (gnat_field))))
+ && !Is_Constrained (Underlying_Type (gnat_field_type)))
{
gnu_size = max_size (TYPE_SIZE (gnu_field_type), true);
packed = 0;
= create_field_decl (gnu_field_id, gnu_field_type, gnu_record_type,
gnu_size, gnu_pos, packed, Is_Aliased (gnat_field));
Sloc_to_locus (Sloc (gnat_field), &DECL_SOURCE_LOCATION (gnu_field));
- TREE_THIS_VOLATILE (gnu_field) = Treat_As_Volatile (gnat_field);
+ DECL_ALIASED_P (gnu_field) = Is_Aliased (gnat_field);
+ TREE_THIS_VOLATILE (gnu_field) = TREE_SIDE_EFFECTS (gnu_field) = is_volatile;
if (Ekind (gnat_field) == E_Discriminant)
DECL_DISCRIMINANT_NUMBER (gnu_field)
return gnu_field;
}
\f
-/* Return true if TYPE is a type with variable size, a padding type with a
- field of variable size or is a record that has a field such a field. */
+/* Return true if TYPE is a type with variable size or a padding type with a
+ field of variable size or a record that has a field with such a type. */
static bool
-is_variable_size (tree type)
+type_has_variable_size (tree type)
{
tree field;
&& !TREE_CONSTANT (DECL_SIZE (TYPE_FIELDS (type))))
return true;
- if (TREE_CODE (type) != RECORD_TYPE
- && TREE_CODE (type) != UNION_TYPE
- && TREE_CODE (type) != QUAL_UNION_TYPE)
+ if (!RECORD_OR_UNION_TYPE_P (type))
return false;
- for (field = TYPE_FIELDS (type); field; field = TREE_CHAIN (field))
- if (is_variable_size (TREE_TYPE (field)))
+ for (field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
+ if (type_has_variable_size (TREE_TYPE (field)))
return true;
return false;
}
\f
+/* Return true if FIELD is an artificial field. */
+
+static bool
+field_is_artificial (tree field)
+{
+ /* These fields are generated by the front-end proper. */
+ if (IDENTIFIER_POINTER (DECL_NAME (field)) [0] == '_')
+ return true;
+
+ /* These fields are generated by gigi. */
+ if (DECL_INTERNAL_P (field))
+ return true;
+
+ return false;
+}
+
+/* Return true if FIELD is a non-artificial aliased field. */
+
+static bool
+field_is_aliased (tree field)
+{
+ if (field_is_artificial (field))
+ return false;
+
+ return DECL_ALIASED_P (field);
+}
+
+/* Return true if FIELD is a non-artificial field with self-referential
+ size. */
+
+static bool
+field_has_self_size (tree field)
+{
+ if (field_is_artificial (field))
+ return false;
+
+ if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
+ return false;
+
+ return CONTAINS_PLACEHOLDER_P (TYPE_SIZE (TREE_TYPE (field)));
+}
+
+/* Return true if FIELD is a non-artificial field with variable size. */
+
+static bool
+field_has_variable_size (tree field)
+{
+ if (field_is_artificial (field))
+ return false;
+
+ if (DECL_SIZE (field) && TREE_CODE (DECL_SIZE (field)) == INTEGER_CST)
+ return false;
+
+ return TREE_CODE (TYPE_SIZE (TREE_TYPE (field))) != INTEGER_CST;
+}
+
/* qsort comparer for the bit positions of two record components. */
static int
DEFINITION is true if we are defining this record type.
- P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
- with a rep clause is to be added; in this case, that is all that should
- be done with such fields.
-
CANCEL_ALIGNMENT is true if the alignment should be zeroed before laying
out the record. This means the alignment only serves to force fields to
be bitfields, but not to require the record to be that aligned. This is
UNCHECKED_UNION is true if we are building this type for a record with a
Pragma Unchecked_Union.
- DEBUG_INFO_P is true if we need to write debug information about the type.
+ ARTIFICIAL is true if this is a type that was generated by the compiler.
+
+ DEBUG_INFO is true if we need to write debug information about the type.
MAYBE_UNUSED is true if this type may be unused in the end; this doesn't
- mean that its contents may be unused as well, but only the container. */
+ mean that its contents may be unused as well, only the container itself.
+
+ REORDER is true if we are permitted to reorder components of this type.
+ FIRST_FREE_POS, if nonzero, is the first (lowest) free field position in
+ the outer record type down to this variant level. It is nonzero only if
+ all the fields down to this level have a rep clause and ALL_REP is false.
+
+ P_GNU_REP_LIST, if nonzero, is a pointer to a list to which each field
+ with a rep clause is to be added; in this case, that is all that should
+ be done with such fields. */
static void
components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
tree gnu_field_list, int packed, bool definition,
- tree *p_gnu_rep_list, bool cancel_alignment,
- bool all_rep, bool unchecked_union, bool debug_info_p,
- bool maybe_unused)
+ bool cancel_alignment, bool all_rep,
+ bool unchecked_union, bool artificial,
+ bool debug_info, bool maybe_unused, bool reorder,
+ tree first_free_pos, tree *p_gnu_rep_list)
{
bool all_rep_and_size = all_rep && TYPE_SIZE (gnu_record_type);
bool layout_with_rep = false;
+ bool has_self_field = false;
+ bool has_aliased_after_self_field = false;
Node_Id component_decl, variant_part;
- tree gnu_our_rep_list = NULL_TREE;
- tree gnu_field, gnu_next, gnu_last = tree_last (gnu_field_list);
+ tree gnu_field, gnu_next, gnu_last;
+ tree gnu_rep_part = NULL_TREE;
+ tree gnu_variant_part = NULL_TREE;
+ tree gnu_rep_list = NULL_TREE;
+ tree gnu_var_list = NULL_TREE;
+ tree gnu_self_list = NULL_TREE;
/* For each component referenced in a component declaration create a GCC
field and add it to the list, skipping pragmas in the GNAT list. */
+ gnu_last = tree_last (gnu_field_list);
if (Present (Component_Items (gnat_component_list)))
for (component_decl
= First_Non_Pragma (Component_Items (gnat_component_list));
else
{
gnu_field = gnat_to_gnu_field (gnat_field, gnu_record_type, packed,
- definition, debug_info_p);
+ definition, debug_info);
/* If this is the _Tag field, put it before any other fields. */
if (gnat_name == Name_uTag)
fields except for the _Tag or _Parent field. */
else if (gnat_name == Name_uController && gnu_last)
{
- TREE_CHAIN (gnu_field) = TREE_CHAIN (gnu_last);
- TREE_CHAIN (gnu_last) = gnu_field;
+ DECL_CHAIN (gnu_field) = DECL_CHAIN (gnu_last);
+ DECL_CHAIN (gnu_last) = gnu_field;
}
/* If this is a regular field, put it after the other fields. */
else
{
- TREE_CHAIN (gnu_field) = gnu_field_list;
+ DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
if (!gnu_last)
gnu_last = gnu_field;
+
+ /* And record information for the final layout. */
+ if (field_has_self_size (gnu_field))
+ has_self_field = true;
+ else if (has_self_field && field_is_aliased (gnu_field))
+ has_aliased_after_self_field = true;
}
}
tree gnu_var_name
= concat_name (get_identifier (Get_Name_String (Chars (gnat_discr))),
"XVN");
- tree gnu_union_type, gnu_union_name, gnu_union_field;
- tree gnu_variant_list = NULL_TREE;
+ tree gnu_union_type, gnu_union_name;
+ tree this_first_free_pos, gnu_variant_list = NULL_TREE;
if (TREE_CODE (gnu_name) == TYPE_DECL)
gnu_name = DECL_NAME (gnu_name);
gnu_union_name
= concat_name (gnu_name, IDENTIFIER_POINTER (gnu_var_name));
- /* Reuse an enclosing union if all fields are in the variant part
- and there is no representation clause on the record, to match
- the layout of C unions. There is an associated check below. */
- if (!gnu_field_list
- && TREE_CODE (gnu_record_type) == UNION_TYPE
- && !TYPE_PACKED (gnu_record_type))
+ /* Reuse the enclosing union if this is an Unchecked_Union whose fields
+ are all in the variant part, to match the layout of C unions. There
+ is an associated check below. */
+ if (TREE_CODE (gnu_record_type) == UNION_TYPE)
gnu_union_type = gnu_record_type;
else
{
TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
}
+ /* If all the fields down to this level have a rep clause, find out
+ whether all the fields at this level also have one. If so, then
+ compute the new first free position to be passed downward. */
+ this_first_free_pos = first_free_pos;
+ if (this_first_free_pos)
+ {
+ for (gnu_field = gnu_field_list;
+ gnu_field;
+ gnu_field = DECL_CHAIN (gnu_field))
+ if (DECL_FIELD_OFFSET (gnu_field))
+ {
+ tree pos = bit_position (gnu_field);
+ if (!tree_int_cst_lt (pos, this_first_free_pos))
+ this_first_free_pos
+ = size_binop (PLUS_EXPR, pos, DECL_SIZE (gnu_field));
+ }
+ else
+ {
+ this_first_free_pos = NULL_TREE;
+ break;
+ }
+ }
+
for (variant = First_Non_Pragma (Variants (variant_part));
Present (variant);
variant = Next_Non_Pragma (variant))
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
/* Similarly, if the outer record has a size specified and all
- fields have record rep clauses, we can propagate the size
- into the variant part. */
+ the fields have a rep clause, we can propagate the size. */
if (all_rep_and_size)
{
TYPE_SIZE (gnu_variant_type) = TYPE_SIZE (gnu_record_type);
we aren't sure to really use it at this point, see below. */
components_to_record (gnu_variant_type, Component_List (variant),
NULL_TREE, packed, definition,
- &gnu_our_rep_list, !all_rep_and_size, all_rep,
- unchecked_union, debug_info_p, true);
+ !all_rep_and_size, all_rep, unchecked_union,
+ true, debug_info, true, reorder,
+ this_first_free_pos,
+ all_rep || this_first_free_pos
+ ? NULL : &gnu_rep_list);
gnu_qual = choices_to_gnu (gnu_discr, Discrete_Choices (variant));
-
Set_Present_Expr (variant, annotate_value (gnu_qual));
- /* If this is an Unchecked_Union and we have exactly one field,
- use this field directly to match the layout of C unions. */
- if (unchecked_union
- && TYPE_FIELDS (gnu_variant_type)
- && !TREE_CHAIN (TYPE_FIELDS (gnu_variant_type)))
- gnu_field = TYPE_FIELDS (gnu_variant_type);
+ /* If this is an Unchecked_Union whose fields are all in the variant
+ part and we have a single field with no representation clause or
+ placed at offset zero, use the field directly to match the layout
+ of C unions. */
+ if (TREE_CODE (gnu_record_type) == UNION_TYPE
+ && (gnu_field = TYPE_FIELDS (gnu_variant_type)) != NULL_TREE
+ && !DECL_CHAIN (gnu_field)
+ && (!DECL_FIELD_OFFSET (gnu_field)
+ || integer_zerop (bit_position (gnu_field))))
+ DECL_CONTEXT (gnu_field) = gnu_union_type;
else
{
/* Deal with packedness like in gnat_to_gnu_field. */
the fields associated with these empty variants. */
rest_of_record_type_compilation (gnu_variant_type);
create_type_decl (TYPE_NAME (gnu_variant_type), gnu_variant_type,
- NULL, true, debug_info_p, gnat_component_list);
+ NULL, true, debug_info, gnat_component_list);
gnu_field
= create_field_decl (gnu_inner_name, gnu_variant_type,
DECL_QUALIFIER (gnu_field) = gnu_qual;
}
- TREE_CHAIN (gnu_field) = gnu_variant_list;
+ DECL_CHAIN (gnu_field) = gnu_variant_list;
gnu_variant_list = gnu_field;
}
}
finish_record_type (gnu_union_type, nreverse (gnu_variant_list),
- all_rep_and_size ? 1 : 0, debug_info_p);
+ all_rep_and_size ? 1 : 0, debug_info);
/* 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
{
gcc_assert (unchecked_union
&& !gnu_field_list
- && !gnu_our_rep_list);
+ && !gnu_rep_list);
return;
}
create_type_decl (TYPE_NAME (gnu_union_type), gnu_union_type,
- NULL, true, debug_info_p, gnat_component_list);
+ NULL, true, debug_info, gnat_component_list);
/* Deal with packedness like in gnat_to_gnu_field. */
union_field_packed
= adjust_packed (gnu_union_type, gnu_record_type, packed);
- gnu_union_field
+ gnu_variant_part
= create_field_decl (gnu_var_name, gnu_union_type, gnu_record_type,
all_rep ? TYPE_SIZE (gnu_union_type) : 0,
- all_rep ? bitsize_zero_node : 0,
+ all_rep || this_first_free_pos
+ ? bitsize_zero_node : 0,
union_field_packed, 0);
- DECL_INTERNAL_P (gnu_union_field) = 1;
- TREE_CHAIN (gnu_union_field) = gnu_field_list;
- gnu_field_list = gnu_union_field;
+ DECL_INTERNAL_P (gnu_variant_part) = 1;
}
}
- /* Scan GNU_FIELD_LIST and see if any fields have rep clauses. If they
- do, pull them out and put them into GNU_OUR_REP_LIST. We have to do
- this in a separate pass since we want to handle the discriminants but
- can't play with them until we've used them in debugging data above.
+ /* From now on, a zero FIRST_FREE_POS is totally useless. */
+ if (first_free_pos && integer_zerop (first_free_pos))
+ first_free_pos = NULL_TREE;
- ??? If we then reorder them, debugging information will be wrong but
- there's nothing that can be done about this at the moment. */
+ /* Scan GNU_FIELD_LIST and see if any fields have rep clauses and, if we are
+ permitted to reorder components, self-referential sizes or variable sizes.
+ If they do, pull them out and put them onto the appropriate list. We have
+ to do this in a separate pass since we want to handle the discriminants
+ but can't play with them until we've used them in debugging data above.
+
+ ??? If we reorder them, debugging information will be wrong but there is
+ nothing that can be done about this at the moment. */
gnu_last = NULL_TREE;
+
+#define MOVE_FROM_FIELD_LIST_TO(LIST) \
+ do { \
+ if (gnu_last) \
+ DECL_CHAIN (gnu_last) = gnu_next; \
+ else \
+ gnu_field_list = gnu_next; \
+ \
+ DECL_CHAIN (gnu_field) = (LIST); \
+ (LIST) = gnu_field; \
+ } while (0)
+
for (gnu_field = gnu_field_list; gnu_field; gnu_field = gnu_next)
{
- gnu_next = TREE_CHAIN (gnu_field);
+ gnu_next = DECL_CHAIN (gnu_field);
if (DECL_FIELD_OFFSET (gnu_field))
{
- if (!gnu_last)
- gnu_field_list = gnu_next;
- else
- TREE_CHAIN (gnu_last) = gnu_next;
+ MOVE_FROM_FIELD_LIST_TO (gnu_rep_list);
+ continue;
+ }
- TREE_CHAIN (gnu_field) = gnu_our_rep_list;
- gnu_our_rep_list = gnu_field;
+ if ((reorder || has_aliased_after_self_field)
+ && field_has_self_size (gnu_field))
+ {
+ MOVE_FROM_FIELD_LIST_TO (gnu_self_list);
+ continue;
}
- else
- gnu_last = gnu_field;
+
+ if (reorder && field_has_variable_size (gnu_field))
+ {
+ MOVE_FROM_FIELD_LIST_TO (gnu_var_list);
+ continue;
+ }
+
+ gnu_last = gnu_field;
}
- /* If we have any fields in our rep'ed field list and it is not the case that
- all the fields in the record have rep clauses and P_REP_LIST is nonzero,
- set it and ignore these fields. */
- if (gnu_our_rep_list && p_gnu_rep_list && !all_rep)
- *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_our_rep_list);
+#undef MOVE_FROM_FIELD_LIST_TO
+
+ /* If permitted, we reorder the fields as follows:
+
+ 1) all fixed length fields,
+ 2) all fields whose length doesn't depend on discriminants,
+ 3) all fields whose length depends on discriminants,
+ 4) the variant part,
+
+ within the record and within each variant recursively. */
+ if (reorder)
+ gnu_field_list
+ = chainon (nreverse (gnu_self_list),
+ chainon (nreverse (gnu_var_list), gnu_field_list));
+
+ /* Otherwise, if there is an aliased field placed after a field whose length
+ depends on discriminants, we put all the fields of the latter sort, last.
+ We need to do this in case an object of this record type is mutable. */
+ else if (has_aliased_after_self_field)
+ gnu_field_list = chainon (nreverse (gnu_self_list), gnu_field_list);
+
+ /* If P_REP_LIST is nonzero, this means that we are asked to move the fields
+ in our REP list to the previous level because this level needs them in
+ order to do a correct layout, i.e. avoid having overlapping fields. */
+ if (p_gnu_rep_list && gnu_rep_list)
+ *p_gnu_rep_list = chainon (*p_gnu_rep_list, gnu_rep_list);
/* Otherwise, sort the fields by bit position and put them into their own
- record, before the others, if we also have fields without rep clauses. */
- else if (gnu_our_rep_list)
+ record, before the others, if we also have fields without rep clause. */
+ else if (gnu_rep_list)
{
tree gnu_rep_type
= (gnu_field_list ? make_node (RECORD_TYPE) : gnu_record_type);
- int i, len = list_length (gnu_our_rep_list);
- tree *gnu_arr = (tree *) alloca (sizeof (tree) * len);
+ int i, len = list_length (gnu_rep_list);
+ tree *gnu_arr = XALLOCAVEC (tree, len);
- for (gnu_field = gnu_our_rep_list, i = 0;
+ for (gnu_field = gnu_rep_list, i = 0;
gnu_field;
- gnu_field = TREE_CHAIN (gnu_field), i++)
+ gnu_field = DECL_CHAIN (gnu_field), i++)
gnu_arr[i] = gnu_field;
qsort (gnu_arr, len, sizeof (tree), compare_field_bitpos);
/* Put the fields in the list in order of increasing position, which
means we start from the end. */
- gnu_our_rep_list = NULL_TREE;
+ gnu_rep_list = NULL_TREE;
for (i = len - 1; i >= 0; i--)
{
- TREE_CHAIN (gnu_arr[i]) = gnu_our_rep_list;
- gnu_our_rep_list = gnu_arr[i];
+ DECL_CHAIN (gnu_arr[i]) = gnu_rep_list;
+ gnu_rep_list = gnu_arr[i];
DECL_CONTEXT (gnu_arr[i]) = gnu_rep_type;
}
if (gnu_field_list)
{
- finish_record_type (gnu_rep_type, gnu_our_rep_list, 1, debug_info_p);
- gnu_field
- = create_field_decl (get_identifier ("REP"), gnu_rep_type,
- gnu_record_type, NULL_TREE, NULL_TREE, 0, 1);
- DECL_INTERNAL_P (gnu_field) = 1;
- gnu_field_list = chainon (gnu_field_list, gnu_field);
+ finish_record_type (gnu_rep_type, gnu_rep_list, 1, debug_info);
+
+ /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields
+ without rep clause are laid out starting from this position.
+ Therefore, we force it as a minimal size on the REP part. */
+ gnu_rep_part
+ = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
}
else
{
layout_with_rep = true;
- gnu_field_list = nreverse (gnu_our_rep_list);
+ gnu_field_list = nreverse (gnu_rep_list);
}
}
+ /* If FIRST_FREE_POS is nonzero, we need to ensure that the fields without
+ rep clause are laid out starting from this position. Therefore, if we
+ have not already done so, we create a fake REP part with this size. */
+ if (first_free_pos && !layout_with_rep && !gnu_rep_part)
+ {
+ tree gnu_rep_type = make_node (RECORD_TYPE);
+ finish_record_type (gnu_rep_type, NULL_TREE, 0, debug_info);
+ gnu_rep_part
+ = create_rep_part (gnu_rep_type, gnu_record_type, first_free_pos);
+ }
+
+ /* Now chain the REP part at the end of the reversed field list. */
+ if (gnu_rep_part)
+ gnu_field_list = chainon (gnu_field_list, gnu_rep_part);
+
+ /* And the variant part at the beginning. */
+ if (gnu_variant_part)
+ {
+ DECL_CHAIN (gnu_variant_part) = gnu_field_list;
+ gnu_field_list = gnu_variant_part;
+ }
+
if (cancel_alignment)
TYPE_ALIGN (gnu_record_type) = 0;
finish_record_type (gnu_record_type, nreverse (gnu_field_list),
- layout_with_rep ? 1 : 0, debug_info_p && !maybe_unused);
+ layout_with_rep ? 1 : 0, false);
+ TYPE_ARTIFICIAL (gnu_record_type) = artificial;
+ if (debug_info && !maybe_unused)
+ rest_of_record_type_compilation (gnu_record_type);
}
\f
/* Given GNU_SIZE, a GCC tree representing a size, return a Uint to be
{
TCode tcode;
Node_Ref_Or_Val ops[3], ret;
- struct tree_int_map **h = NULL;
+ struct tree_int_map in;
int i;
/* See if we've already saved the value for this node. */
if (EXPR_P (gnu_size))
{
- struct tree_int_map in;
+ struct tree_int_map *e;
+
if (!annotate_value_cache)
annotate_value_cache = htab_create_ggc (512, tree_int_map_hash,
tree_int_map_eq, 0);
in.base.from = gnu_size;
- h = (struct tree_int_map **)
- htab_find_slot (annotate_value_cache, &in, INSERT);
+ e = (struct tree_int_map *)
+ htab_find (annotate_value_cache, &in);
- if (*h)
- return (Node_Ref_Or_Val) (*h)->to;
+ if (e)
+ return (Node_Ref_Or_Val) e->to;
}
+ else
+ in.base.from = NULL_TREE;
/* If we do not return inside this switch, TCODE will be set to the
code to use for a Create_Node operand and LEN (set above) will be
ret = Create_Node (tcode, ops[0], ops[1], ops[2]);
/* Save the result in the cache. */
- if (h)
+ if (in.base.from)
{
- *h = GGC_NEW (struct tree_int_map);
+ struct tree_int_map **h;
+ /* We can't assume the hash table data hasn't moved since the
+ initial look up, so we have to search again. Allocating and
+ inserting an entry at that point would be an alternative, but
+ then we'd better discard the entry if we decided not to cache
+ it. */
+ h = (struct tree_int_map **)
+ htab_find_slot (annotate_value_cache, &in, INSERT);
+ gcc_assert (!*h);
+ *h = ggc_alloc_tree_int_map ();
(*h)->base.from = gnu_size;
(*h)->to = ret;
}
/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
- BY_REF is true if the object is used by reference. */
+ BY_REF is true if the object is used by reference and BY_DOUBLE_REF is
+ true if the object is used by double reference. */
void
-annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref)
+annotate_object (Entity_Id gnat_entity, tree gnu_type, tree size, bool by_ref,
+ bool by_double_ref)
{
if (by_ref)
{
+ if (by_double_ref)
+ gnu_type = TREE_TYPE (gnu_type);
+
if (TYPE_IS_FAT_POINTER_P (gnu_type))
gnu_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
else
{
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
- size = TYPE_SIZE (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type))));
+ size = TYPE_SIZE (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type))));
else if (!size)
size = TYPE_SIZE (gnu_type);
for (gnu_field = TYPE_FIELDS (gnu_type);
gnu_field;
- gnu_field = TREE_CHAIN (gnu_field))
+ gnu_field = DECL_CHAIN (gnu_field))
{
tree gnu_our_bitpos = size_binop (PLUS_EXPR, gnu_bitpos,
DECL_FIELD_BIT_OFFSET (gnu_field));
return gnu_list;
}
-/* Return a TREE_LIST describing the substitutions needed to reflect the
+/* Return a VEC describing the substitutions needed to reflect the
discriminant substitutions from GNAT_TYPE to GNAT_SUBTYPE. They can
- be in any order. TREE_PURPOSE gives the tree for the discriminant and
- TREE_VALUE is the replacement value. They are in the form of operands
- to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for a definition
- of GNAT_SUBTYPE. */
+ be in any order. The values in an element of the VEC are in the form
+ of operands to SUBSTITUTE_IN_EXPR. DEFINITION is true if this is for
+ a definition of GNAT_SUBTYPE. */
-static tree
+static VEC(subst_pair,heap) *
build_subst_list (Entity_Id gnat_subtype, Entity_Id gnat_type, bool definition)
{
- tree gnu_list = NULL_TREE;
+ VEC(subst_pair,heap) *gnu_vec = NULL;
Entity_Id gnat_discrim;
Node_Id gnat_value;
if (!Is_Access_Type (Etype (Node (gnat_value))))
{
tree gnu_field = gnat_to_gnu_field_decl (gnat_discrim);
- gnu_list = tree_cons (gnu_field,
- convert (TREE_TYPE (gnu_field),
- elaborate_expression
- (Node (gnat_value), gnat_subtype,
- get_entity_name (gnat_discrim),
- definition, true, false)),
- gnu_list);
+ tree replacement = convert (TREE_TYPE (gnu_field),
+ elaborate_expression
+ (Node (gnat_value), gnat_subtype,
+ get_entity_name (gnat_discrim),
+ definition, true, false));
+ subst_pair *s = VEC_safe_push (subst_pair, heap, gnu_vec, NULL);
+ s->discriminant = gnu_field;
+ s->replacement = replacement;
}
- return gnu_list;
+ return gnu_vec;
}
-/* Scan all fields in QUAL_UNION_TYPE and return a TREE_LIST describing the
- variants of QUAL_UNION_TYPE that are still relevant after applying the
- substitutions described in SUBST_LIST. TREE_PURPOSE is the type of the
- variant and TREE_VALUE is a TREE_VEC containing the field, the new value
- of the qualifier and NULL_TREE respectively. GNU_LIST is a pre-existing
- list to be chained to the newly created entries. */
+/* Scan all fields in QUAL_UNION_TYPE and return a VEC describing the
+ variants of QUAL_UNION_TYPE that are still relevant after applying
+ the substitutions described in SUBST_LIST. VARIANT_LIST is a
+ pre-existing VEC onto which newly created entries should be
+ pushed. */
-static tree
-build_variant_list (tree qual_union_type, tree subst_list, tree gnu_list)
+static VEC(variant_desc,heap) *
+build_variant_list (tree qual_union_type, VEC(subst_pair,heap) *subst_list,
+ VEC(variant_desc,heap) *variant_list)
{
tree gnu_field;
for (gnu_field = TYPE_FIELDS (qual_union_type);
gnu_field;
- gnu_field = TREE_CHAIN (gnu_field))
+ gnu_field = DECL_CHAIN (gnu_field))
{
- tree t, qual = DECL_QUALIFIER (gnu_field);
+ tree qual = DECL_QUALIFIER (gnu_field);
+ unsigned ix;
+ subst_pair *s;
- for (t = subst_list; t; t = TREE_CHAIN (t))
- qual = SUBSTITUTE_IN_EXPR (qual, TREE_PURPOSE (t), TREE_VALUE (t));
+ FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
+ qual = SUBSTITUTE_IN_EXPR (qual, s->discriminant, s->replacement);
/* If the new qualifier is not unconditionally false, its variant may
still be accessed. */
if (!integer_zerop (qual))
{
+ variant_desc *v;
tree variant_type = TREE_TYPE (gnu_field), variant_subpart;
- tree v = make_tree_vec (3);
- TREE_VEC_ELT (v, 0) = gnu_field;
- TREE_VEC_ELT (v, 1) = qual;
- TREE_VEC_ELT (v, 2) = NULL_TREE;
- gnu_list = tree_cons (variant_type, v, gnu_list);
+
+ v = VEC_safe_push (variant_desc, heap, variant_list, NULL);
+ v->type = variant_type;
+ v->field = gnu_field;
+ v->qual = qual;
+ v->new_type = NULL_TREE;
/* Recurse on the variant subpart of the variant, if any. */
variant_subpart = get_variant_part (variant_type);
if (variant_subpart)
- gnu_list = build_variant_list (TREE_TYPE (variant_subpart),
- subst_list, gnu_list);
+ variant_list = build_variant_list (TREE_TYPE (variant_subpart),
+ subst_list, variant_list);
/* If the new qualifier is unconditionally true, the subsequent
variants cannot be accessed. */
}
}
- return gnu_list;
+ return variant_list;
}
\f
/* UINT_SIZE is a Uint giving the specified size for an object of GNU_TYPE
- corresponding to GNAT_OBJECT. If size is valid, return a tree corresponding
- to its value. Otherwise return 0. KIND is VAR_DECL is we are specifying
- the size for an object, TYPE_DECL for the size of a type, and FIELD_DECL
- for the size of a field. COMPONENT_P is true if we are being called
- to process the Component_Size of GNAT_OBJECT. This is used for error
- message handling and to indicate to use the object size of GNU_TYPE.
- ZERO_OK is true if a size of zero is permitted; if ZERO_OK is false,
- it means that a size of zero should be treated as an unspecified size. */
+ corresponding to GNAT_OBJECT. If the size is valid, return an INTEGER_CST
+ corresponding to its value. Otherwise, return NULL_TREE. KIND is set to
+ VAR_DECL if we are specifying the size of an object, TYPE_DECL for the
+ size of a type, and FIELD_DECL for the size of a field. COMPONENT_P is
+ true if we are being called to process the Component_Size of GNAT_OBJECT;
+ this is used only for error messages. ZERO_OK is true if a size of zero
+ is permitted; if ZERO_OK is false, it means that a size of zero should be
+ treated as an unspecified size. */
static tree
validate_size (Uint uint_size, tree gnu_type, Entity_Id gnat_object,
if (UI_Lt (uint_size, Uint_0))
return NULL_TREE;
- /* Find the node to use for errors. */
+ /* Find the node to use for error messages. */
if ((Ekind (gnat_object) == E_Component
|| Ekind (gnat_object) == E_Discriminant)
&& Present (Component_Clause (gnat_object)))
else
gnat_error_node = gnat_object;
- /* Get the size as a tree. Issue an error if a size was specified but
- cannot be represented in sizetype. */
+ /* Get the size as an INTEGER_CST. Issue an error if a size was specified
+ but cannot be represented in bitsizetype. */
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
if (component_p)
- post_error_ne ("component size of & is too large", gnat_error_node,
+ post_error_ne ("component size for& is too large", gnat_error_node,
gnat_object);
else
- post_error_ne ("size of & is too large", gnat_error_node,
+ post_error_ne ("size for& is too large", gnat_error_node,
gnat_object);
return NULL_TREE;
}
}
/* If this is an integral type or a packed array type, the front-end has
- verified the size, so we need not do it here (which would entail
+ already verified the size, so we need not do it here (which would mean
checking against the bounds). However, if this is an aliased object,
it may not be smaller than the type of the object. */
if ((INTEGRAL_TYPE_P (gnu_type) || TYPE_IS_PACKED_ARRAY_TYPE_P (gnu_type))
&& !(kind == VAR_DECL && Is_Aliased (gnat_object)))
return size;
- /* If the object is a record that contains a template, add the size of
- the template to the specified size. */
+ /* If the object is a record that contains a template, add the size of the
+ template to the specified size. */
if (TREE_CODE (gnu_type) == RECORD_TYPE
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
size = size_binop (PLUS_EXPR, DECL_SIZE (TYPE_FIELDS (gnu_type)), size);
else
type_size = rm_size (gnu_type);
- /* Modify the size of the type to be that of the maximum size if it has a
- discriminant. */
+ /* Modify the size of a discriminated type to be the maximum size. */
if (type_size && CONTAINS_PLACEHOLDER_P (type_size))
type_size = max_size (type_size, true);
type_size = bitsize_int (GET_MODE_BITSIZE (p_mode));
}
- /* If the size of the object is a constant, the new size must not be
- smaller. */
+ /* Issue an error either if the default size of the object isn't a constant
+ or if the new size is smaller than it. */
if (TREE_CODE (type_size) != INTEGER_CST
|| TREE_OVERFLOW (type_size)
|| tree_int_cst_lt (size, type_size))
post_error_ne_tree
("size for& too small{, minimum allowed is ^}",
gnat_error_node, gnat_object, type_size);
-
- size = NULL_TREE;
+ return NULL_TREE;
}
return size;
}
\f
-/* Similarly, but both validate and process a value of RM size. This
- routine is only called for types. */
+/* Similarly, but both validate and process a value of RM size. This routine
+ is only called for types. */
static void
set_rm_size (Uint uint_size, tree gnu_type, Entity_Id gnat_entity)
gnat_attr_node
= Get_Attribute_Definition_Clause (gnat_entity, Attr_Value_Size);
- /* Get the size as a tree. Issue an error if a size was specified but
- cannot be represented in sizetype. */
+ /* Get the size as an INTEGER_CST. Issue an error if a size was specified
+ but cannot be represented in bitsizetype. */
size = UI_To_gnu (uint_size, bitsizetype);
if (TREE_OVERFLOW (size))
{
if (Present (gnat_attr_node))
- post_error_ne ("Value_Size of & is too large", gnat_attr_node,
+ post_error_ne ("Value_Size for& is too large", gnat_attr_node,
gnat_entity);
return;
}
if (CONTAINS_PLACEHOLDER_P (old_size))
old_size = max_size (old_size, true);
- /* If the size of the object is a constant, the new size must not be smaller
- (the front-end has verified this for scalar and packed array types). */
+ /* Issue an error either if the old size of the object isn't a constant or
+ if the new size is smaller than it. The front-end has already verified
+ this for scalar and packed array types. */
if (TREE_CODE (old_size) != INTEGER_CST
|| TREE_OVERFLOW (old_size)
|| (AGGREGATE_TYPE_P (gnu_type)
SET_TYPE_RM_SIZE (gnu_type, size);
/* ...or the Ada size for record and union types. */
- else if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
+ else if (RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type))
SET_TYPE_ADA_SIZE (gnu_type, size);
}
/* Only do something if the type is not a packed array type and
doesn't already have the proper size. */
- if (TYPE_PACKED_ARRAY_TYPE_P (type)
+ if (TYPE_IS_PACKED_ARRAY_TYPE_P (type)
|| (TYPE_PRECISION (type) == size && biased_p == for_biased))
break;
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. */
+/* Helper for the intrin compatibility checks family. Evaluate whether
+ two types are definitely incompatible. */
-static int
-compatible_signatures_p (tree ftype1, tree ftype2)
+static bool
+intrin_types_incompatible_p (tree t1, tree t2)
+{
+ enum tree_code code;
+
+ if (TYPE_MAIN_VARIANT (t1) == TYPE_MAIN_VARIANT (t2))
+ return false;
+
+ if (TYPE_MODE (t1) != TYPE_MODE (t2))
+ return true;
+
+ if (TREE_CODE (t1) != TREE_CODE (t2))
+ return true;
+
+ code = TREE_CODE (t1);
+
+ switch (code)
+ {
+ case INTEGER_TYPE:
+ case REAL_TYPE:
+ return TYPE_PRECISION (t1) != TYPE_PRECISION (t2);
+
+ case POINTER_TYPE:
+ case REFERENCE_TYPE:
+ /* Assume designated types are ok. We'd need to account for char * and
+ void * variants to do better, which could rapidly get messy and isn't
+ clearly worth the effort. */
+ return false;
+
+ default:
+ break;
+ }
+
+ return false;
+}
+
+/* Helper for intrin_profiles_compatible_p, to perform compatibility checks
+ on the Ada/builtin argument lists for the INB binding. */
+
+static bool
+intrin_arglists_compatible_p (intrin_binding_t * inb)
+{
+ function_args_iterator ada_iter, btin_iter;
+
+ function_args_iter_init (&ada_iter, inb->ada_fntype);
+ function_args_iter_init (&btin_iter, inb->btin_fntype);
+
+ /* Sequence position of the last argument we checked. */
+ int argpos = 0;
+
+ while (1)
+ {
+ tree ada_type = function_args_iter_cond (&ada_iter);
+ tree btin_type = function_args_iter_cond (&btin_iter);
+
+ /* If we've exhausted both lists simultaneously, we're done. */
+ if (ada_type == NULL_TREE && btin_type == NULL_TREE)
+ break;
+
+ /* If one list is shorter than the other, they fail to match. */
+ if (ada_type == NULL_TREE || btin_type == NULL_TREE)
+ return false;
+
+ /* If we're done with the Ada args and not with the internal builtin
+ args, or the other way around, complain. */
+ if (ada_type == void_type_node
+ && btin_type != void_type_node)
+ {
+ post_error ("?Ada arguments list too short!", inb->gnat_entity);
+ return false;
+ }
+
+ if (btin_type == void_type_node
+ && ada_type != void_type_node)
+ {
+ post_error_ne_num ("?Ada arguments list too long ('> ^)!",
+ inb->gnat_entity, inb->gnat_entity, argpos);
+ return false;
+ }
+
+ /* Otherwise, check that types match for the current argument. */
+ argpos ++;
+ if (intrin_types_incompatible_p (ada_type, btin_type))
+ {
+ post_error_ne_num ("?intrinsic binding type mismatch on argument ^!",
+ inb->gnat_entity, inb->gnat_entity, argpos);
+ return false;
+ }
+
+
+ function_args_iter_next (&ada_iter);
+ function_args_iter_next (&btin_iter);
+ }
+
+ return true;
+}
+
+/* Helper for intrin_profiles_compatible_p, to perform compatibility checks
+ on the Ada/builtin return values for the INB binding. */
+
+static bool
+intrin_return_compatible_p (intrin_binding_t * inb)
+{
+ tree ada_return_type = TREE_TYPE (inb->ada_fntype);
+ tree btin_return_type = TREE_TYPE (inb->btin_fntype);
+
+ /* Accept function imported as procedure, common and convenient. */
+ if (VOID_TYPE_P (ada_return_type)
+ && !VOID_TYPE_P (btin_return_type))
+ return true;
+
+ /* Check return types compatibility otherwise. Note that this
+ handles void/void as well. */
+ if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
+ {
+ post_error ("?intrinsic binding type mismatch on return value!",
+ inb->gnat_entity);
+ return false;
+ }
+
+ return true;
+}
+
+/* Check and return whether the Ada and gcc builtin profiles bound by INB are
+ compatible. Issue relevant warnings when they are not.
+
+ This is intended as a light check to diagnose the most obvious cases, not
+ as a full fledged type compatibility predicate. It is the programmer's
+ responsibility to ensure correctness of the Ada declarations in Imports,
+ especially when binding straight to a compiler internal. */
+
+static bool
+intrin_profiles_compatible_p (intrin_binding_t * inb)
{
- /* 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.
+ /* Check compatibility on return values and argument lists, each responsible
+ for posting warnings as appropriate. Ensure use of the proper sloc for
+ this purpose. */
- 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. */
+ bool arglists_compatible_p, return_compatible_p;
+ location_t saved_location = input_location;
- /* Almost fake test, ensuring a use of each argument. */
- if (ftype1 == ftype2)
- return 1;
+ Sloc_to_locus (Sloc (inb->gnat_entity), &input_location);
- return 1;
+ return_compatible_p = intrin_return_compatible_p (inb);
+ arglists_compatible_p = intrin_arglists_compatible_p (inb);
+
+ input_location = saved_location;
+
+ return return_compatible_p && arglists_compatible_p;
}
\f
/* Return a FIELD_DECL node modeled on OLD_FIELD. FIELD_TYPE is its type
static tree
create_field_decl_from (tree old_field, tree field_type, tree record_type,
- tree size, tree pos_list, tree subst_list)
+ tree size, tree pos_list,
+ VEC(subst_pair,heap) *subst_list)
{
tree t = TREE_VALUE (purpose_member (old_field, pos_list));
tree pos = TREE_VEC_ELT (t, 0), bitpos = TREE_VEC_ELT (t, 2);
unsigned int offset_align = tree_low_cst (TREE_VEC_ELT (t, 1), 1);
tree new_pos, new_field;
+ unsigned ix;
+ subst_pair *s;
if (CONTAINS_PLACEHOLDER_P (pos))
- for (t = subst_list; t; t = TREE_CHAIN (t))
- pos = SUBSTITUTE_IN_EXPR (pos, TREE_PURPOSE (t), TREE_VALUE (t));
+ FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
+ pos = SUBSTITUTE_IN_EXPR (pos, s->discriminant, s->replacement);
/* If the position is now a constant, we can set it as the position of the
field when we make it. Otherwise, we need to deal with it specially. */
return new_field;
}
+/* Create the REP part of RECORD_TYPE with REP_TYPE. If MIN_SIZE is nonzero,
+ it is the minimal size the REP_PART must have. */
+
+static tree
+create_rep_part (tree rep_type, tree record_type, tree min_size)
+{
+ tree field;
+
+ if (min_size && !tree_int_cst_lt (TYPE_SIZE (rep_type), min_size))
+ min_size = NULL_TREE;
+
+ field = create_field_decl (get_identifier ("REP"), rep_type, record_type,
+ min_size, bitsize_zero_node, 0, 1);
+ DECL_INTERNAL_P (field) = 1;
+
+ return field;
+}
+
/* Return the REP part of RECORD_TYPE, if any. Otherwise return NULL. */
static tree
tree field = TYPE_FIELDS (record_type);
/* The REP part is the first field, internal, another record, and its name
- doesn't start with an underscore (i.e. is not generated by the FE). */
+ starts with an 'R'. */
if (DECL_INTERNAL_P (field)
&& TREE_CODE (TREE_TYPE (field)) == RECORD_TYPE
- && IDENTIFIER_POINTER (DECL_NAME (field)) [0] != '_')
+ && IDENTIFIER_POINTER (DECL_NAME (field)) [0] == 'R')
return field;
return NULL_TREE;
/* Return the variant part of RECORD_TYPE, if any. Otherwise return NULL. */
-static tree
+tree
get_variant_part (tree record_type)
{
tree field;
/* The variant part is the only internal field that is a qualified union. */
- for (field = TYPE_FIELDS (record_type); field; field = TREE_CHAIN (field))
+ for (field = TYPE_FIELDS (record_type); field; field = DECL_CHAIN (field))
if (DECL_INTERNAL_P (field)
&& TREE_CODE (TREE_TYPE (field)) == QUAL_UNION_TYPE)
return field;
layout. */
static tree
-create_variant_part_from (tree old_variant_part, tree variant_list,
- tree record_type, tree pos_list, tree subst_list)
+create_variant_part_from (tree old_variant_part,
+ VEC(variant_desc,heap) *variant_list,
+ tree record_type, tree pos_list,
+ VEC(subst_pair,heap) *subst_list)
{
tree offset = DECL_FIELD_OFFSET (old_variant_part);
tree old_union_type = TREE_TYPE (old_variant_part);
- tree new_union_type, new_variant_part, t;
+ tree new_union_type, new_variant_part;
tree union_field_list = NULL_TREE;
+ variant_desc *v;
+ unsigned ix;
/* First create the type of the variant part from that of the old one. */
new_union_type = make_node (QUAL_UNION_TYPE);
- TYPE_NAME (new_union_type) = DECL_NAME (TYPE_NAME (old_union_type));
+ TYPE_NAME (new_union_type)
+ = concat_name (TYPE_NAME (record_type),
+ IDENTIFIER_POINTER (DECL_NAME (old_variant_part)));
/* If the position of the variant part is constant, subtract it from the
size of the type of the parent to get the new size. This manual CSE
copy_and_substitute_in_size (new_union_type, old_union_type, subst_list);
/* Now finish up the new variants and populate the union type. */
- for (t = variant_list; t; t = TREE_CHAIN (t))
+ FOR_EACH_VEC_ELT_REVERSE (variant_desc, variant_list, ix, v)
{
- tree old_field = TREE_VEC_ELT (TREE_VALUE (t), 0), new_field;
+ tree old_field = v->field, new_field;
tree old_variant, old_variant_subpart, new_variant, field_list;
/* Skip variants that don't belong to this nesting level. */
continue;
/* Retrieve the list of fields already added to the new variant. */
- new_variant = TREE_VEC_ELT (TREE_VALUE (t), 2);
+ new_variant = v->new_type;
field_list = TYPE_FIELDS (new_variant);
/* If the old variant had a variant subpart, we need to create a new
variant subpart and add it to the field list. */
- old_variant = TREE_PURPOSE (t);
+ old_variant = v->type;
old_variant_subpart = get_variant_part (old_variant);
if (old_variant_subpart)
{
tree new_variant_subpart
= create_variant_part_from (old_variant_subpart, variant_list,
new_variant, pos_list, subst_list);
- TREE_CHAIN (new_variant_subpart) = field_list;
+ DECL_CHAIN (new_variant_subpart) = field_list;
field_list = new_variant_subpart;
}
= create_field_decl_from (old_field, new_variant, new_union_type,
TYPE_SIZE (new_variant),
pos_list, subst_list);
- DECL_QUALIFIER (new_field) = TREE_VEC_ELT (TREE_VALUE (t), 1);
+ DECL_QUALIFIER (new_field) = v->qual;
DECL_INTERNAL_P (new_field) = 1;
- TREE_CHAIN (new_field) = union_field_list;
+ DECL_CHAIN (new_field) = union_field_list;
union_field_list = new_field;
}
statically selected while outer ones are not; in this case, the list
of fields of the inner variant is not flattened and we end up with a
qualified union with a single member. Drop the useless container. */
- if (!TREE_CHAIN (union_field_list))
+ if (!DECL_CHAIN (union_field_list))
{
DECL_CONTEXT (union_field_list) = record_type;
DECL_FIELD_OFFSET (union_field_list)
in SUBST_LIST. */
static void
-copy_and_substitute_in_size (tree new_type, tree old_type, tree subst_list)
+copy_and_substitute_in_size (tree new_type, tree old_type,
+ VEC(subst_pair,heap) *subst_list)
{
- tree t;
+ unsigned ix;
+ subst_pair *s;
TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
- for (t = subst_list; t; t = TREE_CHAIN (t))
+ FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
TYPE_SIZE (new_type)
= SUBSTITUTE_IN_EXPR (TYPE_SIZE (new_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t));
+ s->discriminant, s->replacement);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE_UNIT (new_type)))
- for (t = subst_list; t; t = TREE_CHAIN (t))
+ FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
TYPE_SIZE_UNIT (new_type)
= SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (new_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t));
+ s->discriminant, s->replacement);
if (CONTAINS_PLACEHOLDER_P (TYPE_ADA_SIZE (new_type)))
- for (t = subst_list; t; t = TREE_CHAIN (t))
+ FOR_EACH_VEC_ELT_REVERSE (subst_pair, subst_list, ix, s)
SET_TYPE_ADA_SIZE
(new_type, SUBSTITUTE_IN_EXPR (TYPE_ADA_SIZE (new_type),
- TREE_PURPOSE (t),
- TREE_VALUE (t)));
+ s->discriminant, s->replacement));
/* Finalize the size. */
TYPE_SIZE (new_type) = variable_size (TYPE_SIZE (new_type));
return build_complex_type (nt);
- case OFFSET_TYPE:
- case METHOD_TYPE:
case FUNCTION_TYPE:
- case LANG_TYPE:
/* These should never show up here. */
gcc_unreachable ();
if (component == TREE_TYPE (t) && domain == TYPE_DOMAIN (t))
return t;
- nt = build_array_type (component, domain);
+ nt = build_nonshared_array_type (component, domain);
TYPE_ALIGN (nt) = TYPE_ALIGN (t);
TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
SET_TYPE_MODE (nt, TYPE_MODE (t));
nt = copy_type (t);
TYPE_FIELDS (nt) = NULL_TREE;
- for (field = TYPE_FIELDS (t); field; field = TREE_CHAIN (field))
+ for (field = TYPE_FIELDS (t); field; field = DECL_CHAIN (field))
{
tree new_field = copy_node (field), new_n;
DECL_CONTEXT (new_field) = nt;
SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
- TREE_CHAIN (new_field) = TYPE_FIELDS (nt);
+ DECL_CHAIN (new_field) = TYPE_FIELDS (nt);
TYPE_FIELDS (nt) = new_field;
}
&& TYPE_CONTAINS_TEMPLATE_P (gnu_type))
return
size_binop (PLUS_EXPR,
- rm_size (TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (gnu_type)))),
+ rm_size (TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_type)))),
DECL_SIZE (TYPE_FIELDS (gnu_type)));
- /* For record types, we store the size explicitly. */
- if ((TREE_CODE (gnu_type) == RECORD_TYPE
- || TREE_CODE (gnu_type) == UNION_TYPE
- || TREE_CODE (gnu_type) == QUAL_UNION_TYPE)
+ /* For record or union types, we store the size explicitly. */
+ if (RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& TYPE_ADA_SIZE (gnu_type))
return TYPE_ADA_SIZE (gnu_type);
if (suffix)
{
- String_Template temp = {1, strlen (suffix)};
+ String_Template temp = {1, (int) strlen (suffix)};
Fat_Pointer fp = {suffix, &temp};
Get_External_Name_With_Suffix (gnat_entity, fp);
}
OSDN Git Service
