Skip to content

R
riscv-gcc-1
Commit 1e55d29a by Eric Botcazou Committed by Eric Botcazou
Options

sem_aux.adb (Is_By_Reference_Type): Also return true for a tagged incomplete… 

sem_aux.adb (Is_By_Reference_Type): Also return true for a tagged incomplete type without full view.

	* sem_aux.adb (Is_By_Reference_Type): Also return true for a tagged
	incomplete type without full view.
	* sem_ch6.adb (Exchange_Limited_Views): Change into a function and
	return the list of changes.
	(Restore_Limited_Views): New procedure to undo the transformation made
	by Exchange_Limited_Views.
	(Analyze_Subprogram_Body_Helper): Adjust call to Exchange_Limited_Views
	and call Restore_Limited_Views at the end, if need be.
	(Possible_Freeze): Do not delay freezing because of incomplete types.
	(Process_Formals): Remove kludges for class-wide types.
	* types.h (By_Copy_Return): Delete.
	* gcc-interface/ada-tree.h (TYPE_MAX_ALIGN): Move around.
	(TYPE_DUMMY_IN_PROFILE_P): New macro.
	* gcc-interface/gigi.h (update_profiles_with): Declare.
	(finish_subprog_decl): Likewise.
	(get_minimal_subprog_decl): Delete.
	(create_subprog_type): Likewise.
	(create_param_decl): Adjust prototype.
	(create_subprog_decl): Likewise.
	* gcc-interface/decl.c (defer_limited_with): Rename into...
	(defer_limited_with_list): ...this.
	(gnat_to_gnu_entity): Adjust to above renaming.
	(finalize_from_limited_with): Likewise.
	(tree_entity_vec_map): New structure.
	(gt_pch_nx): New helpers.
	(dummy_to_subprog_map): New hash table.
	(gnat_to_gnu_param): Set the SLOC here.  Remove MECH parameter and
	add FIRST parameter.  Deal with the mechanism here instead of...
	Do not make read-only variant of types.  Simplify expressions.
	In the by-ref case, test the mechanism before must_pass_by_ref
	and also TYPE_IS_BY_REFERENCE_P before building the reference type.
	(gnat_to_gnu_subprog_type): New static function extracted from...
	Do not special-case the type_annotate_only mode.  Call
	gnat_to_gnu_profile_type instead of gnat_to_gnu_type on return type.
	Deal with dummy return types.  Likewise for parameter types.  Deal
	with by-reference types explicitly and add a kludge for null procedures
	with untagged incomplete types.  Remove assertion on the types and be
	prepared for multiple elaboration of the declarations.  Skip the whole
	CICO processing if the profile is incomplete.  Handle the completion of
	a previously incomplete profile.
	(gnat_to_gnu_entity) <E_Variable>: Rename local variable.
	Adjust couple of calls to create_param_decl.
	<E_Access_Subprogram_Type, E_Anonymous_Access_Subprogram_Type>:
	Remove specific deferring code.
	<E_Access_Type>: Also deal with E_Subprogram_Type designated type.
	Simplify handling of dummy types and remove obsolete comment.
	Constify a couple of variables.  Do not set TYPE_UNIVERSAL_ALIASING_P
	on dummy types.
	<E_Access_Subtype>: Tweak comment and simplify condition.
	<E_Subprogram_Type>: ...here.  Call it and clean up handling.  Remove
	obsolete comment and adjust call to gnat_to_gnu_param.  Adjust call to
	create_subprog_decl.
	<E_Incomplete_Type>: Add a couple of 'const' qualifiers and get rid of
	inner break statements.  Tidy up condition guarding direct use of the
	full view.
	(get_minimal_subprog_decl): Delete.
	(finalize_from_limited_with): Call update_profiles_with on dummy types
	with TYPE_DUMMY_IN_PROFILE_P set.
	(is_from_limited_with_of_main): Delete.
	(associate_subprog_with_dummy_type): New function.
	(update_profile): Likewise.
	(update_profiles_with): Likewise.
	(gnat_to_gnu_profile_type): Likewise.
	(init_gnat_decl): Initialize dummy_to_subprog_map.
	(destroy_gnat_decl): Destroy dummy_to_subprog_map.
	* gcc-interface/misc.c (gnat_get_alias_set): Add guard for accessing
	TYPE_UNIVERSAL_ALIASING_P.
	(gnat_get_array_descr_info): Minor tweak.
	* gcc-interface/trans.c (gigi): Adjust calls to create_subprog_decl.
	(build_raise_check): Likewise.
	(Compilation_Unit_to_gnu): Likewise.
	(Identifier_to_gnu): Accept mismatches coming from a limited context.
	(Attribute_to_gnu): Remove kludge for dispatch table entities.
	(process_freeze_entity): Do not retrieve old definition if there is an
	address clause on the entity.  Call update_profiles_with on dummy types
	with TYPE_DUMMY_IN_PROFILE_P set.
	* gcc-interface/utils.c (build_dummy_unc_pointer_types): Also set
	TYPE_REFERENCE_TO to the fat pointer type.
	(create_subprog_type): Delete.
	(create_param_decl): Remove READONLY parameter.
	(finish_subprog_decl): New function extracted from...
	(create_subprog_decl): ...here.  Call it.  Remove CONST_FLAG and
	VOLATILE_FLAG parameters and adjust.
	(update_pointer_to): Also clear TYPE_REFERENCE_TO in the unconstrained
	case.

