OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Eric Botcazou 2016-04-27 18:08:39 +00:00 committed by Eric Botcazou
parent e306693a82
commit 1e55d29a0c
14 changed files with 1170 additions and 899 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

88
gcc/ada/ChangeLog
View File

@ -1,3 +1,91 @@
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>
* aa_util.adb, aa_util.ads: Removed, no longer used.

11
gcc/ada/gcc-interface/ada-tree.h
View File

@ -180,12 +180,11 @@ do { \
#define TYPE_IS_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)
/* 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)))
/* True for a dummy type if TYPE appears in a profile. */
#define TYPE_DUMMY_IN_PROFILE_P(NODE) TYPE_LANG_FLAG_6 (NODE)
/* True for types that implement a packed array and for original packed array
types. */
@ -196,6 +195,10 @@ do { \
/* True for types that can hold a debug type. */
#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
template and the object.

1469
gcc/ada/gcc-interface/decl.c
View File

File diff suppressed because it is too large Load Diff

42
gcc/ada/gcc-interface/gigi.h
View File

@ -49,6 +49,10 @@ extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
the GCC type corresponding to that 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. */
extern void start_stmt_group (void);
@ -109,11 +113,6 @@ extern void elaborate_entity (Entity_Id gnat_entity);
/* Get the unpadded version of a GNAT type. */
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
a C++ imported method or equivalent. */
extern bool is_cplusplus_method (Entity_Id gnat_entity);
@ -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. */
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. */
extern tree copy_type (tree type);
@ -717,10 +702,8 @@ extern tree create_field_decl (tree name, tree type, tree record_type,
tree size, tree pos, int packed,
int addressable);
/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is
its type. READONLY is true if the parameter is readonly (either an In
parameter or an address of a pass-by-ref parameter). */
extern tree create_param_decl (tree name, tree type, bool readonly);
/* Return a PARM_DECL node with NAME and TYPE. */
extern tree create_param_decl (tree name, tree type);
/* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of
the decl. */
@ -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.
CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the
appropriate flags on the FUNCTION_DECL.
PUBLIC_FLAG is true if this is for a reference to a public entity or for a
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.
@ -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,
tree param_decl_list,
enum inline_status_t inline_status,
bool const_flag, bool public_flag,
bool extern_flag, bool volatile_flag,
bool public_flag, bool extern_flag,
bool artificial_p, bool debug_info_p,
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
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. */

6
gcc/ada/gcc-interface/misc.c
View File

@ -718,7 +718,9 @@ gnat_get_alias_set (tree 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. */
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 -1;
@ -932,7 +934,7 @@ gnat_get_array_descr_info (const_tree const_type,
and XUA types. */
if (TYPE_CONTEXT (first_dimen)
&& 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)
{
info->dimen[i].lower_bound = NULL_TREE;

145
gcc/ada/gcc-interface/trans.c
View File

@ -398,8 +398,8 @@ gigi (Node_Id gnat_root,
malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
ftype,
NULL_TREE, is_disabled, false, true, true, false,
true, false, NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false,
NULL, Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
/* free is a function declaration tree for a function to free memory. */
@ -408,8 +408,8 @@ gigi (Node_Id gnat_root,
build_function_type_list (void_type_node,
ptr_type_node,
NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false,
true, false, NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false,
NULL, Empty);
/* This is used for 64-bit multiplication with overflow checking. */
int64_type = gnat_type_for_size (64, 0);
@ -417,8 +417,8 @@ gigi (Node_Id gnat_root,
= create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
build_function_type_list (int64_type, int64_type,
int64_type, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false,
true, false, NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false,
NULL, Empty);
/* Name of the _Parent field in tagged record types. */
parent_name_id = get_identifier (Get_Name_String (Name_uParent));
@ -441,24 +441,21 @@ gigi (Node_Id gnat_root,
= create_subprog_decl
(get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false,
NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
set_jmpbuf_decl
= create_subprog_decl
(get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
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, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
get_excptr_decl
= create_subprog_decl
(get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
build_function_type_list (build_pointer_type (except_type_node),
NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false,
NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
not_handled_by_others_decl = get_identifier ("not_handled_by_others");
for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
@ -476,8 +473,7 @@ gigi (Node_Id gnat_root,
(get_identifier ("__builtin_setjmp"), NULL_TREE,
build_function_type_list (integer_type_node, jmpbuf_ptr_type,
NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false,
NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
@ -487,35 +483,26 @@ gigi (Node_Id gnat_root,
= create_subprog_decl
(get_identifier ("__builtin_update_setjmp_buf"), 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, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
/* 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
= create_subprog_decl
(get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
build_function_type_list (void_type_node,
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);
(get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
set_exception_parameter_decl
= create_subprog_decl
(get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
NULL_TREE),
NULL_TREE, is_disabled, false, true, true, false, true, false,
NULL, Empty);
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
/* Hooks to call when entering/leaving an exception handler. */
ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
@ -523,20 +510,24 @@ gigi (Node_Id gnat_root,
begin_handler_decl
= create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false,
NULL, Empty);
is_disabled, true, true, true, false, NULL, Empty);
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false,
NULL, Empty);
is_disabled, true, true, true, false, NULL, Empty);
unhandled_except_decl
= create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
NULL_TREE, ftype, NULL_TREE,
is_disabled, false, true, true, false, true, false,
NULL, Empty);
is_disabled, true, true, true, false, 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
tables. These are exported by a-exexpr-gcc.adb, so see this unit for
@ -567,14 +558,15 @@ gigi (Node_Id gnat_root,
this procedure will never be called in this mode. */
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
= create_subprog_decl
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
build_function_type_list (void_type_node,
build_pointer_type (char_type_node),
integer_type_node, NULL_TREE),
NULL_TREE, is_disabled, false, true, true, true, true, false,
NULL, Empty);
(get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
gnat_raise_decls[i] = decl;
}
@ -736,10 +728,10 @@ build_raise_check (int check, enum exception_info_kind kind)
}
/* Indicate that it never returns. */
ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
result
= create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE,
ftype, NULL_TREE,
is_disabled, false, true, true, true, true, false,
= create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
NULL_TREE, is_disabled, true, true, true, false,
NULL, Empty);
return result;
@ -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. */
bool use_constant_initializer = false;
/* If the Etype of this node does not equal the Etype of the Entity,
something is wrong with the entity map, probably in generic
instantiation. However, this does not apply to types. Since we sometime
have strange Ekind's, just do this test for objects. Also, if the Etype of
the Entity is private, the Etype of the N_Identifier is allowed to be the
full type and also we consider a packed array type to be the same as the
original type. Similarly, a class-wide type is equivalent to a subtype of
itself. Finally, if the types are Itypes, one may be a copy of the other,
which is also legal. */
/* If the Etype of this node is not the same as that of the Entity, then
something went wrong, probably in generic instantiation. However, this
does not apply to types. Since we sometime have strange Ekind's, just
do this test for objects. Moreover, if the Etype of the Entity is private
or incomplete coming from a limited context, the Etype of the N_Identifier
is allowed to be the full/non-limited view and we also consider a packed
array type to be the same as the original type. Similarly, a CW type is
equivalent to a subtype of itself. Finally, if the types are Itypes, one
may be a copy of the other, which is also legal. */
gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier
|| Nkind (gnat_node) == N_Defining_Operator_Symbol)
? gnat_node : Entity (gnat_node));
@ -1046,6 +1038,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
&& (Etype (gnat_node)
== Packed_Array_Impl_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))
|| !(Ekind (gnat_temp) == E_Variable
|| Ekind (gnat_temp) == E_Component
@ -1569,25 +1565,11 @@ static tree
Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
{
const Node_Id gnat_prefix = Prefix (gnat_node);
tree gnu_prefix, gnu_type, gnu_expr;
tree gnu_result_type, gnu_result = error_mark_node;
tree gnu_prefix = gnat_to_gnu (gnat_prefix);
tree gnu_type = TREE_TYPE (gnu_prefix);
tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
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 (TREE_CODE (gnu_prefix) == NULL_EXPR)
{
@ -5340,8 +5322,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
= create_subprog_decl
(create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE,
is_disabled, false, true, false, false, true, true,
NULL, gnat_unit);
is_disabled, true, false, true, true, NULL, gnat_unit);
struct elab_info *info;
vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
@ -6340,8 +6321,7 @@ gnat_to_gnu (Node_Id gnat_node)
(Entity (Prefix (gnat_node)),
attr == Attr_Elab_Body ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, is_disabled,
false, true, true, false, true, true,
NULL, gnat_node);
true, true, true, true, NULL, gnat_node);
gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
}
@ -8554,14 +8534,11 @@ process_freeze_entity (Node_Id gnat_node)
if (kind == E_Class_Wide_Type)
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
= present_gnu_tree (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;
= present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
? get_gnu_tree (gnat_entity) : NULL_TREE;
/* Don't do anything for subprograms that may have been elaborated before
their freeze nodes. This can happen, for example, because of an inner
@ -8671,6 +8648,8 @@ process_freeze_entity (Node_Id gnat_node)
{
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
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))
used_types_insert (TREE_TYPE (gnu_new));
}

101
gcc/ada/gcc-interface/utils.c
View File

@ -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_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;
}
@ -2221,47 +2222,6 @@ split_plus (tree in, tree *pvar)
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. */
tree
@ -2742,12 +2702,10 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
return field_decl;
}
/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is
its type. READONLY is true if the parameter is readonly (either an In
parameter or an address of a pass-by-ref parameter). */
/* Return a PARM_DECL node with NAME and TYPE. */
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);
@ -2775,7 +2733,6 @@ create_param_decl (tree name, tree type, bool readonly)
}
DECL_ARG_TYPE (param_decl) = type;
TREE_READONLY (param_decl) = readonly;
return param_decl;
}
@ -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.
CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the
appropriate flags on the FUNCTION_DECL.
PUBLIC_FLAG is true if this is for a reference to a public entity or for a
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.
@ -3164,18 +3123,20 @@ create_label_decl (tree name, Node_Id gnat_node)
tree
create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
enum inline_status_t inline_status, bool const_flag,
bool public_flag, bool extern_flag, bool volatile_flag,
bool artificial_p, bool debug_info_p,
enum inline_status_t inline_status, bool public_flag,
bool extern_flag, bool artificial_p, bool debug_info_p,
struct attrib *attr_list, Node_Id gnat_node)
{
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;
finish_subprog_decl (subprog_decl, type);
DECL_ARTIFICIAL (subprog_decl) = artificial_p;
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)
{
@ -3204,20 +3165,6 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
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);
/* Add this decl to the current binding level. */
@ -3246,6 +3193,25 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
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
body. This routine needs to be invoked before processing the declarations
@ -3992,6 +3958,7 @@ update_pointer_to (tree old_type, tree new_type)
TYPE_OBJECT_RECORD_TYPE (new_type));
TYPE_POINTER_TO (old_type) = NULL_TREE;
TYPE_REFERENCE_TO (old_type) = NULL_TREE;
}
}

6
gcc/ada/sem_aux.adb
View File

@ -933,8 +933,12 @@ package body Sem_Aux is
declare
Ftyp : constant Entity_Id := Full_View (Btype);
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
return False;
return Is_Tagged_Type (Btype);
else
return Is_By_Reference_Type (Ftyp);
end if;

100
gcc/ada/sem_ch6.adb
View File

@ -2148,6 +2148,7 @@ package body Sem_Ch6 is
Body_Spec : Node_Id := Specification (N);
Body_Id : Entity_Id := Defining_Entity (Body_Spec);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Exch_Views : Elist_Id := No_Elist;
Conformant : Boolean;
HSS : Node_Id;
Prot_Typ : Entity_Id := Empty;
@ -2214,16 +2215,20 @@ package body Sem_Ch6 is
-- mechanism is used to find the corresponding spec of the primitive
-- 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
-- incomplete types coming from a limited context and swap their limited
-- views with the non-limited ones.
-- incomplete types coming from a limited context and replace their
-- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- 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);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the
-- subprogram whose body is being analyzed. N is the statement node
@ -2870,7 +2875,9 @@ package body Sem_Ch6 is
-- 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);
-- Determine whether Id's type denotes an incomplete type associated
-- with a limited with clause and exchange the limited view with the
@ -2890,6 +2897,12 @@ package body Sem_Ch6 is
and then Has_Non_Limited_View (Typ)
and then not From_Limited_With (Scope (Typ))
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));
end if;
end Detect_And_Exchange;
@ -2902,13 +2915,13 @@ package body Sem_Ch6 is
begin
if No (Subp_Id) then
return;
return No_Elist;
-- Do not process subprogram bodies as they already use the non-
-- limited view of types.
elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then
return;
return No_Elist;
end if;
-- Examine all formals and swap views when applicable
@ -2925,6 +2938,8 @@ package body Sem_Ch6 is
if Ekind (Subp_Id) = E_Function then
Detect_And_Exchange (Subp_Id);
end if;
return Result;
end Exchange_Limited_Views;
-------------------------------------
@ -2960,6 +2975,23 @@ package body Sem_Ch6 is
return False;
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 --
----------------------------
@ -3887,7 +3919,7 @@ package body Sem_Ch6 is
-- spec, swap any limited views with their non-limited counterpart.
if Ada_Version >= Ada_2012 then
Exchange_Limited_Views (Spec_Id);
Exch_Views := Exchange_Limited_Views (Spec_Id);
end if;
-- Analyze any aspect specifications that appear on the subprogram body
@ -4152,6 +4184,13 @@ package body Sem_Ch6 is
end if;
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;
end Analyze_Subprogram_Body_Helper;
@ -5269,10 +5308,7 @@ package body Sem_Ch6 is
procedure Possible_Freeze (T : Entity_Id);
-- 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
-- subprogram itself must be delayed. If T is the limited view of an
-- 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.
-- subprogram itself must be delayed.
---------------------
-- Possible_Freeze --
@ -5288,20 +5324,6 @@ package body Sem_Ch6 is
and then not Is_Frozen (Designated_Type (T))
then
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 Possible_Freeze;
@ -10451,9 +10473,7 @@ package body Sem_Ch6 is
-- it is still the case that untagged incomplete types cannot
-- be Taft-amendment types and must be completed in private
-- part, so the subprogram must appear in the list of private
-- dependents of the type. If the type is class-wide, it is
-- not a primitive, but the freezing of the subprogram must
-- also be delayed to force the creation of a freeze node.
-- dependents of the type.
if Is_Tagged_Type (Formal_Type)
or else (Ada_Version >= Ada_2012
@ -10462,19 +10482,14 @@ package body Sem_Ch6 is
then
if Ekind (Scope (Current_Scope)) = E_Package
and then not Is_Generic_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type)
then
if not Nkind_In
(Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
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,
Private_Dependents (Base_Type (Formal_Type)));
end if;
Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));
-- Freezing is delayed to ensure that Register_Prim
-- will get called for this operation, which is needed
@ -10728,19 +10743,6 @@ package body Sem_Ch6 is
if Nkind (Related_Nod) = N_Function_Specification then
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;
-- Now set the kind (mode) of each formal

5
gcc/ada/types.h
View File

@ -6,7 +6,7 @@
* *
* 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 *
* terms of the GNU General Public License as published by the Free Soft- *
@ -351,9 +351,6 @@ typedef Int Mechanism_Type;
#define By_Short_Descriptor_NCA (-18)
#define By_Short_Descriptor_Last (-18)
/* Internal to Gigi. */
#define By_Copy_Return (-128)
/* Definitions of Reason codes for Raise_xxx_Error nodes */
#define CE_Access_Check_Failed 0
#define CE_Access_Parameter_Is_Null 1

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
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>
PR target/70155

43
gcc/testsuite/gnat.dg/limited_with4.adb Normal file
View File

@ -0,0 +1,43 @@
-- { 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;

29
gcc/testsuite/gnat.dg/limited_with4.ads Normal file
View File

@ -0,0 +1,29 @@
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;

19
gcc/testsuite/gnat.dg/limited_with4_pkg.ads Normal file
View File

@ -0,0 +1,19 @@
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;