From-SVN: r235521
parent e306693a
Showing with 1348 additions and 1077 deletions
gcc/ada/ChangeLog
2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
* sem_aux.adb (Is_By_Reference_Type): Also return true for a tagged
incomplete type without full view.
* sem_ch6.adb (Exchange_Limited_Views): Change into a function and
return the list of changes.
(Restore_Limited_Views): New procedure to undo the transformation made
by Exchange_Limited_Views.
(Analyze_Subprogram_Body_Helper): Adjust call to Exchange_Limited_Views
and call Restore_Limited_Views at the end, if need be.
(Possible_Freeze): Do not delay freezing because of incomplete types.
(Process_Formals): Remove kludges for class-wide types.
* types.h (By_Copy_Return): Delete.
* gcc-interface/ada-tree.h (TYPE_MAX_ALIGN): Move around.
(TYPE_DUMMY_IN_PROFILE_P): New macro.
* gcc-interface/gigi.h (update_profiles_with): Declare.
(finish_subprog_decl): Likewise.
(get_minimal_subprog_decl): Delete.
(create_subprog_type): Likewise.
(create_param_decl): Adjust prototype.
(create_subprog_decl): Likewise.
* gcc-interface/decl.c (defer_limited_with): Rename into...
(defer_limited_with_list): ...this.
(gnat_to_gnu_entity): Adjust to above renaming.
(finalize_from_limited_with): Likewise.
(tree_entity_vec_map): New structure.
(gt_pch_nx): New helpers.
(dummy_to_subprog_map): New hash table.
(gnat_to_gnu_param): Set the SLOC here. Remove MECH parameter and
add FIRST parameter. Deal with the mechanism here instead of...
Do not make read-only variant of types. Simplify expressions.
In the by-ref case, test the mechanism before must_pass_by_ref
and also TYPE_IS_BY_REFERENCE_P before building the reference type.
(gnat_to_gnu_subprog_type): New static function extracted from...
Do not special-case the type_annotate_only mode. Call
gnat_to_gnu_profile_type instead of gnat_to_gnu_type on return type.
Deal with dummy return types. Likewise for parameter types. Deal
with by-reference types explicitly and add a kludge for null procedures
with untagged incomplete types. Remove assertion on the types and be
prepared for multiple elaboration of the declarations. Skip the whole
CICO processing if the profile is incomplete. Handle the completion of
a previously incomplete profile.
(gnat_to_gnu_entity) <E_Variable>: Rename local variable.
Adjust couple of calls to create_param_decl.
<E_Access_Subprogram_Type, E_Anonymous_Access_Subprogram_Type>:
Remove specific deferring code.
<E_Access_Type>: Also deal with E_Subprogram_Type designated type.
Simplify handling of dummy types and remove obsolete comment.
Constify a couple of variables. Do not set TYPE_UNIVERSAL_ALIASING_P
on dummy types.
<E_Access_Subtype>: Tweak comment and simplify condition.
<E_Subprogram_Type>: ...here. Call it and clean up handling. Remove
obsolete comment and adjust call to gnat_to_gnu_param. Adjust call to
create_subprog_decl.
<E_Incomplete_Type>: Add a couple of 'const' qualifiers and get rid of
inner break statements. Tidy up condition guarding direct use of the
full view.
(get_minimal_subprog_decl): Delete.
(finalize_from_limited_with): Call update_profiles_with on dummy types
with TYPE_DUMMY_IN_PROFILE_P set.
(is_from_limited_with_of_main): Delete.
(associate_subprog_with_dummy_type): New function.
(update_profile): Likewise.
(update_profiles_with): Likewise.
(gnat_to_gnu_profile_type): Likewise.
(init_gnat_decl): Initialize dummy_to_subprog_map.
(destroy_gnat_decl): Destroy dummy_to_subprog_map.
* gcc-interface/misc.c (gnat_get_alias_set): Add guard for accessing
TYPE_UNIVERSAL_ALIASING_P.
(gnat_get_array_descr_info): Minor tweak.
* gcc-interface/trans.c (gigi): Adjust calls to create_subprog_decl.
(build_raise_check): Likewise.
(Compilation_Unit_to_gnu): Likewise.
(Identifier_to_gnu): Accept mismatches coming from a limited context.
(Attribute_to_gnu): Remove kludge for dispatch table entities.
(process_freeze_entity): Do not retrieve old definition if there is an
address clause on the entity. Call update_profiles_with on dummy types
with TYPE_DUMMY_IN_PROFILE_P set.
* gcc-interface/utils.c (build_dummy_unc_pointer_types): Also set
TYPE_REFERENCE_TO to the fat pointer type.
(create_subprog_type): Delete.
(create_param_decl): Remove READONLY parameter.
(finish_subprog_decl): New function extracted from...
(create_subprog_decl): ...here. Call it. Remove CONST_FLAG and
VOLATILE_FLAG parameters and adjust.
(update_pointer_to): Also clear TYPE_REFERENCE_TO in the unconstrained
case.
2016-04-27 Arnaud Charlet <charlet@adacore.com> 2016-04-27 Arnaud Charlet <charlet@adacore.com>
* aa_util.adb, aa_util.ads: Removed, no longer used. * aa_util.adb, aa_util.ads: Removed, no longer used.
......
gcc/ada/gcc-interface/ada-tree.h
...@@ -180,12 +180,11 @@ do { \ ...@@ -180,12 +180,11 @@ do { \
#define TYPE_IS_PADDING_P(NODE) \ #define TYPE_IS_PADDING_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_PADDING_P (NODE)) (TREE_CODE (NODE) == RECORD_TYPE && TYPE_PADDING_P (NODE))
/* True if TYPE can alias any other types. */ /* True for a non-dummy type if TYPE can alias any other types. */
#define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE) #define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE)
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, this holds the maximum /* True for a dummy type if TYPE appears in a profile. */
alignment value the type ought to have. */ #define TYPE_DUMMY_IN_PROFILE_P(NODE) TYPE_LANG_FLAG_6 (NODE)
#define TYPE_MAX_ALIGN(NODE) (TYPE_PRECISION (RECORD_OR_UNION_CHECK (NODE)))
/* True for types that implement a packed array and for original packed array /* True for types that implement a packed array and for original packed array
types. */ types. */
...@@ -196,6 +195,10 @@ do { \ ...@@ -196,6 +195,10 @@ do { \
/* True for types that can hold a debug type. */ /* True for types that can hold a debug type. */
#define TYPE_CAN_HAVE_DEBUG_TYPE_P(NODE) (!TYPE_IMPL_PACKED_ARRAY_P (NODE)) #define TYPE_CAN_HAVE_DEBUG_TYPE_P(NODE) (!TYPE_IMPL_PACKED_ARRAY_P (NODE))
/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, this holds the maximum
alignment value the type ought to have. */
#define TYPE_MAX_ALIGN(NODE) (TYPE_PRECISION (RECORD_OR_UNION_CHECK (NODE)))
/* For an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the /* For an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the
template and the object. template and the object.
......
gcc/ada/gcc-interface/decl.c
...@@ -96,13 +96,13 @@ struct incomplete ...@@ -96,13 +96,13 @@ struct incomplete
}; };
/* These variables are used to defer recursively expanding incomplete types /* These variables are used to defer recursively expanding incomplete types
while we are processing an array, a record or a subprogram type. */ while we are processing a record, an array or a subprogram type. */
static int defer_incomplete_level = 0; static int defer_incomplete_level = 0;
static struct incomplete *defer_incomplete_list; static struct incomplete *defer_incomplete_list;
/* This variable is used to delay expanding From_Limited_With types until the /* This variable is used to delay expanding From_Limited_With types until the
end of the spec. */ end of the spec. */
static struct incomplete *defer_limited_with; static struct incomplete *defer_limited_with_list;
typedef struct subst_pair_d { typedef struct subst_pair_d {
tree discriminant; tree discriminant;
...@@ -125,8 +125,7 @@ typedef struct variant_desc_d { ...@@ -125,8 +125,7 @@ typedef struct variant_desc_d {
} variant_desc; } variant_desc;
/* A hash table used to cache the result of annotate_value. */ /* A map used to cache the result of annotate_value. */
struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map> struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
{ {
static inline hashval_t static inline hashval_t
...@@ -150,6 +149,47 @@ struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map> ...@@ -150,6 +149,47 @@ struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache; static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
/* A map used to associate a dummy type with a list of subprogram entities. */
struct GTY((for_user)) tree_entity_vec_map
{
struct tree_map_base base;
vec<Entity_Id, va_gc_atomic> *to;
};
void
gt_pch_nx (Entity_Id &)
{
}
void
gt_pch_nx (Entity_Id *x, gt_pointer_operator op, void *cookie)
{
op (x, cookie);
}
struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
{
static inline hashval_t
hash (tree_entity_vec_map *m)
{
return htab_hash_pointer (m->base.from);
}
static inline bool
equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
{
return a->base.from == b->base.from;
}
static int
keep_cache_entry (tree_entity_vec_map *&m)
{
return ggc_marked_p (m->base.from);
}
};
static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
static void prepend_one_attribute (struct attrib **, static void prepend_one_attribute (struct attrib **,
enum attrib_type, tree, tree, Node_Id); enum attrib_type, tree, tree, Node_Id);
static void prepend_one_attribute_pragma (struct attrib **, Node_Id); static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
...@@ -162,10 +202,8 @@ static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool, ...@@ -162,10 +202,8 @@ static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
unsigned int); unsigned int);
static tree elaborate_reference (tree, Entity_Id, bool, tree *); static tree elaborate_reference (tree, Entity_Id, bool, tree *);
static tree gnat_to_gnu_component_type (Entity_Id, bool, bool); static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool, static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
bool *);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool); static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
static bool is_from_limited_with_of_main (Entity_Id);
static tree change_qualified_type (tree, int); static tree change_qualified_type (tree, int);
static bool same_discriminant_p (Entity_Id, Entity_Id); static bool same_discriminant_p (Entity_Id, Entity_Id);
static bool array_type_has_nonaliased_component (tree, Entity_Id); static bool array_type_has_nonaliased_component (tree, Entity_Id);
...@@ -1127,10 +1165,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -1127,10 +1165,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (definition && Present (Address_Clause (gnat_entity))) if (definition && Present (Address_Clause (gnat_entity)))
{ {
const Node_Id gnat_clause = Address_Clause (gnat_entity); const Node_Id gnat_clause = Address_Clause (gnat_entity);
Node_Id gnat_expr = Expression (gnat_clause); Node_Id gnat_address = Expression (gnat_clause);
tree gnu_address tree gnu_address
= present_gnu_tree (gnat_entity) = present_gnu_tree (gnat_entity)
? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr); ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_address);
save_gnu_tree (gnat_entity, NULL_TREE, false); save_gnu_tree (gnat_entity, NULL_TREE, false);
...@@ -1144,7 +1182,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -1144,7 +1182,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
used_by_ref = true; used_by_ref = true;
const_flag const_flag
= (!Is_Public (gnat_entity) = (!Is_Public (gnat_entity)
|| compile_time_known_address_p (gnat_expr)); || compile_time_known_address_p (gnat_address));
volatile_flag = false; volatile_flag = false;
gnu_size = NULL_TREE; gnu_size = NULL_TREE;
...@@ -1453,7 +1491,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -1453,7 +1491,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& !optimize && !optimize
&& !flag_generate_lto) && !flag_generate_lto)
{ {
tree param = create_param_decl (gnu_entity_name, gnu_type, false); tree param = create_param_decl (gnu_entity_name, gnu_type);
gnat_pushdecl (param, gnat_entity); gnat_pushdecl (param, gnat_entity);
SET_DECL_VALUE_EXPR (param, gnu_decl); SET_DECL_VALUE_EXPR (param, gnu_decl);
DECL_HAS_VALUE_EXPR_P (param) = 1; DECL_HAS_VALUE_EXPR_P (param) = 1;
...@@ -3769,6 +3807,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3769,6 +3807,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
break; break;
case E_Access_Subprogram_Type: case E_Access_Subprogram_Type:
case E_Anonymous_Access_Subprogram_Type:
/* Use the special descriptor type for dispatch tables if needed, /* Use the special descriptor type for dispatch tables if needed,
that is to say for the Prim_Ptr of a-tags.ads and its clones. that is to say for the Prim_Ptr of a-tags.ads and its clones.
Note that we are only required to do so for static tables in Note that we are only required to do so for static tables in
...@@ -3785,34 +3824,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3785,34 +3824,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
/* ... fall through ... */ /* ... fall through ... */
case E_Anonymous_Access_Subprogram_Type:
/* If we are not defining this entity, and we have incomplete
entities being processed above us, make a dummy type and
fill it in later. */
if (!definition && defer_incomplete_level != 0)
{
struct incomplete *p = XNEW (struct incomplete);
gnu_type
= build_pointer_type
(make_dummy_type (Directly_Designated_Type (gnat_entity)));
gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
artificial_p, debug_info_p,
gnat_entity);
this_made_decl = true;
gnu_type = TREE_TYPE (gnu_decl);
save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true;
p->old_type = TREE_TYPE (gnu_type);
p->full_type = Directly_Designated_Type (gnat_entity);
p->next = defer_incomplete_list;
defer_incomplete_list = p;
break;
}
/* ... fall through ... */
case E_Allocator_Type: case E_Allocator_Type:
case E_Access_Type: case E_Access_Type:
case E_Access_Attribute_Type: case E_Access_Attribute_Type:
...@@ -3823,7 +3834,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3823,7 +3834,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity); Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type); Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
/* Whether it comes from a limited with. */ /* Whether it comes from a limited with. */
bool is_from_limited_with const bool is_from_limited_with
= (IN (Ekind (gnat_desig_equiv), Incomplete_Kind) = (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
&& From_Limited_With (gnat_desig_equiv)); && From_Limited_With (gnat_desig_equiv));
/* The "full view" of the designated type. If this is an incomplete /* The "full view" of the designated type. If this is an incomplete
...@@ -3851,7 +3862,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3851,7 +3862,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
Entity_Id gnat_desig_rep; Entity_Id gnat_desig_rep;
/* We want to know if we'll be seeing the freeze node for any /* We want to know if we'll be seeing the freeze node for any
incomplete type we may be pointing to. */ incomplete type we may be pointing to. */
bool in_main_unit const bool in_main_unit
= (Present (gnat_desig_full) = (Present (gnat_desig_full)
? In_Extended_Main_Code_Unit (gnat_desig_full) ? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type)); : In_Extended_Main_Code_Unit (gnat_desig_type));
...@@ -3899,14 +3910,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3899,14 +3910,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
&& Present (gnat_desig_full) && Present (gnat_desig_full)
&& (Is_Record_Type (gnat_desig_full) && (Is_Record_Type (gnat_desig_full)
|| Is_Array_Type (gnat_desig_full))) || Is_Array_Type (gnat_desig_full)))
/* Likewise if we are pointing to a record or array and we are /* Likewise if this is a reference to a record, an array or a
to defer elaborating incomplete types. We do this as this subprogram type and we are to defer elaborating incomplete
access type may be the full view of a private type. */ types. We do this because this access type may be the full
view of a private type. */
|| ((!in_main_unit || imported_p) || ((!in_main_unit || imported_p)
&& defer_incomplete_level != 0 && defer_incomplete_level != 0
&& !present_gnu_tree (gnat_desig_equiv) && !present_gnu_tree (gnat_desig_equiv)
&& (Is_Record_Type (gnat_desig_rep) && (Is_Record_Type (gnat_desig_rep)
|| Is_Array_Type (gnat_desig_rep))) || Is_Array_Type (gnat_desig_rep)
|| Ekind (gnat_desig_rep) == E_Subprogram_Type))
/* If this is a reference from a limited_with type back to our /* If this is a reference from a limited_with type back to our
main unit and there's a freeze node for it, either we have main unit and there's a freeze node for it, either we have
already processed the declaration and made the dummy type, already processed the declaration and made the dummy type,
...@@ -3950,7 +3963,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3950,7 +3963,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
break; break;
} }
/* For an unconstrained array, make dummy fat & thin pointer types. */ /* Access-to-unconstrained-array types need a special treatment. */
if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep)) if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
{ {
/* If the processing above got something that has a pointer, then /* If the processing above got something that has a pointer, then
...@@ -3958,6 +3971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3958,6 +3971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
was elaborated or because somebody else executed the code. */ was elaborated or because somebody else executed the code. */
if (!TYPE_POINTER_TO (gnu_desig_type)) if (!TYPE_POINTER_TO (gnu_desig_type))
build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type); build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
gnu_type = TYPE_POINTER_TO (gnu_desig_type); gnu_type = TYPE_POINTER_TO (gnu_desig_type);
} }
...@@ -3965,62 +3979,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -3965,62 +3979,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
else if (!gnu_type) else if (!gnu_type)
{ {
/* Modify the designated type if we are pointing only to constant /* Modify the designated type if we are pointing only to constant
objects, but don't do it for unconstrained arrays. */ objects, but don't do it for a dummy type. */
if (Is_Access_Constant (gnat_entity) if (Is_Access_Constant (gnat_entity)
&& TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE) && !TYPE_IS_DUMMY_P (gnu_desig_type))
{
gnu_desig_type gnu_desig_type
= change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST); = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
/* Some extra processing is required if we are building a
pointer to an incomplete type (in the GCC sense). We might
have such a type if we just made a dummy, or directly out
of the call to gnat_to_gnu_type above if we are processing
an access type for a record component designating the
record type itself. */
if (TYPE_MODE (gnu_desig_type) == VOIDmode)
{
/* We must ensure that the pointer to variant we make will
be processed by update_pointer_to when the initial type
is completed. Pretend we made a dummy and let further
processing act as usual. */
made_dummy = true;
/* We must ensure that update_pointer_to will not retrieve
the dummy variant when building a properly qualified
version of the complete type. We take advantage of the
fact that get_qualified_type is requiring TYPE_NAMEs to
match to influence build_qualified_type and then also
update_pointer_to here. */
TYPE_NAME (gnu_desig_type)
= create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
}
}
gnu_type gnu_type
= build_pointer_type_for_mode (gnu_desig_type, p_mode, = build_pointer_type_for_mode (gnu_desig_type, p_mode,
No_Strict_Aliasing (gnat_entity)); No_Strict_Aliasing (gnat_entity));
} }
/* If we are not defining this object and we have made a dummy pointer, /* If the designated type is not declared in the main unit and we made
save our current definition, evaluate the actual type, and replace a dummy node for it, save our definition, elaborate the actual type
the tentative type we made with the actual one. If we are to defer and replace the dummy type we made with the actual one. But if we
actually looking up the actual type, make an entry in the deferred are to defer actually looking up the actual type, make an entry in
list. If this is from a limited with, we may have to defer to the the deferred list instead. If this is from a limited with, we may
end of the current unit. */ have to defer until the end of the current unit. */
if ((!in_main_unit || is_from_limited_with) && made_dummy) if (!in_main_unit && made_dummy)
{
tree gnu_old_desig_type;
if (TYPE_IS_FAT_POINTER_P (gnu_type))
{ {
gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type); if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
if (esize == POINTER_SIZE) gnu_type
gnu_type = build_pointer_type = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
(TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
}
else
gnu_old_desig_type = TREE_TYPE (gnu_type);
process_attributes (&gnu_type, &attr_list, false, gnat_entity); process_attributes (&gnu_type, &attr_list, false, gnat_entity);
gnu_decl = create_type_decl (gnu_entity_name, gnu_type, gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
...@@ -4031,20 +4011,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4031,20 +4011,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
save_gnu_tree (gnat_entity, gnu_decl, false); save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true; saved = true;
/* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
update gnu_old_desig_type directly, in which case it will not be
a dummy type any more when we get into update_pointer_to.
This can happen e.g. when the designated type is a record type,
because their elaboration starts with an initial node from
make_dummy_type, which may be the same node as the one we got.
Besides, variants of this non-dummy type might have been created
along the way. update_pointer_to is expected to properly take
care of those situations. */
if (defer_incomplete_level == 0 && !is_from_limited_with) if (defer_incomplete_level == 0 && !is_from_limited_with)
{ {
update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type), update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
gnat_to_gnu_type (gnat_desig_equiv)); gnat_to_gnu_type (gnat_desig_equiv));
} }
else else
...@@ -4052,8 +4021,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4052,8 +4021,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
struct incomplete *p = XNEW (struct incomplete); struct incomplete *p = XNEW (struct incomplete);
struct incomplete **head struct incomplete **head
= (is_from_limited_with = (is_from_limited_with
? &defer_limited_with : &defer_incomplete_list); ? &defer_limited_with_list : &defer_incomplete_list);
p->old_type = gnu_old_desig_type;
p->old_type = gnu_desig_type;
p->full_type = gnat_desig_equiv; p->full_type = gnat_desig_equiv;
p->next = *head; p->next = *head;
*head = p; *head = p;
...@@ -4064,15 +4034,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4064,15 +4034,17 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
case E_Access_Protected_Subprogram_Type: case E_Access_Protected_Subprogram_Type:
case E_Anonymous_Access_Protected_Subprogram_Type: case E_Anonymous_Access_Protected_Subprogram_Type:
/* The run-time representation is the equivalent type. */
if (type_annotate_only && No (gnat_equiv_type)) if (type_annotate_only && No (gnat_equiv_type))
gnu_type = ptr_type_node; gnu_type = ptr_type_node;
else else
{ {
/* The run-time representation is the equivalent type. */
gnu_type = gnat_to_gnu_type (gnat_equiv_type); gnu_type = gnat_to_gnu_type (gnat_equiv_type);
maybe_present = true; maybe_present = true;
} }
/* The designated subtype must be elaborated as well, if it does
not have its own freeze node. */
if (Is_Itype (Directly_Designated_Type (gnat_entity)) if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity)) && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity))) && No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
...@@ -4083,29 +4055,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4083,29 +4055,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
break; break;
case E_Access_Subtype: case E_Access_Subtype:
/* We treat this as identical to its base type; any constraint is /* We treat this as identical to its base type; any constraint is
meaningful only to the front-end. meaningful only to the front-end. */
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
The designated type must be elaborated as well, if it does /* The designated subtype must be elaborated as well, if it does
not have its own freeze node. Designated (sub)types created not have its own freeze node. But designated subtypes created
for constrained components of records with discriminants are 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 not elaborated here, because
because their use may appear before the base type is frozen, their use may appear before the base type is frozen and it is
and because it is not clear that they are needed anywhere in not clear that they are needed in gigi. With the current model,
gigi. With the current model, there is no correct place where there is no correct place where they could be elaborated. */
they could be elaborated. */
gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
if (Is_Itype (Directly_Designated_Type (gnat_entity)) if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity)) && !present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& Is_Frozen (Directly_Designated_Type (gnat_entity)) && Is_Frozen (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity)))) && No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
{ {
/* If we are not defining this entity, and we have incomplete /* If we are to defer elaborating incomplete types, make a dummy
entities being processed above us, make a dummy type and type node and elaborate it later. */
elaborate it later. */ if (defer_incomplete_level != 0)
if (!definition && defer_incomplete_level != 0)
{ {
struct incomplete *p = XNEW (struct incomplete); struct incomplete *p = XNEW (struct incomplete);
...@@ -4169,31 +4137,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4169,31 +4137,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
case E_Function: case E_Function:
case E_Procedure: case E_Procedure:
{ {
/* The type returned by a function or else Standard_Void_Type for a
procedure. */
Entity_Id gnat_return_type = Etype (gnat_entity);
tree gnu_return_type;
/* The first GCC parameter declaration (a PARM_DECL node). The
PARM_DECL nodes are chained through the DECL_CHAIN field, so this
actually is the head of this parameter list. */
tree gnu_param_list = NULL_TREE;
/* Non-null for subprograms containing parameters passed by copy-in
copy-out (Ada In Out or Out parameters not passed by reference),
in which case it is the list of nodes used to specify the values
of the In Out/Out parameters that are returned as a record upon
procedure return. The TREE_PURPOSE of an element of this list is
a field of the record and the TREE_VALUE is the PARM_DECL
corresponding to that field. This list will be saved in the
TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
tree gnu_cico_list = NULL_TREE;
/* List of fields in return type of procedure with copy-in copy-out
parameters. */
tree gnu_field_list = NULL_TREE;
/* If an import pragma asks to map this subprogram to a GCC builtin,
this is the builtin DECL node. */
tree gnu_builtin_decl = NULL_TREE;
tree gnu_ext_name = create_concat_name (gnat_entity, NULL); tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
Entity_Id gnat_param;
enum inline_status_t inline_status enum inline_status_t inline_status
= Has_Pragma_No_Inline (gnat_entity) = Has_Pragma_No_Inline (gnat_entity)
? is_suppressed ? is_suppressed
...@@ -4208,20 +4152,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4208,20 +4152,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
|| imported_p || imported_p
|| (Convention (gnat_entity) == Convention_Intrinsic || (Convention (gnat_entity) == Convention_Intrinsic
&& Has_Pragma_Inline_Always (gnat_entity))); && Has_Pragma_Inline_Always (gnat_entity)));
/* The semantics of "pure" in Ada essentially matches that of "const" tree gnu_param_list;
in the back-end. In particular, both properties are orthogonal to
the "nothrow" property if the EH circuitry is explicit in the
internal representation of the back-end. If we are to completely
hide the EH circuitry from it, we need to declare that calls to pure
Ada subprograms that can throw have side effects since they can
trigger an "abnormal" transfer of control flow; thus they can be
neither "const" nor "pure" in the back-end sense. */
bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_entity));
bool volatile_flag = No_Return (gnat_entity);
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
int parmnum;
/* A parameter may refer to this type, so defer completion of any /* A parameter may refer to this type, so defer completion of any
incomplete types. */ incomplete types. */
...@@ -4283,491 +4214,139 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4283,491 +4214,139 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
break; break;
} }
/* Get the GCC tree for the (underlying) subprogram type. If the
entity is an actual subprogram, also get the parameter list. */
gnu_type
= gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
&gnu_param_list);
/* If this subprogram is expectedly bound to a GCC builtin, fetch the /* If this subprogram is expectedly bound to a GCC builtin, fetch the
corresponding DECL node. Proper generation of calls later on need corresponding DECL node and check the parameter association. */
proper parameter associations so we don't "break;" here. */
if (Convention (gnat_entity) == Convention_Intrinsic if (Convention (gnat_entity) == Convention_Intrinsic
&& Present (Interface_Name (gnat_entity))) && Present (Interface_Name (gnat_entity)))
{ {
gnu_builtin_decl = builtin_decl_for (gnu_ext_name); tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
/* If we have a builtin DECL for that function, use it. Check if
the profiles are compatible and warn if they are not. Note that
the checker is expected to post diagnostics in this case. */
if (gnu_builtin_decl)
{
intrin_binding_t inb
= { gnat_entity, gnu_type, TREE_TYPE (gnu_builtin_decl) };
if (!intrin_profiles_compatible_p (&inb))
post_error
("?profile of& doesn''t match the builtin it binds!",
gnat_entity);
gnu_decl = gnu_builtin_decl;
gnu_type = TREE_TYPE (gnu_builtin_decl);
break;
}
/* Inability to find the builtin decl most often indicates a /* Inability to find the builtin DECL most often indicates a
genuine mistake, but imports of unregistered intrinsics are genuine mistake, but imports of unregistered intrinsics are
sometimes issued on purpose to allow hooking in alternate sometimes issued on purpose to allow hooking in alternate
bodies. We post a warning conditioned on Wshadow in this case, bodies. We post a warning conditioned on Wshadow in this case,
to let developers be notified on demand without risking false to let developers be notified on demand without risking false
positives with common default sets of options. */ positives with common default sets of options. */
else if (warn_shadow)
if (!gnu_builtin_decl && warn_shadow)
post_error ("?gcc intrinsic not found for&!", gnat_entity); post_error ("?gcc intrinsic not found for&!", gnat_entity);
} }
/* ??? What if we don't find the builtin node above ? warn ? err ? /* If there was no specified Interface_Name and the external and
In the current state we neither warn nor err, and calls will just internal names of the subprogram are the same, only use the
be handled as for regular subprograms. */ internal name to allow disambiguation of nested subprograms. */
if (No (Interface_Name (gnat_entity))
/* Look into the return type and get its associated GCC tree. If it && gnu_ext_name == gnu_entity_name)
is not void, compute various flags for the subprogram type. */ gnu_ext_name = NULL_TREE;
if (Ekind (gnat_return_type) == E_Void)
gnu_return_type = void_type_node;
else
{
/* Ada 2012 (AI05-0151): Incomplete types coming from a limited
context may now appear in parameter and result profiles. If
we are only annotating types, break circularities here. */
if (type_annotate_only
&& is_from_limited_with_of_main (gnat_return_type))
gnu_return_type = void_type_node;
else
gnu_return_type = gnat_to_gnu_type (gnat_return_type);
/* If this function returns by reference, make the actual return
type the pointer type and make a note of that. */
if (Returns_By_Ref (gnat_entity))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_by_direct_ref_p = true;
}
/* If the return type is an unconstrained array type, the return
value will be allocated on the secondary stack so the actual
return type is the fat pointer type. */
else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
{
gnu_return_type = TREE_TYPE (gnu_return_type);
return_unconstrained_p = true;
}
/* Likewise, if the return type requires a transient scope, the
return value will also be allocated on the secondary stack so
the actual return type is the pointer type. */
else if (Requires_Transient_Scope (gnat_return_type))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_unconstrained_p = true;
}
/* If the Mechanism is By_Reference, ensure this function uses the /* Deal with platform-specific calling conventions. */
target's by-invisible-reference mechanism, which may not be the if (Has_Stdcall_Convention (gnat_entity))
same as above (e.g. it might be passing an extra parameter). */ prepend_one_attribute
else if (kind == E_Function (&attr_list, ATTR_MACHINE_ATTRIBUTE,
&& Mechanism (gnat_entity) == By_Reference) get_identifier ("stdcall"), NULL_TREE,
return_by_invisi_ref_p = true; gnat_entity);
else if (Has_Thiscall_Convention (gnat_entity))
prepend_one_attribute
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("thiscall"), NULL_TREE,
gnat_entity);
/* Likewise, if the return type is itself By_Reference. */ /* If we should request stack realignment for a foreign convention
else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type)) subprogram, do so. Note that this applies to task entry points
return_by_invisi_ref_p = true; in particular. */
if (FOREIGN_FORCE_REALIGN_STACK
&& Has_Foreign_Convention (gnat_entity))
prepend_one_attribute
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("force_align_arg_pointer"), NULL_TREE,
gnat_entity);
/* If the type is a padded type and the underlying type would not /* Deal with a pragma Linker_Section on a subprogram. */
be passed by reference or the function has a foreign convention, if ((kind == E_Function || kind == E_Procedure)
return the underlying type. */ && Present (Linker_Section_Pragma (gnat_entity)))
else if (TYPE_IS_PADDING_P (gnu_return_type) prepend_one_attribute_pragma (&attr_list,
&& (!default_pass_by_ref Linker_Section_Pragma (gnat_entity));
(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 /* If we are defining the subprogram and it has an Address clause
maximum size. Use the padded type as the effective return type. we must get the address expression from the saved GCC tree for the
And ensure the function uses the target's by-invisible-reference subprogram if it has a Freeze_Node. Otherwise, we elaborate
mechanism to avoid copying too much data when it returns. */ the address expression here since the front-end has guaranteed
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type))) in that case that the elaboration has no effects. If there is
an Address clause and we are not defining the object, just
make it a constant. */
if (Present (Address_Clause (gnat_entity)))
{ {
tree orig_type = gnu_return_type; tree gnu_address = NULL_TREE;
tree max_return_size
= max_size (TYPE_SIZE (gnu_return_type), true);
/* If the size overflows to 0, set it to an arbitrary positive if (definition)
value so that assignments in the type are preserved. Their gnu_address
actual size is independent of this positive value. */ = (present_gnu_tree (gnat_entity)
if (TREE_CODE (max_return_size) == INTEGER_CST ? get_gnu_tree (gnat_entity)
&& TREE_OVERFLOW (max_return_size) : gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
&& integer_zerop (max_return_size))
{
max_return_size = copy_node (bitsize_unit_node);
TREE_OVERFLOW (max_return_size) = 1;
}
gnu_return_type save_gnu_tree (gnat_entity, NULL_TREE, false);
= maybe_pad_type (gnu_return_type, max_return_size, 0,
gnat_entity, false, false, definition,
true);
/* Declare it now since it will never be declared otherwise. /* Convert the type of the object to a reference type that can
This is necessary to ensure that its subtrees are properly alias everything as per RM 13.3(19). */
marked. */ gnu_type
if (gnu_return_type != orig_type = build_reference_type_for_mode (gnu_type, ptr_mode, true);
&& !DECL_P (TYPE_NAME (gnu_return_type))) if (gnu_address)
create_type_decl (TYPE_NAME (gnu_return_type), gnu_address = convert (gnu_type, gnu_address);
gnu_return_type, true, debug_info_p,
gnat_entity);
return_by_invisi_ref_p = true; gnu_decl
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_address, false, Is_Public (gnat_entity),
extern_flag, false, false, artificial_p,
debug_info_p, NULL, gnat_entity);
DECL_BY_REF_P (gnu_decl) = 1;
} }
/* If the return type has a size that overflows, we cannot have else if (kind == E_Subprogram_Type)
a function that returns that type. This usage doesn't make
sense anyway, so give an error here. */
if (!return_by_invisi_ref_p
&& TYPE_SIZE_UNIT (gnu_return_type)
&& TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
&& !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
{ {
post_error ("cannot return type whose size overflows", process_attributes (&gnu_type, &attr_list, false, gnat_entity);
gnat_entity);
gnu_return_type = copy_type (gnu_return_type); gnu_decl
TYPE_SIZE (gnu_return_type) = bitsize_zero_node; = create_type_decl (gnu_entity_name, gnu_type, artificial_p,
TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node; debug_info_p, gnat_entity);
}
} }
/* Loop over the parameters and get their associated GCC tree. While else
doing this, build a copy-in copy-out structure if we need one. */
for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
{ {
Entity_Id gnat_param_type = Etype (gnat_param); gnu_decl
tree gnu_param_name = get_entity_name (gnat_param); = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
tree gnu_param_type, gnu_param, gnu_field; gnu_param_list, inline_status,
Mechanism_Type mech = Mechanism (gnat_param); public_flag, extern_flag,
bool copy_in_copy_out = false, fake_param_type; artificial_p, debug_info_p,
attr_list, gnat_entity);
/* Ada 2012 (AI05-0151): Incomplete types coming from a limited DECL_STUBBED_P (gnu_decl)
context may now appear in parameter and result profiles. If = (Convention (gnat_entity) == Convention_Stubbed);
we are only annotating types, break circularities here. */
if (type_annotate_only
&& is_from_limited_with_of_main (gnat_param_type))
{
gnu_param_type = void_type_node;
fake_param_type = true;
} }
else
{
gnu_param_type = gnat_to_gnu_type (gnat_param_type);
fake_param_type = false;
} }
break;
/* Builtins are expanded inline and there is no real call sequence
involved. So the type expected by the underlying expander is
always the type of each argument "as is". */
if (gnu_builtin_decl)
mech = By_Copy;
/* Handle the first parameter of a valued procedure specially. */
else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
mech = By_Copy_Return;
/* Otherwise, see if a Mechanism was supplied that forced this
parameter to be passed one way or another. */
else if (mech == Default
|| mech == By_Copy
|| mech == By_Reference)
;
else if (mech > 0)
{
if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
|| TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
|| 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
mech))
mech = By_Reference;
else
mech = By_Copy;
}
else
{
post_error ("unsupported mechanism for&", gnat_param);
mech = Default;
}
/* Do not call gnat_to_gnu_param for a fake parameter type since
it will try to use the real type again. */
if (fake_param_type)
{
if (Ekind (gnat_param) == E_Out_Parameter)
gnu_param = NULL_TREE;
else
{
gnu_param
= create_param_decl (gnu_param_name, gnu_param_type,
false);
Set_Mechanism (gnat_param,
mech == Default ? By_Copy : mech);
if (Ekind (gnat_param) == E_In_Out_Parameter)
copy_in_copy_out = true;
}
}
else
gnu_param
= gnat_to_gnu_param (gnat_param, mech, gnat_entity,
Has_Foreign_Convention (gnat_entity),
&copy_in_copy_out);
/* We are returned either a PARM_DECL or a type if no parameter
needs to be passed; in either case, adjust the type. */
if (DECL_P (gnu_param))
gnu_param_type = TREE_TYPE (gnu_param);
else
{
gnu_param_type = gnu_param;
gnu_param = NULL_TREE;
}
/* The failure of this assertion will very likely come from an
order of elaboration issue for the type of the parameter. */
gcc_assert (kind == E_Subprogram_Type
|| !TYPE_IS_DUMMY_P (gnu_param_type)
|| type_annotate_only);
if (gnu_param)
{
gnu_param_list = chainon (gnu_param, gnu_param_list);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_param));
save_gnu_tree (gnat_param, gnu_param, false);
/* If a parameter is a pointer, this function may modify
memory through it and thus shouldn't be considered
a const function. Also, the memory may be modified
between two calls, so they can't be CSE'ed. The latter
case also handles by-ref parameters. */
if (POINTER_TYPE_P (gnu_param_type)
|| TYPE_IS_FAT_POINTER_P (gnu_param_type))
const_flag = false;
}
if (copy_in_copy_out)
{
if (!gnu_cico_list)
{
tree gnu_new_ret_type = make_node (RECORD_TYPE);
/* If this is a function, we also need a field for the
return value to be placed. */
if (TREE_CODE (gnu_return_type) != VOID_TYPE)
{
gnu_field
= create_field_decl (get_identifier ("RETVAL"),
gnu_return_type,
gnu_new_ret_type, NULL_TREE,
NULL_TREE, 0, 0);
Sloc_to_locus (Sloc (gnat_entity),
&DECL_SOURCE_LOCATION (gnu_field));
gnu_field_list = gnu_field;
gnu_cico_list
= tree_cons (gnu_field, void_type_node, NULL_TREE);
}
gnu_return_type = gnu_new_ret_type;
TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
/* Set a default alignment to speed up accesses. But we
shouldn't increase the size of the structure too much,
lest it doesn't fit in return registers anymore. */
SET_TYPE_ALIGN (gnu_return_type,
get_mode_alignment (ptr_mode));
}
gnu_field
= create_field_decl (gnu_param_name, gnu_param_type,
gnu_return_type, NULL_TREE, NULL_TREE,
0, 0);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_field));
DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
gnu_cico_list
= tree_cons (gnu_field, gnu_param, gnu_cico_list);
}
}
if (gnu_cico_list)
{
/* If we have a CICO list but it has only one entry, we convert
this function into a function that returns this object. */
if (list_length (gnu_cico_list) == 1)
gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
/* Do not finalize the return type if the subprogram is stubbed
since structures are incomplete for the back-end. */
else if (Convention (gnat_entity) != Convention_Stubbed)
{
finish_record_type (gnu_return_type, nreverse (gnu_field_list),
0, false);
/* Try to promote the mode of the return type if it is passed
in registers, again to speed up accesses. */
if (TYPE_MODE (gnu_return_type) == BLKmode
&& !targetm.calls.return_in_memory (gnu_return_type,
NULL_TREE))
{
unsigned int size
= TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
unsigned int i = BITS_PER_UNIT;
machine_mode mode;
while (i < size)
i <<= 1;
mode = mode_for_size (i, MODE_INT, 0);
if (mode != BLKmode)
{
SET_TYPE_MODE (gnu_return_type, mode);
SET_TYPE_ALIGN (gnu_return_type,
GET_MODE_ALIGNMENT (mode));
TYPE_SIZE (gnu_return_type)
= bitsize_int (GET_MODE_BITSIZE (mode));
TYPE_SIZE_UNIT (gnu_return_type)
= size_int (GET_MODE_SIZE (mode));
}
}
if (debug_info_p)
rest_of_record_type_compilation (gnu_return_type);
}
}
/* Deal with platform-specific calling conventions. */
if (Has_Stdcall_Convention (gnat_entity))
prepend_one_attribute
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("stdcall"), NULL_TREE,
gnat_entity);
else if (Has_Thiscall_Convention (gnat_entity))
prepend_one_attribute
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("thiscall"), NULL_TREE,
gnat_entity);
/* If 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
(&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("force_align_arg_pointer"), NULL_TREE,
gnat_entity);
/* Deal with a pragma Linker_Section on a subprogram. */
if ((kind == E_Function || kind == E_Procedure)
&& Present (Linker_Section_Pragma (gnat_entity)))
prepend_one_attribute_pragma (&attr_list,
Linker_Section_Pragma (gnat_entity));
/* The lists have been built in reverse. */
gnu_param_list = nreverse (gnu_param_list);
gnu_cico_list = nreverse (gnu_cico_list);
if (kind == E_Function)
Set_Mechanism (gnat_entity, return_unconstrained_p
|| return_by_direct_ref_p
|| return_by_invisi_ref_p
? By_Reference : By_Copy);
gnu_type
= create_subprog_type (gnu_return_type, gnu_param_list,
gnu_cico_list, return_unconstrained_p,
return_by_direct_ref_p,
return_by_invisi_ref_p);
/* A procedure (something that doesn't return anything) shouldn't be
considered const since there would be no reason for calling such a
subprogram. Note that procedures with Out (or In Out) parameters
have already been converted into a function with a return type.
Similarly, if the function returns an unconstrained type, then the
function will allocate the return value on the secondary stack and
thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
const_flag = false;
/* If we have a builtin decl for that function, use it. Check if the
profiles are compatible and warn if they are not. The checker is
expected to post extra diagnostics in this case. */
if (gnu_builtin_decl)
{
intrin_binding_t inb;
inb.gnat_entity = gnat_entity;
inb.ada_fntype = gnu_type;
inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
if (!intrin_profiles_compatible_p (&inb))
post_error
("?profile of& doesn''t match the builtin it binds!",
gnat_entity);
gnu_decl = gnu_builtin_decl;
gnu_type = TREE_TYPE (gnu_builtin_decl);
break;
}
/* If there was no specified Interface_Name and the external and
internal names of the subprogram are the same, only use the
internal name to allow disambiguation of nested subprograms. */
if (No (Interface_Name (gnat_entity))
&& gnu_ext_name == gnu_entity_name)
gnu_ext_name = NULL_TREE;
/* If we are defining the subprogram and it has an Address clause
we must get the address expression from the saved GCC tree for the
subprogram if it has a Freeze_Node. Otherwise, we elaborate
the address expression here since the front-end has guaranteed
in that case that the elaboration has no effects. If there is
an Address clause and we are not defining the object, just
make it a constant. */
if (Present (Address_Clause (gnat_entity)))
{
tree gnu_address = NULL_TREE;
if (definition)
gnu_address
= (present_gnu_tree (gnat_entity)
? get_gnu_tree (gnat_entity)
: gnat_to_gnu (Expression (Address_Clause (gnat_entity))));
save_gnu_tree (gnat_entity, NULL_TREE, false);
/* Convert the type of the object to a reference type that can
alias everything as per RM 13.3(19). */
gnu_type
= build_reference_type_for_mode (gnu_type, ptr_mode, true);
if (gnu_address)
gnu_address = convert (gnu_type, gnu_address);
gnu_decl
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_address, false, Is_Public (gnat_entity),
extern_flag, false, false, artificial_p,
debug_info_p, NULL, gnat_entity);
DECL_BY_REF_P (gnu_decl) = 1;
}
else if (kind == E_Subprogram_Type)
{
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
if (const_flag || volatile_flag)
{
const int quals
= (const_flag ? TYPE_QUAL_CONST : 0)
| (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
gnu_type = change_qualified_type (gnu_type, quals);
}
gnu_decl
= create_type_decl (gnu_entity_name, gnu_type, artificial_p,
debug_info_p, gnat_entity);
}
else
{
gnu_decl
= create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
gnu_param_list, inline_status, const_flag,
public_flag, extern_flag, volatile_flag,
artificial_p, debug_info_p,
attr_list, gnat_entity);
/* This is unrelated to the stub built right above. */
DECL_STUBBED_P (gnu_decl)
= Convention (gnat_entity) == Convention_Stubbed;
}
}
break;
case E_Incomplete_Type: case E_Incomplete_Type:
case E_Incomplete_Subtype: case E_Incomplete_Subtype:
...@@ -4778,14 +4357,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4778,14 +4357,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
case E_Record_Type_With_Private: case E_Record_Type_With_Private:
case E_Record_Subtype_With_Private: case E_Record_Subtype_With_Private:
{ {
bool is_from_limited_with const bool is_from_limited_with
= (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity)); = (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
/* Get the "full view" of this entity. If this is an incomplete /* Get the "full view" of this entity. If this is an incomplete
entity from a limited with, treat its non-limited view as the entity from a limited with, treat its non-limited view as the
full view. Otherwise, use either the full view or the underlying full view. Otherwise, use either the full view or the underlying
full view, whichever is present. This is used in all the tests full view, whichever is present. This is used in all the tests
below. */ below. */
Entity_Id full_view const Entity_Id full_view
= is_from_limited_with = is_from_limited_with
? Non_Limited_View (gnat_entity) ? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity)) : Present (Full_View (gnat_entity))
...@@ -4810,43 +4389,39 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -4810,43 +4389,39 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
= gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false); = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
maybe_present = true; maybe_present = true;
} }
break;
} }
/* If we already made a type for the full view, reuse it. */ /* Or else, if we already made a type for the full view, reuse it. */
else if (present_gnu_tree (full_view)) else if (present_gnu_tree (full_view))
{
gnu_decl = get_gnu_tree (full_view); gnu_decl = get_gnu_tree (full_view);
break;
}
/* Otherwise, if we are not defining the type now, get the type /* Or else, if we are not defining the type or there is no freeze
from the full view. But always get the type from the full view node on it, get the type for the full view. Likewise if this is
for define on use types, since otherwise we won't see them. a limited_with'ed type not declared in the main unit, which can
Likewise if this is a non-limited view not declared in the main happen for incomplete formal types instantiated on a type coming
unit, which can happen for incomplete formal types instantiated from a limited_with clause. */
on a type coming from a limited_with clause. */
else if (!definition else if (!definition
|| (Is_Itype (full_view) && No (Freeze_Node (gnat_entity))) || No (Freeze_Node (full_view))
|| (Is_Itype (gnat_entity) && No (Freeze_Node (full_view)))
|| (is_from_limited_with || (is_from_limited_with
&& !In_Extended_Main_Code_Unit (full_view))) && !In_Extended_Main_Code_Unit (full_view)))
{ {
gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false); gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
maybe_present = true; maybe_present = true;
break;
} }
/* For incomplete types, make a dummy type entry which will be /* Otherwise, make a dummy type entry which will be replaced later.
replaced later. Save it as the full declaration's type so Save it as the full declaration's type so we can do any needed
we can do any needed updates when we see it. */ updates when we see it. */
else
{
gnu_type = make_dummy_type (gnat_entity); gnu_type = make_dummy_type (gnat_entity);
gnu_decl = TYPE_STUB_DECL (gnu_type); gnu_decl = TYPE_STUB_DECL (gnu_type);
if (Has_Completion_In_Body (gnat_entity)) if (Has_Completion_In_Body (gnat_entity))
DECL_TAFT_TYPE_P (gnu_decl) = 1; DECL_TAFT_TYPE_P (gnu_decl) = 1;
save_gnu_tree (full_view, gnu_decl, 0); save_gnu_tree (full_view, gnu_decl, 0);
break;
} }
}
break;
case E_Class_Wide_Type: case E_Class_Wide_Type:
/* Class-wide types are always transformed into their root type. */ /* Class-wide types are always transformed into their root type. */
...@@ -5171,7 +4746,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -5171,7 +4746,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
if (Present (Alignment_Clause (gnat_entity))) if (Present (Alignment_Clause (gnat_entity)))
TYPE_USER_ALIGN (gnu_type) = 1; TYPE_USER_ALIGN (gnu_type) = 1;
if (Universal_Aliasing (gnat_entity)) if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1; TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
/* If it is passed by reference, force BLKmode to ensure that /* If it is passed by reference, force BLKmode to ensure that
...@@ -5456,7 +5031,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition) ...@@ -5456,7 +5031,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
p->old_type = NULL_TREE; p->old_type = NULL_TREE;
} }
for (p = defer_limited_with; p; p = p->next) for (p = defer_limited_with_list; p; p = p->next)
if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity) if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
{ {
update_pointer_to (TYPE_MAIN_VARIANT (p->old_type), update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
...@@ -5525,49 +5100,8 @@ get_unpadded_type (Entity_Id gnat_entity) ...@@ -5525,49 +5100,8 @@ get_unpadded_type (Entity_Id gnat_entity)
return type; return type;
} }
/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
type has been changed to that of the parameterless procedure, except if an a C++ imported method or equivalent.
alias is already present, in which case it is returned instead. */
tree
get_minimal_subprog_decl (Entity_Id gnat_entity)
{
tree gnu_entity_name, gnu_ext_name;
struct attrib *attr_list = NULL;
/* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
of the handling applied here. */
while (Present (Alias (gnat_entity)))
{
gnat_entity = Alias (gnat_entity);
if (present_gnu_tree (gnat_entity))
return get_gnu_tree (gnat_entity);
}
gnu_entity_name = get_entity_name (gnat_entity);
gnu_ext_name = create_concat_name (gnat_entity, NULL);
if (Has_Stdcall_Convention (gnat_entity))
prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("stdcall"), NULL_TREE,
gnat_entity);
else if (Has_Thiscall_Convention (gnat_entity))
prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
get_identifier ("thiscall"), NULL_TREE,
gnat_entity);
if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
gnu_ext_name = NULL_TREE;
return
create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false,
attr_list, gnat_entity);
}
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent.
We use the predicate on 32-bit x86/Windows to find out whether we need to 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 use the "thiscall" calling convention for GNAT_ENTITY. This convention is
...@@ -5622,16 +5156,21 @@ finalize_from_limited_with (void) ...@@ -5622,16 +5156,21 @@ finalize_from_limited_with (void)
{ {
struct incomplete *p, *next; struct incomplete *p, *next;
p = defer_limited_with; p = defer_limited_with_list;
defer_limited_with = NULL; defer_limited_with_list = NULL;
for (; p; p = next) for (; p; p = next)
{ {
next = p->next; next = p->next;
if (p->old_type) if (p->old_type)
{
update_pointer_to (TYPE_MAIN_VARIANT (p->old_type), update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
gnat_to_gnu_type (p->full_type)); gnat_to_gnu_type (p->full_type));
if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
update_profiles_with (p->old_type);
}
free (p); free (p);
} }
} }
...@@ -5786,204 +5325,803 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition, ...@@ -5786,204 +5325,803 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
return gnu_type; return gnu_type;
} }
/* Return a GCC tree for a parameter corresponding to GNAT_PARAM and /* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
using MECH as its passing mechanism, to be placed in the parameter in the parameter list built for GNAT_SUBPROG. FIRST is true if GNAT_PARAM
list built for GNAT_SUBPROG. Assume a foreign convention for the is the first parameter in the list. Also set CICO to true if the parameter
latter if FOREIGN is true. Also set CICO to true if the parameter
must use the copy-in copy-out implementation mechanism. must use the copy-in copy-out implementation mechanism.
The returned tree is a PARM_DECL, except for those cases where no The returned tree is a PARM_DECL, except for those cases where no
parameter needs to be actually passed to the subprogram; the type parameter needs to be actually passed to the subprogram; the type
of this "shadow" parameter is then returned instead. */ of this "shadow" parameter is then returned instead. */
static tree
gnat_to_gnu_param (Entity_Id gnat_param, bool first, Entity_Id gnat_subprog,
bool *cico)
{
Entity_Id gnat_param_type = Etype (gnat_param);
Mechanism_Type mech = Mechanism (gnat_param);
tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (gnat_param_type);
bool foreign = Has_Foreign_Convention (gnat_subprog);
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
bool by_return = false, by_component_ptr = false;
bool by_ref = false;
bool restricted_aliasing_p = false;
tree gnu_param;
/* Builtins are expanded inline and there is no real call sequence involved.
So the type expected by the underlying expander is always the type of the
argument "as is". */
if (Convention (gnat_subprog) == Convention_Intrinsic
&& Present (Interface_Name (gnat_subprog)))
mech = By_Copy;
/* Handle the first parameter of a valued procedure specially: it's a copy
mechanism for which the parameter is never allocated. */
else if (first && Is_Valued_Procedure (gnat_subprog))
{
gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
mech = By_Copy;
by_return = true;
}
/* Or else, see if a Mechanism was supplied that forced this parameter
to be passed one way or another. */
else if (mech == Default || mech == By_Copy || mech == By_Reference)
;
/* Positive mechanism means by copy for sufficiently small parameters. */
else if (mech > 0)
{
if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
|| TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
|| compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
mech = By_Reference;
else
mech = By_Copy;
}
/* Otherwise, it's an unsupported mechanism so error out. */
else
{
post_error ("unsupported mechanism for&", gnat_param);
mech = Default;
}
/* If this is either a foreign function or if the underlying type won't
be passed by reference and is as aligned as the original type, strip
off possible padding type. */
if (TYPE_IS_PADDING_P (gnu_param_type))
{
tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type));
if (foreign
|| (!must_pass_by_ref (unpadded_type)
&& mech != By_Reference
&& (mech == By_Copy || !default_pass_by_ref (unpadded_type))
&& TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type)))
gnu_param_type = unpadded_type;
}
/* If this is a read-only parameter, make a variant of the type that is
read-only. ??? However, if this is an unconstrained array, that type
can be very complex, so skip it for now. Likewise for any other
self-referential type. */
if (ro_param
&& TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
/* For foreign conventions, pass arrays as pointers to the element type.
First check for unconstrained array and get the underlying array. */
if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
/* For GCC builtins, pass Address integer types as (void *) */
if (Convention (gnat_subprog) == Convention_Intrinsic
&& Present (Interface_Name (gnat_subprog))
&& Is_Descendant_Of_Address (gnat_param_type))
gnu_param_type = ptr_type_node;
/* Arrays are passed as pointers to element type for foreign conventions. */
if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{
/* Strip off any multi-dimensional entries, then strip
off the last array to get the component type. */
while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
gnu_param_type = TREE_TYPE (gnu_param_type);
by_component_ptr = true;
gnu_param_type = TREE_TYPE (gnu_param_type);
if (ro_param)
gnu_param_type
= change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
gnu_param_type = build_pointer_type (gnu_param_type);
}
/* Fat pointers are passed as thin pointers for foreign conventions. */
else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type))
gnu_param_type
= make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
/* If we were requested or muss pass by reference, do so.
If we were requested to pass by copy, do so.
Otherwise, for foreign conventions, pass In Out or Out parameters
or aggregates by reference. For COBOL and Fortran, pass all
integer and FP types that way too. For Convention Ada, use
the standard Ada default. */
else if (mech == By_Reference
|| must_pass_by_ref (gnu_param_type)
|| (mech != By_Copy
&& ((foreign
&& (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
|| (foreign
&& (Convention (gnat_subprog) == Convention_Fortran
|| Convention (gnat_subprog) == Convention_COBOL)
&& (INTEGRAL_TYPE_P (gnu_param_type)
|| FLOAT_TYPE_P (gnu_param_type)))
|| (!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 allow only a restricted form of aliasing. */
restricted_aliasing_p
= !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
gnu_param_type = build_reference_type (gnu_param_type);
by_ref = true;
}
/* Pass In Out or Out parameters using copy-in copy-out mechanism. */
else if (!in_param)
*cico = true;
if (mech == By_Copy && (by_ref || by_component_ptr))
post_error ("?cannot pass & by copy", gnat_param);
/* If this is an Out parameter that isn't passed by reference and isn't
a pointer or aggregate, we don't make a PARM_DECL for it. Instead,
it will be a VAR_DECL created when we process the procedure, so just
return its type. For the special parameter of a valued procedure,
never pass it in.
An exception is made to cover the RM-6.4.1 rule requiring "by copy"
Out parameters with discriminants or implicit initial values to be
handled like In Out parameters. These type are normally built as
aggregates, hence passed by reference, except for some packed arrays
which end up encoded in special integer types. Note that scalars can
be given implicit initial values using the Default_Value aspect.
The exception we need to make is then for packed arrays of records
with discriminants or implicit initial values. We have no light/easy
way to check for the latter case, so we merely check for packed arrays
of records. This may lead to useless copy-in operations, but in very
rare cases only, as these would be exceptions in a set of already
exceptional situations. */
if (Ekind (gnat_param) == E_Out_Parameter
&& !by_ref
&& (by_return
|| (!POINTER_TYPE_P (gnu_param_type)
&& !AGGREGATE_TYPE_P (gnu_param_type)
&& !Has_Default_Aspect (gnat_param_type)))
&& !(Is_Array_Type (gnat_param_type)
&& Is_Packed (gnat_param_type)
&& Is_Composite_Type (Component_Type (gnat_param_type))))
return gnu_param_type;
gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */
if (mech == Default)
mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy;
Set_Mechanism (gnat_param, mech);
return gnu_param;
}
/* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
GNAT_SUBPROG is updated when TYPE is completed. */
static void
associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
{
gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
struct tree_entity_vec_map in;
in.base.from = gnu_type;
struct tree_entity_vec_map **slot
= dummy_to_subprog_map->find_slot (&in, INSERT);
if (!*slot)
{
tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
e->base.from = gnu_type;
e->to = NULL;
*slot = e;
TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
}
vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
/* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
since this would mean updating twice its profile. */
if (v)
{
const unsigned len = v->length ();
unsigned int l = 0, u = len;
/* Entity_Id is a simple integer so we can implement a stable order on
the vector with an ordered insertion scheme and binary search. */
while (l < u)
{
unsigned int m = (l + u) / 2;
int diff = (int) (*v)[m] - (int) gnat_subprog;
if (diff > 0)
u = m;
else if (diff < 0)
l = m + 1;
else
return;
}
/* l == u and therefore is the insertion point. */
vec_safe_insert (v, l, gnat_subprog);
}
else
vec_safe_push (v, gnat_subprog);
(*slot)->to = v;
}
/* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
static void
update_profile (Entity_Id gnat_subprog)
{
tree gnu_param_list;
tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
Needs_Debug_Info (gnat_subprog),
&gnu_param_list);
tree gnu_subprog = get_gnu_tree (gnat_subprog);
TREE_TYPE (gnu_subprog) = gnu_type;
/* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
and needs to be adjusted too. */
if (Ekind (gnat_subprog) != E_Subprogram_Type)
{
DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
finish_subprog_decl (gnu_subprog, gnu_type);
}
}
/* Update the GCC trees previously built for the profiles involving GNU_TYPE,
a dummy type which appears in profiles. */
void
update_profiles_with (tree gnu_type)
{
struct tree_entity_vec_map in;
in.base.from = gnu_type;
struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
gcc_assert (e);
vec<Entity_Id, va_gc_atomic> *v = e->to;
e->to = NULL;
TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
unsigned int i;
Entity_Id *iter;
FOR_EACH_VEC_ELT (*v, i, iter)
update_profile (*iter);
vec_free (v);
}
/* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
Ada 2012 (AI05-0151) says that incomplete types coming from a limited
context may now appear as parameter and result types. As a consequence,
we may need to defer their translation until after a freeze node is seen
or to the end of the current unit. We also aim at handling temporarily
incomplete types created by the usual delayed elaboration scheme. */
static tree
gnat_to_gnu_profile_type (Entity_Id gnat_type)
{
/* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
so the rationale is exposed in that place. These processings probably
ought to be merged at some point. */
Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
const bool is_from_limited_with
= (IN (Ekind (gnat_equiv), Incomplete_Kind)
&& From_Limited_With (gnat_equiv));
Entity_Id gnat_full_direct_first
= (is_from_limited_with
? Non_Limited_View (gnat_equiv)
: (IN (Ekind (gnat_equiv), Incomplete_Or_Private_Kind)
? Full_View (gnat_equiv) : Empty));
Entity_Id gnat_full_direct
= ((is_from_limited_with
&& Present (gnat_full_direct_first)
&& IN (Ekind (gnat_full_direct_first), Private_Kind))
? Full_View (gnat_full_direct_first)
: gnat_full_direct_first);
Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
tree gnu_type;
if (Present (gnat_full) && present_gnu_tree (gnat_full))
gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
else if (is_from_limited_with
&& ((!in_main_unit
&& !present_gnu_tree (gnat_equiv)
&& Present (gnat_full)
&& (Is_Record_Type (gnat_full) || Is_Array_Type (gnat_full)))
|| (in_main_unit && Present (Freeze_Node (gnat_rep)))))
{
gnu_type = make_dummy_type (gnat_equiv);
if (!in_main_unit)
{
struct incomplete *p = XNEW (struct incomplete);
p->old_type = gnu_type;
p->full_type = gnat_equiv;
p->next = defer_limited_with_list;
defer_limited_with_list = p;
}
}
else if (type_annotate_only && No (gnat_equiv))
gnu_type = void_type_node;
else
gnu_type = gnat_to_gnu_type (gnat_equiv);
/* Access-to-unconstrained-array types need a special treatment. */
if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
{
if (!TYPE_POINTER_TO (gnu_type))
build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
}
return gnu_type;
}
/* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
is true if we need to write debug information for other types that we may
create in the process. Also set PARAM_LIST to the list of parameters. */
static tree
gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
bool debug_info_p, tree *param_list)
{
const Entity_Kind kind = Ekind (gnat_subprog);
Entity_Id gnat_return_type = Etype (gnat_subprog);
Entity_Id gnat_param;
tree gnu_return_type;
tree gnu_param_type_list = NULL_TREE;
tree gnu_param_list = NULL_TREE;
/* Non-null for subprograms containing parameters passed by copy-in copy-out
(In Out or Out parameters not passed by reference), in which case it is
the list of nodes used to specify the values of the In Out/Out parameters
that are returned as a record upon procedure return. The TREE_PURPOSE of
an element of this list is a FIELD_DECL of the record and the TREE_VALUE
is the PARM_DECL corresponding to that field. This list will be saved in
the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
tree gnu_cico_list = NULL_TREE;
/* Fields in return type of procedure with copy-in copy-out parameters. */
tree gnu_field_list = NULL_TREE;
/* The semantics of "pure" in Ada essentially matches that of "const"
in the back-end. In particular, both properties are orthogonal to
the "nothrow" property if the EH circuitry is explicit in the
internal representation of the back-end. If we are to completely
hide the EH circuitry from it, we need to declare that calls to pure
Ada subprograms that can throw have side effects since they can
trigger an "abnormal" transfer of control flow; thus they can be
neither "const" nor "pure" in the back-end sense. */
bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
bool return_by_direct_ref_p = false;
bool return_by_invisi_ref_p = false;
bool return_unconstrained_p = false;
bool incomplete_profile_p = false;
unsigned int num;
/* Look into the return type and get its associated GCC tree. If it is not
void, compute various flags for the subprogram type. */
if (Ekind (gnat_return_type) == E_Void)
gnu_return_type = void_type_node;
else
{
gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
/* If this function returns by reference, make the actual return type
the reference type and make a note of that. */
if (Returns_By_Ref (gnat_subprog))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_by_direct_ref_p = true;
}
/* If the return type is an unconstrained array type, the return value
will be allocated on the secondary stack so the actual return type
is the fat pointer type. */
else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
{
gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
return_unconstrained_p = true;
}
/* This is the same unconstrained array case, but for a dummy type. */
else if (TYPE_REFERENCE_TO (gnu_return_type)
&& TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
{
gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
return_unconstrained_p = true;
}
/* Likewise, if the return type requires a transient scope, the return
value will also be allocated on the secondary stack so the actual
return type is the reference type. */
else if (Requires_Transient_Scope (gnat_return_type))
{
gnu_return_type = build_reference_type (gnu_return_type);
return_unconstrained_p = true;
}
/* If the Mechanism is By_Reference, ensure this function uses the
target's by-invisible-reference mechanism, which may not be the
same as above (e.g. it might be passing an extra parameter). */
else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
return_by_invisi_ref_p = true;
/* Likewise, if the return type is itself By_Reference. */
else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
return_by_invisi_ref_p = true;
/* If the type is a padded type and the underlying type would not be
passed by reference or the function has a foreign convention, return
the underlying type. */
else if (TYPE_IS_PADDING_P (gnu_return_type)
&& (!default_pass_by_ref
(TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
|| Has_Foreign_Convention (gnat_subprog)))
gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
/* If the return type is unconstrained, it must have a maximum size.
Use the padded type as the effective return type. And ensure the
function uses the target's by-invisible-reference mechanism to
avoid copying too much data when it returns. */
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
{
tree orig_type = gnu_return_type;
tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
/* If the size overflows to 0, set it to an arbitrary positive
value so that assignments in the type are preserved. Their
actual size is independent of this positive value. */
if (TREE_CODE (max_return_size) == INTEGER_CST
&& TREE_OVERFLOW (max_return_size)
&& integer_zerop (max_return_size))
{
max_return_size = copy_node (bitsize_unit_node);
TREE_OVERFLOW (max_return_size) = 1;
}
gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
0, gnat_subprog, false, false,
definition, true);
/* Declare it now since it will never be declared otherwise. This
is necessary to ensure that its subtrees are properly marked. */
if (gnu_return_type != orig_type
&& !DECL_P (TYPE_NAME (gnu_return_type)))
create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
true, debug_info_p, gnat_subprog);
return_by_invisi_ref_p = true;
}
/* If the return type has a size that overflows, we usually cannot have
a function that returns that type. This usage doesn't really make
sense anyway, so issue an error here. */
if (!return_by_invisi_ref_p
&& TYPE_SIZE_UNIT (gnu_return_type)
&& TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
&& !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
{
post_error ("cannot return type whose size overflows", gnat_subprog);
gnu_return_type = copy_type (gnu_return_type);
TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
}
/* If the return type is incomplete, there are 2 cases: if the function
returns by reference, then the return type is only linked indirectly
in the profile, so the profile can be seen as complete since it need
not be further modified, only the reference types need be adjusted;
otherwise the profile itself is incomplete and need be adjusted. */
if (TYPE_IS_DUMMY_P (gnu_return_type))
{
associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
incomplete_profile_p = true;
}
if (kind == E_Function)
Set_Mechanism (gnat_subprog, return_unconstrained_p
|| return_by_direct_ref_p
|| return_by_invisi_ref_p
? By_Reference : By_Copy);
}
/* A procedure (something that doesn't return anything) shouldn't be
considered const since there would be no reason for calling such a
subprogram. Note that procedures with Out (or In Out) parameters
have already been converted into a function with a return type.
Similarly, if the function returns an unconstrained type, then the
function will allocate the return value on the secondary stack and
thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
const_flag = false;
static tree /* Loop over the parameters and get their associated GCC tree. While doing
gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech, this, build a copy-in copy-out structure if we need one. */
Entity_Id gnat_subprog, bool foreign, bool *cico) for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
{ Present (gnat_param);
gnat_param = Next_Formal_With_Extras (gnat_param), num++)
{
Entity_Id gnat_param_type = Etype (gnat_param);
tree gnu_param_name = get_entity_name (gnat_param); tree gnu_param_name = get_entity_name (gnat_param);
tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param)); tree gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
bool in_param = (Ekind (gnat_param) == E_In_Parameter); tree gnu_param, gnu_field;
/* The parameter can be indirectly modified if its address is taken. */ bool cico = false;
bool ro_param = in_param && !Address_Taken (gnat_param);
bool by_return = false, by_component_ptr = false;
bool by_ref = false;
bool restricted_aliasing_p = false;
tree gnu_param;
/* Copy-return is used only for the first parameter of a valued procedure. /* If the parameter type is incomplete, there are 2 cases: if it is
It's a copy mechanism for which a parameter is never allocated. */ passed by reference, then the type is only linked indirectly in
if (mech == By_Copy_Return) the profile, so the profile can be seen as complete since it need
not be further modified, only the reference types need be adjusted;
otherwise the profile itself is incomplete and need be adjusted. */
if (TYPE_IS_DUMMY_P (gnu_param_type))
{ {
gcc_assert (Ekind (gnat_param) == E_Out_Parameter); Node_Id gnat_decl;
mech = By_Copy;
by_return = true;
}
/* If this is either a foreign function or if the underlying type won't if (Mechanism (gnat_param) == By_Reference
be passed by reference and is as aligned as the original type, strip || (TYPE_REFERENCE_TO (gnu_param_type)
off possible padding type. */ && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_param_type)))
if (TYPE_IS_PADDING_P (gnu_param_type)) || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
{ {
tree unpadded_type = TREE_TYPE (TYPE_FIELDS (gnu_param_type)); gnu_param_type = build_reference_type (gnu_param_type);
gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
if (foreign TREE_READONLY (gnu_param) = 1;
|| (!must_pass_by_ref (unpadded_type) DECL_BY_REF_P (gnu_param) = 1;
&& mech != By_Reference DECL_POINTS_TO_READONLY_P (gnu_param)
&& (mech == By_Copy || !default_pass_by_ref (unpadded_type)) = (Ekind (gnat_param) == E_In_Parameter
&& TYPE_ALIGN (unpadded_type) >= TYPE_ALIGN (gnu_param_type))) && !Address_Taken (gnat_param));
gnu_param_type = unpadded_type; Set_Mechanism (gnat_param, By_Reference);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_param));
} }
/* If this is a read-only parameter, make a variant of the type that is /* ??? This is a kludge to support null procedures in spec taking a
read-only. ??? However, if this is an unconstrained array, that type parameter with an untagged incomplete type coming from a limited
can be very complex, so skip it for now. Likewise for any other context. The front-end creates a body without knowing anything
self-referential type. */ about the non-limited view, which is illegal Ada and cannot be
if (ro_param reasonably supported. Create a parameter with a fake type. */
&& TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE else if (kind == E_Procedure
&& !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type))) && (gnat_decl = Parent (gnat_subprog))
gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST); && Nkind (gnat_decl) == N_Procedure_Specification
&& Null_Present (gnat_decl)
/* For foreign conventions, pass arrays as pointers to the element type. && IN (Ekind (gnat_param_type), Incomplete_Kind))
First check for unconstrained array and get the underlying array. */ gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
if (foreign && TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE)
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
/* For GCC builtins, pass Address integer types as (void *) */ else
if (Convention (gnat_subprog) == Convention_Intrinsic {
&& Present (Interface_Name (gnat_subprog)) gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
&& Is_Descendant_Of_Address (Etype (gnat_param))) associate_subprog_with_dummy_type (gnat_subprog, gnu_param_type);
gnu_param_type = ptr_type_node; incomplete_profile_p = true;
}
}
/* Arrays are passed as pointers to element type for foreign conventions. */ else
if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{ {
/* Strip off any multi-dimensional entries, then strip gnu_param
off the last array to get the component type. */ = gnat_to_gnu_param (gnat_param, num == 0, gnat_subprog, &cico);
while (TREE_CODE (TREE_TYPE (gnu_param_type)) == ARRAY_TYPE
&& TYPE_MULTI_ARRAY_P (TREE_TYPE (gnu_param_type)))
gnu_param_type = TREE_TYPE (gnu_param_type);
by_component_ptr = true; /* We are returned either a PARM_DECL or a type if no parameter
gnu_param_type = TREE_TYPE (gnu_param_type); needs to be passed; in either case, adjust the type. */
if (DECL_P (gnu_param))
gnu_param_type = TREE_TYPE (gnu_param);
else
{
gnu_param_type = gnu_param;
gnu_param = NULL_TREE;
}
}
if (ro_param) /* If we built a GCC tree for the parameter, register it. */
gnu_param_type if (gnu_param)
= change_qualified_type (gnu_param_type, TYPE_QUAL_CONST); {
gnu_param_type_list
= tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
gnu_param_list = chainon (gnu_param, gnu_param_list);
save_gnu_tree (gnat_param, NULL_TREE, false);
save_gnu_tree (gnat_param, gnu_param, false);
gnu_param_type = build_pointer_type (gnu_param_type); /* If a parameter is a pointer, a function may modify memory through
it and thus shouldn't be considered a const function. Also, the
memory may be modified between two calls, so they can't be CSE'ed.
The latter case also handles by-ref parameters. */
if (POINTER_TYPE_P (gnu_param_type)
|| TYPE_IS_FAT_POINTER_P (gnu_param_type))
const_flag = false;
} }
/* Fat pointers are passed as thin pointers for foreign conventions. */ /* If the parameter uses the copy-in copy-out mechanism, allocate a field
else if (foreign && TYPE_IS_FAT_POINTER_P (gnu_param_type)) for it in the return type and register the association. */
gnu_param_type if (cico && !incomplete_profile_p)
= make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0); {
if (!gnu_cico_list)
{
tree gnu_new_ret_type = make_node (RECORD_TYPE);
/* If we must pass or were requested to pass by reference, do so. /* If this is a function, we also need a field for the
If we were requested to pass by copy, do so. return value to be placed. */
Otherwise, for foreign conventions, pass In Out or Out parameters if (TREE_CODE (gnu_return_type) != VOID_TYPE)
or aggregates by reference. For COBOL and Fortran, pass all
integer and FP types that way too. For Convention Ada, use
the standard Ada default. */
else if (must_pass_by_ref (gnu_param_type)
|| mech == By_Reference
|| (mech != By_Copy
&& ((foreign
&& (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
|| (foreign
&& (Convention (gnat_subprog) == Convention_Fortran
|| Convention (gnat_subprog) == Convention_COBOL)
&& (INTEGRAL_TYPE_P (gnu_param_type)
|| FLOAT_TYPE_P (gnu_param_type)))
|| (!foreign
&& default_pass_by_ref (gnu_param_type)))))
{ {
gnu_param_type = build_reference_type (gnu_param_type); gnu_field
/* We take advantage of 6.2(12) by considering that references built for = create_field_decl (get_identifier ("RETVAL"),
parameters whose type isn't by-ref and for which the mechanism hasn't gnu_return_type,
been forced to by-ref allow only a restricted form of aliasing. */ gnu_new_ret_type, NULL_TREE,
restricted_aliasing_p NULL_TREE, 0, 0);
= !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference; Sloc_to_locus (Sloc (gnat_subprog),
by_ref = true; &DECL_SOURCE_LOCATION (gnu_field));
gnu_field_list = gnu_field;
gnu_cico_list
= tree_cons (gnu_field, void_type_node, NULL_TREE);
} }
/* Pass In Out or Out parameters using copy-in copy-out mechanism. */ gnu_return_type = gnu_new_ret_type;
else if (!in_param) TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
*cico = true; /* Set a default alignment to speed up accesses. But we should
not increase the size of the structure too much, lest it does
not fit in return registers anymore. */
SET_TYPE_ALIGN (gnu_return_type, get_mode_alignment (ptr_mode));
}
if (mech == By_Copy && (by_ref || by_component_ptr)) gnu_field
post_error ("?cannot pass & by copy", gnat_param); = create_field_decl (gnu_param_name, gnu_param_type,
gnu_return_type, NULL_TREE, NULL_TREE, 0, 0);
Sloc_to_locus (Sloc (gnat_param),
&DECL_SOURCE_LOCATION (gnu_field));
DECL_CHAIN (gnu_field) = gnu_field_list;
gnu_field_list = gnu_field;
gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
}
}
/* If this is an Out parameter that isn't passed by reference and isn't /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
a pointer or aggregate, we don't make a PARM_DECL for it. Instead, and finish up the return type. */
it will be a VAR_DECL created when we process the procedure, so just if (gnu_cico_list && !incomplete_profile_p)
return its type. For the special parameter of a valued procedure, {
never pass it in. /* 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));
An exception is made to cover the RM-6.4.1 rule requiring "by copy" /* Do not finalize the return type if the subprogram is stubbed
Out parameters with discriminants or implicit initial values to be since structures are incomplete for the back-end. */
handled like In Out parameters. These type are normally built as else if (Convention (gnat_subprog) != Convention_Stubbed)
aggregates, hence passed by reference, except for some packed arrays {
which end up encoded in special integer types. Note that scalars can finish_record_type (gnu_return_type, nreverse (gnu_field_list), 0,
be given implicit initial values using the Default_Value aspect. false);
The exception we need to make is then for packed arrays of records /* Try to promote the mode of the return type if it is passed
with discriminants or implicit initial values. We have no light/easy in registers, again to speed up accesses. */
way to check for the latter case, so we merely check for packed arrays if (TYPE_MODE (gnu_return_type) == BLKmode
of records. This may lead to useless copy-in operations, but in very && !targetm.calls.return_in_memory (gnu_return_type, NULL_TREE))
rare cases only, as these would be exceptions in a set of already {
exceptional situations. */ unsigned int size
if (Ekind (gnat_param) == E_Out_Parameter = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
&& !by_ref unsigned int i = BITS_PER_UNIT;
&& (by_return machine_mode mode;
|| (!POINTER_TYPE_P (gnu_param_type)
&& !AGGREGATE_TYPE_P (gnu_param_type)
&& !Has_Default_Aspect (Etype (gnat_param))))
&& !(Is_Array_Type (Etype (gnat_param))
&& Is_Packed (Etype (gnat_param))
&& Is_Composite_Type (Component_Type (Etype (gnat_param)))))
return gnu_param_type;
gnu_param = create_param_decl (gnu_param_name, gnu_param_type, while (i < size)
ro_param || by_ref || by_component_ptr); i <<= 1;
DECL_BY_REF_P (gnu_param) = by_ref; mode = mode_for_size (i, MODE_INT, 0);
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr; if (mode != BLKmode)
DECL_POINTS_TO_READONLY_P (gnu_param) {
= (ro_param && (by_ref || by_component_ptr)); SET_TYPE_MODE (gnu_return_type, mode);
DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param); SET_TYPE_ALIGN (gnu_return_type, GET_MODE_ALIGNMENT (mode));
DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p; TYPE_SIZE (gnu_return_type)
= bitsize_int (GET_MODE_BITSIZE (mode));
TYPE_SIZE_UNIT (gnu_return_type)
= size_int (GET_MODE_SIZE (mode));
}
}
/* If no Mechanism was specified, indicate what we're using, then if (debug_info_p)
back-annotate it. */ rest_of_record_type_compilation (gnu_return_type);
if (mech == Default) }
mech = (by_ref || by_component_ptr) ? By_Reference : By_Copy; }
Set_Mechanism (gnat_param, mech); /* The lists have been built in reverse. */
return gnu_param; gnu_param_type_list = nreverse (gnu_param_type_list);
} gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
*param_list = nreverse (gnu_param_list);
gnu_cico_list = nreverse (gnu_cico_list);
/* Return true if GNAT_ENTITY is an incomplete entity coming from a limited /* If the profile is incomplete, we only set the (temporary) return and
with of the main unit and whose full view has not been elaborated yet. */ parameter types; otherwise, we build the full type. In either case,
we reuse an already existing GCC tree that we built previously here. */
tree gnu_type = present_gnu_tree (gnat_subprog)
? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
static bool if (incomplete_profile_p)
is_from_limited_with_of_main (Entity_Id gnat_entity) {
{ if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
/* Class-wide types are always transformed into their root type. */ ;
if (Ekind (gnat_entity) == E_Class_Wide_Type) else
gnat_entity = Root_Type (gnat_entity); gnu_type = make_node (FUNCTION_TYPE);
TREE_TYPE (gnu_type) = gnu_return_type;
TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
}
else
{
if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
{
TREE_TYPE (gnu_type) = gnu_return_type;
TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
TYPE_CANONICAL (gnu_type) = gnu_type;
layout_type (gnu_type);
}
else
{
gnu_type
= build_function_type (gnu_return_type, gnu_param_type_list);
if (IN (Ekind (gnat_entity), Incomplete_Kind) /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
&& From_Limited_With (gnat_entity)) has a different TYPE_CI_CO_LIST or flags. */
if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
return_unconstrained_p,
return_by_direct_ref_p,
return_by_invisi_ref_p))
{ {
Entity_Id gnat_full_view = Non_Limited_View (gnat_entity); gnu_type = copy_type (gnu_type);
TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
}
}
if (present_gnu_tree (gnat_full_view)) if (const_flag)
return false; gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
return In_Extended_Main_Code_Unit (gnat_full_view); if (No_Return (gnat_subprog))
gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
} }
return false; return gnu_type;
} }
/* Like build_qualified_type, but TYPE_QUALS is added to the existing /* Like build_qualified_type, but TYPE_QUALS is added to the existing
...@@ -9202,6 +9340,9 @@ init_gnat_decl (void) ...@@ -9202,6 +9340,9 @@ init_gnat_decl (void)
{ {
/* Initialize the cache of annotated values. */ /* Initialize the cache of annotated values. */
annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512); annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
/* Initialize the association of dummy types with subprograms. */
dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
} }
/* Destroy data structures of the decl.c module. */ /* Destroy data structures of the decl.c module. */
...@@ -9212,6 +9353,10 @@ destroy_gnat_decl (void) ...@@ -9212,6 +9353,10 @@ destroy_gnat_decl (void)
/* Destroy the cache of annotated values. */ /* Destroy the cache of annotated values. */
annotate_value_cache->empty (); annotate_value_cache->empty ();
annotate_value_cache = NULL; annotate_value_cache = NULL;
/* Destroy the association of dummy types with subprograms. */
dummy_to_subprog_map->empty ();
dummy_to_subprog_map = NULL;
} }
#include "gt-ada-decl.h" #include "gt-ada-decl.h"
gcc/ada/gcc-interface/gigi.h
...@@ -49,6 +49,10 @@ extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity); ...@@ -49,6 +49,10 @@ extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
the GCC type corresponding to that entity. */ the GCC type corresponding to that entity. */
extern tree gnat_to_gnu_type (Entity_Id gnat_entity); extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
/* Update the GCC tree previously built for the profiles involving GNU_TYPE,
a dummy type which appears in profiles. */
extern void update_profiles_with (tree gnu_type);
/* Start a new statement group chained to the previous group. */ /* Start a new statement group chained to the previous group. */
extern void start_stmt_group (void); extern void start_stmt_group (void);
...@@ -109,11 +113,6 @@ extern void elaborate_entity (Entity_Id gnat_entity); ...@@ -109,11 +113,6 @@ extern void elaborate_entity (Entity_Id gnat_entity);
/* Get the unpadded version of a GNAT type. */ /* Get the unpadded version of a GNAT type. */
extern tree get_unpadded_type (Entity_Id gnat_entity); extern tree get_unpadded_type (Entity_Id gnat_entity);
/* 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. */
extern tree get_minimal_subprog_decl (Entity_Id gnat_entity);
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is /* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent. */ a C++ imported method or equivalent. */
extern bool is_cplusplus_method (Entity_Id gnat_entity); extern bool is_cplusplus_method (Entity_Id gnat_entity);
...@@ -631,20 +630,6 @@ extern void rest_of_record_type_compilation (tree record_type); ...@@ -631,20 +630,6 @@ extern void rest_of_record_type_compilation (tree record_type);
/* Append PARALLEL_TYPE on the chain of parallel types for TYPE. */ /* Append PARALLEL_TYPE on the chain of parallel types for TYPE. */
extern void add_parallel_type (tree type, tree parallel_type); extern void add_parallel_type (tree type, tree parallel_type);
/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
reference. RETURN_BY_INVISI_REF_P is true if the function returns by
invisible reference. */
extern tree create_subprog_type (tree return_type, tree param_decl_list,
tree cico_list, bool return_unconstrained_p,
bool return_by_direct_ref_p,
bool return_by_invisi_ref_p);
/* Return a copy of TYPE, but safe to modify in any way. */ /* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type (tree type); extern tree copy_type (tree type);
...@@ -717,10 +702,8 @@ extern tree create_field_decl (tree name, tree type, tree record_type, ...@@ -717,10 +702,8 @@ extern tree create_field_decl (tree name, tree type, tree record_type,
tree size, tree pos, int packed, tree size, tree pos, int packed,
int addressable); int addressable);
/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is /* Return a PARM_DECL node with NAME and TYPE. */
its type. READONLY is true if the parameter is readonly (either an In extern tree create_param_decl (tree name, tree type);
parameter or an address of a pass-by-ref parameter). */
extern tree create_param_decl (tree name, tree type, bool readonly);
/* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of /* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of
the decl. */ the decl. */
...@@ -733,8 +716,10 @@ extern tree create_label_decl (tree name, Node_Id gnat_node); ...@@ -733,8 +716,10 @@ extern tree create_label_decl (tree name, Node_Id gnat_node);
INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL. INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the PUBLIC_FLAG is true if this is for a reference to a public entity or for a
appropriate flags on the FUNCTION_DECL. definition to be made visible outside of the current compilation unit.
EXTERN_FLAG is true when processing an external subprogram declaration.
ARTIFICIAL_P is true if the subprogram was generated by the compiler. ARTIFICIAL_P is true if the subprogram was generated by the compiler.
...@@ -746,11 +731,14 @@ extern tree create_label_decl (tree name, Node_Id gnat_node); ...@@ -746,11 +731,14 @@ extern tree create_label_decl (tree name, Node_Id gnat_node);
extern tree create_subprog_decl (tree name, tree asm_name, tree type, extern tree create_subprog_decl (tree name, tree asm_name, tree type,
tree param_decl_list, tree param_decl_list,
enum inline_status_t inline_status, enum inline_status_t inline_status,
bool const_flag, bool public_flag, bool public_flag, bool extern_flag,
bool extern_flag, bool volatile_flag,
bool artificial_p, bool debug_info_p, bool artificial_p, bool debug_info_p,
struct attrib *attr_list, Node_Id gnat_node); struct attrib *attr_list, Node_Id gnat_node);
/* Given a subprogram declaration DECL and its TYPE, finish constructing the
subprogram declaration from TYPE. */
extern void finish_subprog_decl (tree decl, tree type);
/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or /* Process the attributes in ATTR_LIST for NODE, which is either a DECL or
a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be
changed. GNAT_NODE is used for the position of error messages. */ changed. GNAT_NODE is used for the position of error messages. */
......
gcc/ada/gcc-interface/misc.c
...@@ -718,7 +718,9 @@ gnat_get_alias_set (tree type) ...@@ -718,7 +718,9 @@ gnat_get_alias_set (tree type)
get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type))))); get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
/* If the type can alias any other types, return the alias set 0. */ /* If the type can alias any other types, return the alias set 0. */
else if (TYPE_P (type) && TYPE_UNIVERSAL_ALIASING_P (type)) else if (TYPE_P (type)
&& !TYPE_IS_DUMMY_P (type)
&& TYPE_UNIVERSAL_ALIASING_P (type))
return 0; return 0;
return -1; return -1;
...@@ -932,7 +934,7 @@ gnat_get_array_descr_info (const_tree const_type, ...@@ -932,7 +934,7 @@ gnat_get_array_descr_info (const_tree const_type,
and XUA types. */ and XUA types. */
if (TYPE_CONTEXT (first_dimen) if (TYPE_CONTEXT (first_dimen)
&& TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE && TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE
&& contains_placeholder_p (TYPE_MIN_VALUE (index_type)) && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type))
&& gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL) && gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{ {
info->dimen[i].lower_bound = NULL_TREE; info->dimen[i].lower_bound = NULL_TREE;
......
gcc/ada/gcc-interface/trans.c
...@@ -398,8 +398,8 @@ gigi (Node_Id gnat_root, ...@@ -398,8 +398,8 @@ gigi (Node_Id gnat_root,
malloc_decl malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE, = create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
ftype, ftype,
NULL_TREE, is_disabled, false, true, true, false, NULL_TREE, is_disabled, true, true, true, false,
true, false, NULL, Empty); NULL, Empty);
DECL_IS_MALLOC (malloc_decl) = 1; DECL_IS_MALLOC (malloc_decl) = 1;
/* free is a function declaration tree for a function to free memory. */ /* free is a function declaration tree for a function to free memory. */
...@@ -408,8 +408,8 @@ gigi (Node_Id gnat_root, ...@@ -408,8 +408,8 @@ gigi (Node_Id gnat_root,
build_function_type_list (void_type_node, build_function_type_list (void_type_node,
ptr_type_node, ptr_type_node,
NULL_TREE), NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, NULL_TREE, is_disabled, true, true, true, false,
true, false, NULL, Empty); NULL, Empty);
/* This is used for 64-bit multiplication with overflow checking. */ /* This is used for 64-bit multiplication with overflow checking. */
int64_type = gnat_type_for_size (64, 0); int64_type = gnat_type_for_size (64, 0);
...@@ -417,8 +417,8 @@ gigi (Node_Id gnat_root, ...@@ -417,8 +417,8 @@ gigi (Node_Id gnat_root,
= create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE, = create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
build_function_type_list (int64_type, int64_type, build_function_type_list (int64_type, int64_type,
int64_type, NULL_TREE), int64_type, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, NULL_TREE, is_disabled, true, true, true, false,
true, false, NULL, Empty); NULL, Empty);
/* Name of the _Parent field in tagged record types. */ /* Name of the _Parent field in tagged record types. */
parent_name_id = get_identifier (Get_Name_String (Name_uParent)); parent_name_id = get_identifier (Get_Name_String (Name_uParent));
...@@ -441,24 +441,21 @@ gigi (Node_Id gnat_root, ...@@ -441,24 +441,21 @@ gigi (Node_Id gnat_root,
= create_subprog_decl = create_subprog_decl
(get_identifier ("system__soft_links__get_jmpbuf_address_soft"), (get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE), NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
set_jmpbuf_decl set_jmpbuf_decl
= create_subprog_decl = create_subprog_decl
(get_identifier ("system__soft_links__set_jmpbuf_address_soft"), (get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
NULL_TREE), NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
get_excptr_decl get_excptr_decl
= create_subprog_decl = create_subprog_decl
(get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE, (get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
build_function_type_list (build_pointer_type (except_type_node), build_function_type_list (build_pointer_type (except_type_node),
NULL_TREE), NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
not_handled_by_others_decl = get_identifier ("not_handled_by_others"); not_handled_by_others_decl = get_identifier ("not_handled_by_others");
for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t)) for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
...@@ -476,8 +473,7 @@ gigi (Node_Id gnat_root, ...@@ -476,8 +473,7 @@ gigi (Node_Id gnat_root,
(get_identifier ("__builtin_setjmp"), NULL_TREE, (get_identifier ("__builtin_setjmp"), NULL_TREE,
build_function_type_list (integer_type_node, jmpbuf_ptr_type, build_function_type_list (integer_type_node, jmpbuf_ptr_type,
NULL_TREE), NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL; DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP; DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
...@@ -487,35 +483,26 @@ gigi (Node_Id gnat_root, ...@@ -487,35 +483,26 @@ gigi (Node_Id gnat_root,
= create_subprog_decl = create_subprog_decl
(get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE, (get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE), build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL; DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF; DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
/* Indicate that it never returns. */ /* Indicate that it never returns. */
ftype = build_function_type_list (void_type_node,
build_pointer_type (except_type_node),
NULL_TREE);
ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
raise_nodefer_decl raise_nodefer_decl
= create_subprog_decl = create_subprog_decl
(get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
build_function_type_list (void_type_node, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
build_pointer_type (except_type_node),
NULL_TREE),
NULL_TREE, is_disabled, false, true, true, true, true, false,
NULL, Empty);
/* Indicate that these never return. */
reraise_zcx_decl
= create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
ftype, NULL_TREE,
is_disabled, false, true, true, true, true, false,
NULL, Empty);
set_exception_parameter_decl set_exception_parameter_decl
= create_subprog_decl = create_subprog_decl
(get_identifier ("__gnat_set_exception_parameter"), NULL_TREE, (get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
build_function_type_list (void_type_node, ptr_type_node, ptr_type_node, build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
NULL_TREE), NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
/* Hooks to call when entering/leaving an exception handler. */ /* Hooks to call when entering/leaving an exception handler. */
ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE); ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
...@@ -523,20 +510,24 @@ gigi (Node_Id gnat_root, ...@@ -523,20 +510,24 @@ gigi (Node_Id gnat_root,
begin_handler_decl begin_handler_decl
= create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE, = create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
ftype, NULL_TREE, ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
end_handler_decl end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE, = create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
ftype, NULL_TREE, ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
unhandled_except_decl unhandled_except_decl
= create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"), = create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
NULL_TREE, ftype, NULL_TREE, NULL_TREE, ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false, is_disabled, true, true, true, false, NULL, Empty);
NULL, Empty);
/* Indicate that it never returns. */
ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
reraise_zcx_decl
= create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
ftype, NULL_TREE,
is_disabled, true, true, true, false, NULL, Empty);
/* Dummy objects to materialize "others" and "all others" in the exception /* Dummy objects to materialize "others" and "all others" in the exception
tables. These are exported by a-exexpr-gcc.adb, so see this unit for tables. These are exported by a-exexpr-gcc.adb, so see this unit for
...@@ -567,14 +558,15 @@ gigi (Node_Id gnat_root, ...@@ -567,14 +558,15 @@ gigi (Node_Id gnat_root,
this procedure will never be called in this mode. */ this procedure will never be called in this mode. */
if (No_Exception_Handlers_Set ()) if (No_Exception_Handlers_Set ())
{ {
/* Indicate that it never returns. */
ftype = build_function_type_list (void_type_node,
build_pointer_type (char_type_node),
integer_type_node, NULL_TREE);
ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
tree decl tree decl
= create_subprog_decl = create_subprog_decl
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE, (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
build_function_type_list (void_type_node, NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
build_pointer_type (char_type_node),
integer_type_node, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, true, true, false,
NULL, Empty);
for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++) for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
gnat_raise_decls[i] = decl; gnat_raise_decls[i] = decl;
} }
...@@ -736,10 +728,10 @@ build_raise_check (int check, enum exception_info_kind kind) ...@@ -736,10 +728,10 @@ build_raise_check (int check, enum exception_info_kind kind)
} }
/* Indicate that it never returns. */ /* Indicate that it never returns. */
ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
result result
= create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
ftype, NULL_TREE, NULL_TREE, is_disabled, true, true, true, false,
is_disabled, false, true, true, true, true, false,
NULL, Empty); NULL, Empty);
return result; return result;
...@@ -1020,15 +1012,15 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) ...@@ -1020,15 +1012,15 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
address clause when the parent doesn't require an lvalue. */ address clause when the parent doesn't require an lvalue. */
bool use_constant_initializer = false; bool use_constant_initializer = false;
/* If the Etype of this node does not equal the Etype of the Entity, /* If the Etype of this node is not the same as that of the Entity, then
something is wrong with the entity map, probably in generic something went wrong, probably in generic instantiation. However, this
instantiation. However, this does not apply to types. Since we sometime does not apply to types. Since we sometime have strange Ekind's, just
have strange Ekind's, just do this test for objects. Also, if the Etype of do this test for objects. Moreover, if the Etype of the Entity is private
the Entity is private, the Etype of the N_Identifier is allowed to be the or incomplete coming from a limited context, the Etype of the N_Identifier
full type and also we consider a packed array type to be the same as the is allowed to be the full/non-limited view and we also consider a packed
original type. Similarly, a class-wide type is equivalent to a subtype of array type to be the same as the original type. Similarly, a CW type is
itself. Finally, if the types are Itypes, one may be a copy of the other, equivalent to a subtype of itself. Finally, if the types are Itypes, one
which is also legal. */ may be a copy of the other, which is also legal. */
gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier
|| Nkind (gnat_node) == N_Defining_Operator_Symbol) || Nkind (gnat_node) == N_Defining_Operator_Symbol)
? gnat_node : Entity (gnat_node)); ? gnat_node : Entity (gnat_node));
...@@ -1046,6 +1038,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p) ...@@ -1046,6 +1038,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
&& (Etype (gnat_node) && (Etype (gnat_node)
== Packed_Array_Impl_Type == Packed_Array_Impl_Type
(Full_View (gnat_temp_type)))))) (Full_View (gnat_temp_type))))))
|| (IN (Ekind (gnat_temp_type), Incomplete_Kind)
&& From_Limited_With (gnat_temp_type)
&& Present (Non_Limited_View (gnat_temp_type))
&& Etype (gnat_node) == Non_Limited_View (gnat_temp_type))
|| (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type)) || (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
|| !(Ekind (gnat_temp) == E_Variable || !(Ekind (gnat_temp) == E_Variable
|| Ekind (gnat_temp) == E_Component || Ekind (gnat_temp) == E_Component
...@@ -1569,25 +1565,11 @@ static tree ...@@ -1569,25 +1565,11 @@ static tree
Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute) Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
{ {
const Node_Id gnat_prefix = Prefix (gnat_node); const Node_Id gnat_prefix = Prefix (gnat_node);
tree gnu_prefix, gnu_type, gnu_expr; tree gnu_prefix = gnat_to_gnu (gnat_prefix);
tree gnu_result_type, gnu_result = error_mark_node; tree gnu_type = TREE_TYPE (gnu_prefix);
tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
bool prefix_unused = false; bool prefix_unused = false;
/* ??? If this is an access attribute for a public subprogram to be used in
a dispatch table, do not translate its type as it's useless in this case
and the parameter types might be incomplete types coming from a limited
context in Ada 2012 (AI05-0151). */
if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
&& Is_Dispatch_Table_Entity (Etype (gnat_node))
&& Nkind (gnat_prefix) == N_Identifier
&& Is_Subprogram (Entity (gnat_prefix))
&& Is_Public (Entity (gnat_prefix))
&& !present_gnu_tree (Entity (gnat_prefix)))
gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
else
gnu_prefix = gnat_to_gnu (gnat_prefix);
gnu_type = TREE_TYPE (gnu_prefix);
/* If the input is a NULL_EXPR, make a new one. */ /* If the input is a NULL_EXPR, make a new one. */
if (TREE_CODE (gnu_prefix) == NULL_EXPR) if (TREE_CODE (gnu_prefix) == NULL_EXPR)
{ {
...@@ -5340,8 +5322,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) ...@@ -5340,8 +5322,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
= create_subprog_decl = create_subprog_decl
(create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"), (create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, NULL_TREE, void_ftype, NULL_TREE,
is_disabled, false, true, false, false, true, true, is_disabled, true, false, true, true, NULL, gnat_unit);
NULL, gnat_unit);
struct elab_info *info; struct elab_info *info;
vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl); vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
...@@ -6340,8 +6321,7 @@ gnat_to_gnu (Node_Id gnat_node) ...@@ -6340,8 +6321,7 @@ gnat_to_gnu (Node_Id gnat_node)
(Entity (Prefix (gnat_node)), (Entity (Prefix (gnat_node)),
attr == Attr_Elab_Body ? "elabb" : "elabs"), attr == Attr_Elab_Body ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, is_disabled, NULL_TREE, void_ftype, NULL_TREE, is_disabled,
false, true, true, false, true, true, true, true, true, true, NULL, gnat_node);
NULL, gnat_node);
gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr); gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
} }
...@@ -8554,14 +8534,11 @@ process_freeze_entity (Node_Id gnat_node) ...@@ -8554,14 +8534,11 @@ process_freeze_entity (Node_Id gnat_node)
if (kind == E_Class_Wide_Type) if (kind == E_Class_Wide_Type)
return; return;
/* Check for an old definition. This freeze node might be for an Itype. */ /* Check for an old definition if this isn't an object with address clause,
since the saved GCC tree is the address expression in that case. */
gnu_old gnu_old
= present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE; = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
? get_gnu_tree (gnat_entity) : NULL_TREE;
/* If this entity has an address representation clause, GNU_OLD is the
address, so discard it here. */
if (Present (Address_Clause (gnat_entity)))
gnu_old = NULL_TREE;
/* Don't do anything for subprograms that may have been elaborated before /* Don't do anything for subprograms that may have been elaborated before
their freeze nodes. This can happen, for example, because of an inner their freeze nodes. This can happen, for example, because of an inner
...@@ -8671,6 +8648,8 @@ process_freeze_entity (Node_Id gnat_node) ...@@ -8671,6 +8648,8 @@ process_freeze_entity (Node_Id gnat_node)
{ {
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)), update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
TREE_TYPE (gnu_new)); TREE_TYPE (gnu_new));
if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
update_profiles_with (TREE_TYPE (gnu_old));
if (DECL_TAFT_TYPE_P (gnu_old)) if (DECL_TAFT_TYPE_P (gnu_old))
used_types_insert (TREE_TYPE (gnu_new)); used_types_insert (TREE_TYPE (gnu_new));
} }
......
gcc/ada/gcc-interface/utils.c
...@@ -428,6 +428,7 @@ build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type) ...@@ -428,6 +428,7 @@ build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
TYPE_DUMMY_P (gnu_object_type) = 1; TYPE_DUMMY_P (gnu_object_type) = 1;
TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type; TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
TYPE_REFERENCE_TO (gnu_desig_type) = gnu_fat_type;
TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type; TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
} }
...@@ -2221,47 +2222,6 @@ split_plus (tree in, tree *pvar) ...@@ -2221,47 +2222,6 @@ split_plus (tree in, tree *pvar)
return bitsize_zero_node; return bitsize_zero_node;
} }
/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
reference. RETURN_BY_INVISI_REF_P is true if the function returns by
invisible reference. */
tree
create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
bool return_unconstrained_p, bool return_by_direct_ref_p,
bool return_by_invisi_ref_p)
{
/* A list of the data type nodes of the subprogram formal parameters.
This list is generated by traversing the input list of PARM_DECL
nodes. */
vec<tree, va_gc> *param_type_list = NULL;
tree t, type;
for (t = param_decl_list; t; t = DECL_CHAIN (t))
vec_safe_push (param_type_list, TREE_TYPE (t));
type = build_function_type_vec (return_type, param_type_list);
/* TYPE may have been shared since GCC hashes types. If it has a different
CICO_LIST, make a copy. Likewise for the various flags. */
if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p,
return_by_direct_ref_p, return_by_invisi_ref_p))
{
type = copy_type (type);
TYPE_CI_CO_LIST (type) = cico_list;
TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p;
TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p;
TREE_ADDRESSABLE (type) = return_by_invisi_ref_p;
}
return type;
}
/* Return a copy of TYPE but safe to modify in any way. */ /* Return a copy of TYPE but safe to modify in any way. */
tree tree
...@@ -2742,12 +2702,10 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos, ...@@ -2742,12 +2702,10 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
return field_decl; return field_decl;
} }
/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is /* Return a PARM_DECL node with NAME and TYPE. */
its type. READONLY is true if the parameter is readonly (either an In
parameter or an address of a pass-by-ref parameter). */
tree tree
create_param_decl (tree name, tree type, bool readonly) create_param_decl (tree name, tree type)
{ {
tree param_decl = build_decl (input_location, PARM_DECL, name, type); tree param_decl = build_decl (input_location, PARM_DECL, name, type);
...@@ -2775,7 +2733,6 @@ create_param_decl (tree name, tree type, bool readonly) ...@@ -2775,7 +2733,6 @@ create_param_decl (tree name, tree type, bool readonly)
} }
DECL_ARG_TYPE (param_decl) = type; DECL_ARG_TYPE (param_decl) = type;
TREE_READONLY (param_decl) = readonly;
return param_decl; return param_decl;
} }
...@@ -3151,8 +3108,10 @@ create_label_decl (tree name, Node_Id gnat_node) ...@@ -3151,8 +3108,10 @@ create_label_decl (tree name, Node_Id gnat_node)
INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL. INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the PUBLIC_FLAG is true if this is for a reference to a public entity or for a
appropriate flags on the FUNCTION_DECL. definition to be made visible outside of the current compilation unit.
EXTERN_FLAG is true when processing an external subprogram declaration.
ARTIFICIAL_P is true if the subprogram was generated by the compiler. ARTIFICIAL_P is true if the subprogram was generated by the compiler.
...@@ -3164,18 +3123,20 @@ create_label_decl (tree name, Node_Id gnat_node) ...@@ -3164,18 +3123,20 @@ create_label_decl (tree name, Node_Id gnat_node)
tree tree
create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list, create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
enum inline_status_t inline_status, bool const_flag, enum inline_status_t inline_status, bool public_flag,
bool public_flag, bool extern_flag, bool volatile_flag, bool extern_flag, bool artificial_p, bool debug_info_p,
bool artificial_p, bool debug_info_p,
struct attrib *attr_list, Node_Id gnat_node) struct attrib *attr_list, Node_Id gnat_node)
{ {
tree subprog_decl = build_decl (input_location, FUNCTION_DECL, name, type); tree subprog_decl = build_decl (input_location, FUNCTION_DECL, name, type);
tree result_decl
= build_decl (input_location, RESULT_DECL, NULL_TREE, TREE_TYPE (type));
DECL_ARGUMENTS (subprog_decl) = param_decl_list; DECL_ARGUMENTS (subprog_decl) = param_decl_list;
finish_subprog_decl (subprog_decl, type);
DECL_ARTIFICIAL (subprog_decl) = artificial_p; DECL_ARTIFICIAL (subprog_decl) = artificial_p;
DECL_EXTERNAL (subprog_decl) = extern_flag; DECL_EXTERNAL (subprog_decl) = extern_flag;
TREE_PUBLIC (subprog_decl) = public_flag;
if (!debug_info_p)
DECL_IGNORED_P (subprog_decl) = 1;
switch (inline_status) switch (inline_status)
{ {
...@@ -3204,20 +3165,6 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list, ...@@ -3204,20 +3165,6 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
gcc_unreachable (); gcc_unreachable ();
} }
if (!debug_info_p)
DECL_IGNORED_P (subprog_decl) = 1;
TREE_READONLY (subprog_decl) = TYPE_READONLY (type) | const_flag;
TREE_PUBLIC (subprog_decl) = public_flag;
TREE_SIDE_EFFECTS (subprog_decl)
= TREE_THIS_VOLATILE (subprog_decl)
= TYPE_VOLATILE (type) | volatile_flag;
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
DECL_RESULT (subprog_decl) = result_decl;
process_attributes (&subprog_decl, &attr_list, true, gnat_node); process_attributes (&subprog_decl, &attr_list, true, gnat_node);
/* Add this decl to the current binding level. */ /* Add this decl to the current binding level. */
...@@ -3247,6 +3194,25 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list, ...@@ -3247,6 +3194,25 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
return subprog_decl; return subprog_decl;
} }
/* Given a subprogram declaration DECL and its TYPE, finish constructing the
subprogram declaration from TYPE. */
void
finish_subprog_decl (tree decl, tree type)
{
tree result_decl
= build_decl (DECL_SOURCE_LOCATION (decl), RESULT_DECL, NULL_TREE,
TREE_TYPE (type));
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
DECL_RESULT (decl) = result_decl;
TREE_READONLY (decl) = TYPE_READONLY (type);
TREE_SIDE_EFFECTS (decl) = TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type);
}
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram /* Set up the framework for generating code for SUBPROG_DECL, a subprogram
body. This routine needs to be invoked before processing the declarations body. This routine needs to be invoked before processing the declarations
appearing in the subprogram. */ appearing in the subprogram. */
...@@ -3992,6 +3958,7 @@ update_pointer_to (tree old_type, tree new_type) ...@@ -3992,6 +3958,7 @@ update_pointer_to (tree old_type, tree new_type)
TYPE_OBJECT_RECORD_TYPE (new_type)); TYPE_OBJECT_RECORD_TYPE (new_type));
TYPE_POINTER_TO (old_type) = NULL_TREE; TYPE_POINTER_TO (old_type) = NULL_TREE;
TYPE_REFERENCE_TO (old_type) = NULL_TREE;
} }
} }
......
gcc/ada/sem_aux.adb
...@@ -933,8 +933,12 @@ package body Sem_Aux is ...@@ -933,8 +933,12 @@ package body Sem_Aux is
declare declare
Ftyp : constant Entity_Id := Full_View (Btype); Ftyp : constant Entity_Id := Full_View (Btype);
begin begin
-- Return true for a tagged incomplete type built as a shadow
-- entity in Build_Limited_Views. It can appear in the profile
-- of a thunk and the back end needs to know how it is passed.
if No (Ftyp) then if No (Ftyp) then
return False; return Is_Tagged_Type (Btype);
else else
return Is_By_Reference_Type (Ftyp); return Is_By_Reference_Type (Ftyp);
end if; end if;
......
gcc/ada/sem_ch6.adb
...@@ -2148,6 +2148,7 @@ package body Sem_Ch6 is ...@@ -2148,6 +2148,7 @@ package body Sem_Ch6 is
Body_Spec : Node_Id := Specification (N); Body_Spec : Node_Id := Specification (N);
Body_Id : Entity_Id := Defining_Entity (Body_Spec); Body_Id : Entity_Id := Defining_Entity (Body_Spec);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id); Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Exch_Views : Elist_Id := No_Elist;
Conformant : Boolean; Conformant : Boolean;
HSS : Node_Id; HSS : Node_Id;
Prot_Typ : Entity_Id := Empty; Prot_Typ : Entity_Id := Empty;
...@@ -2214,16 +2215,20 @@ package body Sem_Ch6 is ...@@ -2214,16 +2215,20 @@ package body Sem_Ch6 is
-- mechanism is used to find the corresponding spec of the primitive -- mechanism is used to find the corresponding spec of the primitive
-- body. -- body.
procedure Exchange_Limited_Views (Subp_Id : Entity_Id); function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id;
-- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains -- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
-- incomplete types coming from a limited context and swap their limited -- incomplete types coming from a limited context and replace their
-- views with the non-limited ones. -- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
function Is_Private_Concurrent_Primitive function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean; (Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent -- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view. -- type that implements an interface and has a private view.
procedure Restore_Limited_Views (Restore_List : Elist_Id);
-- Undo the transformation done by Exchange_Limited_Views.
procedure Set_Trivial_Subprogram (N : Node_Id); procedure Set_Trivial_Subprogram (N : Node_Id);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the -- Sets the Is_Trivial_Subprogram flag in both spec and body of the
-- subprogram whose body is being analyzed. N is the statement node -- subprogram whose body is being analyzed. N is the statement node
...@@ -2870,7 +2875,9 @@ package body Sem_Ch6 is ...@@ -2870,7 +2875,9 @@ package body Sem_Ch6 is
-- Exchange_Limited_Views -- -- Exchange_Limited_Views --
---------------------------- ----------------------------
procedure Exchange_Limited_Views (Subp_Id : Entity_Id) is function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id is
Result : Elist_Id := No_Elist;
procedure Detect_And_Exchange (Id : Entity_Id); procedure Detect_And_Exchange (Id : Entity_Id);
-- Determine whether Id's type denotes an incomplete type associated -- Determine whether Id's type denotes an incomplete type associated
-- with a limited with clause and exchange the limited view with the -- with a limited with clause and exchange the limited view with the
...@@ -2890,6 +2897,12 @@ package body Sem_Ch6 is ...@@ -2890,6 +2897,12 @@ package body Sem_Ch6 is
and then Has_Non_Limited_View (Typ) and then Has_Non_Limited_View (Typ)
and then not From_Limited_With (Scope (Typ)) and then not From_Limited_With (Scope (Typ))
then then
if No (Result) then
Result := New_Elmt_List;
end if;
Prepend_Elmt (Typ, Result);
Prepend_Elmt (Id, Result);
Set_Etype (Id, Non_Limited_View (Typ)); Set_Etype (Id, Non_Limited_View (Typ));
end if; end if;
end Detect_And_Exchange; end Detect_And_Exchange;
...@@ -2902,13 +2915,13 @@ package body Sem_Ch6 is ...@@ -2902,13 +2915,13 @@ package body Sem_Ch6 is
begin begin
if No (Subp_Id) then if No (Subp_Id) then
return; return No_Elist;
-- Do not process subprogram bodies as they already use the non- -- Do not process subprogram bodies as they already use the non-
-- limited view of types. -- limited view of types.
elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then
return; return No_Elist;
end if; end if;
-- Examine all formals and swap views when applicable -- Examine all formals and swap views when applicable
...@@ -2925,6 +2938,8 @@ package body Sem_Ch6 is ...@@ -2925,6 +2938,8 @@ package body Sem_Ch6 is
if Ekind (Subp_Id) = E_Function then if Ekind (Subp_Id) = E_Function then
Detect_And_Exchange (Subp_Id); Detect_And_Exchange (Subp_Id);
end if; end if;
return Result;
end Exchange_Limited_Views; end Exchange_Limited_Views;
------------------------------------- -------------------------------------
...@@ -2960,6 +2975,23 @@ package body Sem_Ch6 is ...@@ -2960,6 +2975,23 @@ package body Sem_Ch6 is
return False; return False;
end Is_Private_Concurrent_Primitive; end Is_Private_Concurrent_Primitive;
---------------------------
-- Restore_Limited_Views --
---------------------------
procedure Restore_Limited_Views (Restore_List : Elist_Id) is
Elmt : Elmt_Id := First_Elmt (Restore_List);
Id : Entity_Id;
begin
while Present (Elmt) loop
Id := Node (Elmt);
Next_Elmt (Elmt);
Set_Etype (Id, Node (Elmt));
Next_Elmt (Elmt);
end loop;
end Restore_Limited_Views;
---------------------------- ----------------------------
-- Set_Trivial_Subprogram -- -- Set_Trivial_Subprogram --
---------------------------- ----------------------------
...@@ -3887,7 +3919,7 @@ package body Sem_Ch6 is ...@@ -3887,7 +3919,7 @@ package body Sem_Ch6 is
-- spec, swap any limited views with their non-limited counterpart. -- spec, swap any limited views with their non-limited counterpart.
if Ada_Version >= Ada_2012 then if Ada_Version >= Ada_2012 then
Exchange_Limited_Views (Spec_Id); Exch_Views := Exchange_Limited_Views (Spec_Id);
end if; end if;
-- Analyze any aspect specifications that appear on the subprogram body -- Analyze any aspect specifications that appear on the subprogram body
...@@ -4152,6 +4184,13 @@ package body Sem_Ch6 is ...@@ -4152,6 +4184,13 @@ package body Sem_Ch6 is
end if; end if;
end; end;
-- Restore the limited views in the spec, if any, to let the back end
-- process it without running into circularities.
if Exch_Views /= No_Elist then
Restore_Limited_Views (Exch_Views);
end if;
Ghost_Mode := Save_Ghost_Mode; Ghost_Mode := Save_Ghost_Mode;
end Analyze_Subprogram_Body_Helper; end Analyze_Subprogram_Body_Helper;
...@@ -5269,10 +5308,7 @@ package body Sem_Ch6 is ...@@ -5269,10 +5308,7 @@ package body Sem_Ch6 is
procedure Possible_Freeze (T : Entity_Id); procedure Possible_Freeze (T : Entity_Id);
-- T is the type of either a formal parameter or of the return type. -- T is the type of either a formal parameter or of the return type.
-- If T is not yet frozen and needs a delayed freeze, then the -- If T is not yet frozen and needs a delayed freeze, then the
-- subprogram itself must be delayed. If T is the limited view of an -- subprogram itself must be delayed.
-- incomplete type (or of a CW type thereof) the subprogram must be
-- frozen as well, because T may depend on local types that have not
-- been frozen yet.
--------------------- ---------------------
-- Possible_Freeze -- -- Possible_Freeze --
...@@ -5288,20 +5324,6 @@ package body Sem_Ch6 is ...@@ -5288,20 +5324,6 @@ package body Sem_Ch6 is
and then not Is_Frozen (Designated_Type (T)) and then not Is_Frozen (Designated_Type (T))
then then
Set_Has_Delayed_Freeze (Designator); Set_Has_Delayed_Freeze (Designator);
elsif (Ekind (T) = E_Incomplete_Type
or else Ekind (T) = E_Class_Wide_Type)
and then From_Limited_With (T)
then
Set_Has_Delayed_Freeze (Designator);
-- AI05-0151: In Ada 2012, Incomplete types can appear in the profile
-- of a subprogram or entry declaration.
elsif Ekind (T) = E_Incomplete_Type
and then Ada_Version >= Ada_2012
then
Set_Has_Delayed_Freeze (Designator);
end if; end if;
end Possible_Freeze; end Possible_Freeze;
...@@ -10451,9 +10473,7 @@ package body Sem_Ch6 is ...@@ -10451,9 +10473,7 @@ package body Sem_Ch6 is
-- it is still the case that untagged incomplete types cannot -- it is still the case that untagged incomplete types cannot
-- be Taft-amendment types and must be completed in private -- be Taft-amendment types and must be completed in private
-- part, so the subprogram must appear in the list of private -- part, so the subprogram must appear in the list of private
-- dependents of the type. If the type is class-wide, it is -- dependents of the type.
-- not a primitive, but the freezing of the subprogram must
-- also be delayed to force the creation of a freeze node.
if Is_Tagged_Type (Formal_Type) if Is_Tagged_Type (Formal_Type)
or else (Ada_Version >= Ada_2012 or else (Ada_Version >= Ada_2012
...@@ -10462,19 +10482,14 @@ package body Sem_Ch6 is ...@@ -10462,19 +10482,14 @@ package body Sem_Ch6 is
then then
if Ekind (Scope (Current_Scope)) = E_Package if Ekind (Scope (Current_Scope)) = E_Package
and then not Is_Generic_Type (Formal_Type) and then not Is_Generic_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type)
then then
if not Nkind_In if not Nkind_In
(Parent (T), N_Access_Function_Definition, (Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition) N_Access_Procedure_Definition)
then then
-- A limited view has no private dependents
if not Is_Class_Wide_Type (Formal_Type)
and then not From_Limited_With (Formal_Type)
then
Append_Elmt (Current_Scope, Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type))); Private_Dependents (Base_Type (Formal_Type)));
end if;
-- Freezing is delayed to ensure that Register_Prim -- Freezing is delayed to ensure that Register_Prim
-- will get called for this operation, which is needed -- will get called for this operation, which is needed
...@@ -10728,19 +10743,6 @@ package body Sem_Ch6 is ...@@ -10728,19 +10743,6 @@ package body Sem_Ch6 is
if Nkind (Related_Nod) = N_Function_Specification then if Nkind (Related_Nod) = N_Function_Specification then
Analyze_Return_Type (Related_Nod); Analyze_Return_Type (Related_Nod);
-- If return type is class-wide, subprogram freezing may be
-- delayed as well, unless the declaration is a compilation unit
-- in which case the freeze node would appear too late.
if Is_Class_Wide_Type (Etype (Current_Scope))
and then not Is_Thunk (Current_Scope)
and then not Is_Compilation_Unit (Current_Scope)
and then Nkind (Unit_Declaration_Node (Current_Scope)) =
N_Subprogram_Declaration
then
Set_Has_Delayed_Freeze (Current_Scope);
end if;
end if; end if;
-- Now set the kind (mode) of each formal -- Now set the kind (mode) of each formal
......
gcc/ada/types.h
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Header File * * C Header File *
* * * *
* Copyright (C) 1992-2014, Free Software Foundation, Inc. * * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* * * *
* GNAT is free software; you can redistribute it and/or modify it under * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -351,9 +351,6 @@ typedef Int Mechanism_Type; ...@@ -351,9 +351,6 @@ typedef Int Mechanism_Type;
#define By_Short_Descriptor_NCA (-18) #define By_Short_Descriptor_NCA (-18)
#define By_Short_Descriptor_Last (-18) #define By_Short_Descriptor_Last (-18)
/* Internal to Gigi. */
#define By_Copy_Return (-128)
/* Definitions of Reason codes for Raise_xxx_Error nodes */ /* Definitions of Reason codes for Raise_xxx_Error nodes */
#define CE_Access_Check_Failed 0 #define CE_Access_Check_Failed 0
#define CE_Access_Parameter_Is_Null 1 #define CE_Access_Parameter_Is_Null 1
......
gcc/testsuite/ChangeLog
2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/limited_with4.ad[sb]: New test.
* gnat.dg/limited_with4_pkg.ads: New helper.
2016-04-27 H.J. Lu <hongjiu.lu@intel.com> 2016-04-27 H.J. Lu <hongjiu.lu@intel.com>
PR target/70155 PR target/70155
......
gcc/testsuite/gnat.dg/limited_with4.adb 0 → 100644
-- { dg-do compile }
with Limited_With4_Pkg;
package body Limited_With4 is
procedure Proc1 (A : Limited_With4_Pkg.Rec12 ; I : Integer) is
begin
if A.R.I /= I then
raise Program_Error;
end if;
end;
function Func1 (I : Integer) return Limited_With4_Pkg.Rec12 is
begin
return (I => I, R => (I => I));
end;
procedure Proc2 (A : Limited_With4_Pkg.Rec22 ; I : Integer) is
begin
if A.R.I /= I then
raise Program_Error;
end if;
end;
function Func2 (I : Integer) return Limited_With4_Pkg.Rec22 is
begin
return (I => I, R => (I => I));
end;
procedure Proc3 (A : Limited_With4_Pkg.Rec12 ; B : Limited_With4_Pkg.Rec22) is
begin
if A.R.I /= B.R.I then
raise Program_Error;
end if;
end;
function Func3 (A : Limited_With4_Pkg.Rec12) return Limited_With4_Pkg.Rec22 is
begin
return (I => A.R.I, R => (I => A.R.I));
end;
end Limited_With4;
gcc/testsuite/gnat.dg/limited_with4.ads 0 → 100644
limited with Limited_With4_Pkg;
package Limited_With4 is
type Ptr1 is access procedure (A : Limited_With4_Pkg.Rec12; I : Integer);
type Ptr2 is access procedure (A : Limited_With4_Pkg.Rec22; I : Integer);
type Rec1 is record
I : Integer;
end record;
procedure Proc1 (A : Limited_With4_Pkg.Rec12 ; I : Integer);
function Func1 (I : Integer) return Limited_With4_Pkg.Rec12;
procedure Proc2 (A : Limited_With4_Pkg.Rec22 ; I : Integer);
function Func2 (I : Integer) return Limited_With4_Pkg.Rec22;
type Rec2 is record
I : Integer;
end record;
procedure Proc3 (A : Limited_With4_Pkg.Rec12 ; B : Limited_With4_Pkg.Rec22);
function Func3 (A : Limited_With4_Pkg.Rec12) return Limited_With4_Pkg.Rec22;
end Limited_With4;
gcc/testsuite/gnat.dg/limited_with4_pkg.ads 0 → 100644
with Limited_With4;
package Limited_With4_Pkg is
P1 : Limited_With4.Ptr1 := Limited_With4.Proc1'Access;
P2 : Limited_With4.Ptr2 := Limited_With4.Proc2'Access;
type Rec12 is record
I : Integer;
R : Limited_With4.Rec1;
end record;
type Rec22 is record
I : Integer;
R : Limited_With4.Rec2;
end record;
end Limited_With4_Pkg;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment