mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-02 06:40:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias.

Browse Source 
2008-05-26  Javier Miranda  <miranda@adacore.com>

	* einfo.ads (Abstract_Interface_Alias): Renamed as Interface_Alias.
	(Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias.
	(Is_Internal): Adding documentation on internal entities that have
 	attribute Interface_Alias (old attribute Abstract_Interface_Alias)

	* einfo.adb (Abstract_Interface_Alias): Renamed as Interface_Alias.
	(Set_Abstract_Interface_Alias): Renamed as Set_Interface_Alias.
 	Added assertion to force entities with this attribute to have
 	attribute Is_Internal set to True.
	(Next_Tag_Component): Simplify assertion using attribute Is_Tag.

	* sem_ch3.adb (Derive_Interface_Subprograms): This subprogram has been
 	renamed as Derive_Progenitor_Subprograms. In addition, its code is
 	a new implementation.
	(Add_Interface_Tag_Components): Remove special management of
	synchronized interfaces.
	(Analyze_Interface_Declaration): Minor reformating
	(Build_Derived_Record_Type): Minor reformating
	(Check_Abstract_Overriding): Avoid reporting error in case of abstract
 	predefined primitive inherited from interface type because the body of
 	internally generated predefined primitives of tagged types are generated
 	later by Freeze_Type
	(Derive_Subprogram): Avoid generating an internal name if the parent
 	subprogram overrides an interface primitive.
	(Derive_Subprograms): New implementation that keeps separate the
 	management of tagged types not implementing interfaces, from tagged
 	types that implement interfaces.
	(Is_Progenitor): New implementation.
	(Process_Full_View): Add documentation
	(Record_Type_Declaration): Replace call to Derive_Interface_Subprograms
 	by call to Derive_Progenitor_Subprograms.

	* sem_ch6.ads (Is_Interface_Conformant): New subprogram.
	(Check_Subtype_Conformant, Subtype_Conformant): Adding new argument
 	Skip_Controlling_Formals.

	* sem_ch6.adb (Is_Interface_Conformant): New subprogram.
	(Check_Conventions): New implementation. Remove local subprogram
 	Skip_Check. Remove formal Search_From of routine Check_Convention.
	(Check_Subtype_Conformant, Subtype_Conformant): Adding new argument
 	Skip_Controlling_Formals.
	(New_Overloaded_Entity): Enable addition of predefined dispatching
 	operations.

	* sem_disp.ads
	(Find_Primitive_Covering_Interface): New subprogram.

	* sem_disp.adb (Check_Dispatching_Operation): Disable registering
 	the task body procedure as a primitive of the corresponding tagged
 	type.
	(Check_Operation_From_Private_Type): Avoid adding twice an entity
 	to the list of primitives.
	(Find_Primitive_Covering_Interface): New subprogram.
	(Override_Dispatching_Operation): Add documentation.

	* sem_type.adb (Covers): Minor reformatings

	* sem_util.ads (Collect_Abstract_Interfaces): Renamed as
	Collect_Interfaces.
 	Rename formal.
	(Has_Abstract_Interfaces): Renamed as Has_Interfaces.
	(Implements_Interface): New subprogram.
	(Is_Parent): Removed.
	(Primitive_Names_Match): New subprogram.
	(Remove_Homonym): Moved here from Derive_Interface_Subprograms.
	(Ultimate_Alias): New subprogram.

	* sem_util.adb (Collect_Abstract_Interfaces): Renamed as
	Collect_Interfaces.
 	Remove special management for synchronized types. Rename formal. Remove
 	internal subprograms Interface_Present_In_Parent and Add_Interface.
	(Has_Abstract_Interfaces): Renamed as Has_Interfaces. Replace assertion
 	on non-record types by code to return false in such case.
	(Implements_Interface): New subprogram.
	(Is_Parent): Removed. No special management is now required for
 	synchronized types covering interfaces.
	(Primitive_Names_Match): New subprogram.
	(Remove_Homonym): Moved here from Derive_Interface_Subprograms.
	(Ultimate_Alias): New subprogram.

	* exp_ch3.adb (Add_Internal_Interface_Entities): New subprogram.
 	Add internal entities associated with secondary dispatch tables to
 	the list of tagged type primitives that are not interfaces.
	(Freeze_Record_Type): Add new call to Add_Internal_Interface_Entities
	(Make_Predefined_Primitive_Specs): Code reorganization to improve
 	the management of predefined equality operator. In addition, if
 	the type has an equality function corresponding with a primitive
 	defined in an interface type, the inherited equality is abstract
 	as well, and no body can be created for it.

	* exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved from
 	exp_util to exp_disp.
	(Is_Predefined_Interface_Primitive): New subprogram. Returns True if
 	an entity corresponds with one of the predefined primitives required
 	to implement interfaces.
	Update copyright notice.

	* exp_disp.adb (Set_All_DT_Position): Add assertion. Exclude from the
 	final check on abstract subprograms all the primitives associated with
 	interface primitives because they must be visible in the public and
 	private part.
	(Write_DT): Use Find_Dispatching_Type to locate the name of the
	interface type. This allows the use of this routine, for debugging
	purposes, when the tagged type is not fully decorated.
	(Is_Predefined_Dispatching_Operation): Moved from exp_util to exp_disp.
 	Factorize code calling new subprogram Is_Predefined_Interface_Primitive.
	(Is_Predefined_Interface_Primitive): New subprogram. Returns True if an
 	entity corresponds with one of the predefined primitives required to
 	implement interfaces.

	* exp_util.adb (Find_Interface_ADT): New implementation
	(Find_Interface): Removed.

	* sprint.adb (Sprint_Node_Actual): Generate missing output for the
 	list of interfaces associated with nodes
	N_Formal_Derived_Type_Definition and N_Private_Extension_Declaration.

From-SVN: r135923
This commit is contained in:
Javier Miranda 2008-05-26 15:43:18 +02:00 committed by Arnaud Charlet
parent e5f005e18c
commit ce2b6ba521
29 changed files with 1783 additions and 1554 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
gcc/ada/einfo.adb
View File

@ -208,8 +208,8 @@ package body Einfo is
-- Spec_PPC_List Node24
-- Abstract_Interface_Alias Node25
-- Abstract_Interfaces Elist25
-- Interface_Alias Node25
-- Interfaces Elist25
-- Debug_Renaming_Link Node25
-- DT_Offset_To_Top_Func Node25
-- Task_Body_Procedure Node25
@ -544,18 +544,6 @@ package body Einfo is
-- Attribute Access Functions --
--------------------------------
function Abstract_Interfaces (Id : E) return L is
begin
pragma Assert (Is_Record_Type (Id));
return Elist25 (Id);
end Abstract_Interfaces;
function Abstract_Interface_Alias (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id));
return Node25 (Id);
end Abstract_Interface_Alias;
function Accept_Address (Id : E) return L is
begin
return Elist21 (Id);
@ -1538,6 +1526,18 @@ package body Einfo is
return Flag232 (Id);
end Implemented_By_Entry;
function Interfaces (Id : E) return L is
begin
pragma Assert (Is_Record_Type (Id));
return Elist25 (Id);
end Interfaces;
function Interface_Alias (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id));
return Node25 (Id);
end Interface_Alias;
function In_Package_Body (Id : E) return B is
begin
return Flag48 (Id);
@ -2941,21 +2941,6 @@ package body Einfo is
-- Attribute Set Procedures --
------------------------------
procedure Set_Abstract_Interfaces (Id : E; V : L) is
begin
pragma Assert (Is_Record_Type (Id));
Set_Elist25 (Id, V);
end Set_Abstract_Interfaces;
procedure Set_Abstract_Interface_Alias (Id : E; V : E) is
begin
pragma Assert
(Is_Hidden (Id)
and then
(Ekind (Id) = E_Procedure or else Ekind (Id) = E_Function));
Set_Node25 (Id, V);
end Set_Abstract_Interface_Alias;
procedure Set_Accept_Address (Id : E; V : L) is
begin
Set_Elist21 (Id, V);
@ -3961,6 +3946,22 @@ package body Einfo is
Set_Flag232 (Id, V);
end Set_Implemented_By_Entry;
procedure Set_Interfaces (Id : E; V : L) is
begin
pragma Assert (Is_Record_Type (Id));
Set_Elist25 (Id, V);
end Set_Interfaces;
procedure Set_Interface_Alias (Id : E; V : E) is
begin
pragma Assert
(Is_Internal (Id)
and then Is_Hidden (Id)
and then (Ekind (Id) = E_Procedure
or else Ekind (Id) = E_Function));
Set_Node25 (Id, V);
end Set_Interface_Alias;
procedure Set_In_Package_Body (Id : E; V : B := True) is
begin
Set_Flag48 (Id, V);
@ -7296,11 +7297,9 @@ package body Einfo is
function Next_Tag_Component (Id : E) return E is
Comp : Entity_Id;
Typ : constant Entity_Id := Scope (Id);
begin
pragma Assert (Ekind (Id) = E_Component
and then Is_Tagged_Type (Typ));
pragma Assert (Is_Tag (Id));
Comp := Next_Entity (Id);
while Present (Comp) loop
@ -8600,13 +8599,13 @@ package body Einfo is
when E_Procedure |
E_Function =>
Write_Str ("Abstract_Interface_Alias");
Write_Str ("Interface_Alias");
when E_Record_Type |
E_Record_Subtype |
E_Record_Type_With_Private |
E_Record_Subtype_With_Private =>
Write_Str ("Abstract_Interfaces");
Write_Str ("Interfaces");
when Task_Kind =>
Write_Str ("Task_Body_Procedure");

64
gcc/ada/einfo.ads
View File

@ -293,18 +293,6 @@ package Einfo is
-- type, and if assertions are enabled, an attempt to set the attribute on a
-- subtype will raise an assert error.
-- Abstract_Interfaces (Elist25)
-- Present in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- Abstract_Interface_Alias (Node25)
-- Present in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
-- Accept_Address (Elist21)
-- Present in entries. If an accept has a statement sequence, then an
-- address variable is created, which is used to hold the address of the
@ -364,12 +352,12 @@ package Einfo is
-- Alias (Node18)
-- Present in overloaded entities (literals, subprograms, entries) and
-- subprograms that cover a primitive operation of an abstract interface
-- (that is, subprograms with the Abstract_Interface_Alias attribute).
-- In case of overloaded entities it points to the parent subprogram of
-- a derived subprogram. In case of abstract interface subprograms it
-- points to the subprogram that covers the abstract interface primitive.
-- Also used for a subprogram renaming, where it points to the renamed
-- subprogram. Always empty for entries.
-- (that is, subprograms with the Interface_Alias attribute). In case of
-- overloaded entities it points to the parent subprogram of a derived
-- subprogram. In case of abstract interface subprograms it points to the
-- subprogram that covers the abstract interface primitive. Also used for
-- a subprogram renaming, where it points to the renamed subprogram.
-- Always empty for entries.
-- Alignment (Uint14)
-- Present in entities for types and also in constants, variables
@ -1837,6 +1825,18 @@ package Einfo is
-- Applies to functions and procedures. Set if pragma Implemented_By_
-- Entry is applied on the subprogram entity.
-- Interfaces (Elist25)
-- Present in record types and subtypes. List of abstract interfaces
-- implemented by a tagged type that are not already implemented by the
-- ancestors (Ada 2005: AI-251).
-- Interface_Alias (Node25)
-- Present in subprograms that cover a primitive operation of an abstract
-- interface type. Can be set only if the Is_Hidden flag is also set,
-- since such entities are always hidden. Points to its associated
-- interface subprogram. It is used to register the subprogram in
-- secondary dispatch table of the interface (Ada 2005: AI-251).
-- In_Package_Body (Flag48)
-- Present in package entities. Set on the entity that denotes the
-- package (the defining occurrence of the package declaration) while
@ -2259,6 +2259,10 @@ package Einfo is
-- 3) Object declarations generated by the expander that are implicitly
-- imported or exported so that they can be marked in Sprint output.
--
-- 4) Internal entities in the list of primitives of tagged types that
-- are used to handle secondary dispatch tables. These entities have
-- also the attribute Interface_Alias.
--
-- Is_Interrupt_Handler (Flag89)
-- Present in procedures. Set if a pragma Interrupt_Handler applies
-- to the procedure. The procedure must be parameterless, and on all
@ -5018,7 +5022,7 @@ package Einfo is
-- Generic_Renamings (Elist23) (for an instance)
-- Inner_Instances (Elist23) (generic function only)
-- Protection_Object (Node23) (for concurrent kind)
-- Abstract_Interface_Alias (Node25)
-- Interface_Alias (Node25)
-- Overridden_Operation (Node26)
-- Extra_Formals (Node28)
-- Body_Needed_For_SAL (Flag40)
@ -5279,7 +5283,7 @@ package Einfo is
-- Inner_Instances (Elist23) (for generic proc)
-- Protection_Object (Node23) (for concurrent kind)
-- Spec_PPC_List (Node24) (non-generic case only)
-- Abstract_Interface_Alias (Node25)
-- Interface_Alias (Node25)
-- Static_Initialization (Node26) (init_proc only)
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
@ -5363,7 +5367,7 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Corresponding_Remote_Type (Node22)
-- Stored_Constraint (Elist23)
-- Abstract_Interfaces (Elist25)
-- Interfaces (Elist25)
-- Component_Alignment (special) (base type only)
-- C_Pass_By_Copy (Flag125) (base type only)
-- Has_Dispatch_Table (Flag220) (base tagged type only)
@ -5397,7 +5401,7 @@ package Einfo is
-- Discriminant_Constraint (Elist21)
-- Private_View (Node22)
-- Stored_Constraint (Elist23)
-- Abstract_Interfaces (Elist25)
-- Interfaces (Elist25)
-- Has_Completion (Flag26)
-- Has_Record_Rep_Clause (Flag65) (base type only)
-- Has_External_Tag_Rep_Clause (Flag110)
@ -5746,13 +5750,11 @@ package Einfo is
-- section contains the functions used to obtain attribute values which
-- correspond to values in fields or flags in the entity itself.
function Abstract_Interfaces (Id : E) return L;
function Accept_Address (Id : E) return L;
function Access_Disp_Table (Id : E) return L;
function Actual_Subtype (Id : E) return E;
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Abstract_Interface_Alias (Id : E) return E;
function Alignment (Id : E) return U;
function Associated_Final_Chain (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
@ -5920,6 +5922,8 @@ package Einfo is
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
function Inner_Instances (Id : E) return L;
function Interfaces (Id : E) return L;
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
function Is_AST_Entry (Id : E) return B;
function Is_Abstract_Subprogram (Id : E) return B;
@ -6305,14 +6309,12 @@ package Einfo is
-- Attribute Set Procedures --
------------------------------
procedure Set_Abstract_Interfaces (Id : E; V : L);
procedure Set_Accept_Address (Id : E; V : L);
procedure Set_Access_Disp_Table (Id : E; V : L);
procedure Set_Dispatch_Table_Wrapper (Id : E; V : E);
procedure Set_Actual_Subtype (Id : E; V : E);
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Abstract_Interface_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
procedure Set_Associated_Final_Chain (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
@ -6474,10 +6476,12 @@ package Einfo is
procedure Set_Hiding_Loop_Variable (Id : E; V : E);
procedure Set_Homonym (Id : E; V : E);
procedure Set_Implemented_By_Entry (Id : E; V : B := True);
procedure Set_Interfaces (Id : E; V : L);
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
procedure Set_Inner_Instances (Id : E; V : L);
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);
procedure Set_Is_AST_Entry (Id : E; V : B := True);
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
@ -6954,12 +6958,10 @@ package Einfo is
-- subprograms meeting the requirements documented in the section on
-- XEINFO may be referenced in this section.
pragma Inline (Abstract_Interfaces);
pragma Inline (Accept_Address);
pragma Inline (Access_Disp_Table);
pragma Inline (Actual_Subtype);
pragma Inline (Address_Taken);
pragma Inline (Abstract_Interface_Alias);
pragma Inline (Alias);
pragma Inline (Alignment);
pragma Inline (Associated_Final_Chain);
@ -7122,10 +7124,12 @@ package Einfo is
pragma Inline (Hiding_Loop_Variable);
pragma Inline (Homonym);
pragma Inline (Implemented_By_Entry);
pragma Inline (Interfaces);
pragma Inline (In_Package_Body);
pragma Inline (In_Private_Part);
pragma Inline (In_Use);
pragma Inline (Inner_Instances);
pragma Inline (Interface_Alias);
pragma Inline (Interface_Name);
pragma Inline (Is_AST_Entry);
pragma Inline (Is_Abstract_Subprogram);
@ -7380,12 +7384,10 @@ package Einfo is
pragma Inline (Init_Esize);
pragma Inline (Init_RM_Size);
pragma Inline (Set_Abstract_Interfaces);
pragma Inline (Set_Accept_Address);
pragma Inline (Set_Access_Disp_Table);
pragma Inline (Set_Actual_Subtype);
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Abstract_Interface_Alias);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
pragma Inline (Set_Associated_Final_Chain);
@ -7547,10 +7549,12 @@ package Einfo is
pragma Inline (Set_Hiding_Loop_Variable);
pragma Inline (Set_Homonym);
pragma Inline (Set_Implemented_By_Entry);
pragma Inline (Set_Interfaces);
pragma Inline (Set_In_Package_Body);
pragma Inline (Set_In_Private_Part);
pragma Inline (Set_In_Use);
pragma Inline (Set_Inner_Instances);
pragma Inline (Set_Interface_Alias);
pragma Inline (Set_Interface_Name);
pragma Inline (Set_Is_AST_Entry);
pragma Inline (Set_Is_Abstract_Subprogram);

6
gcc/ada/exp_aggr.adb
View File

@ -2573,7 +2573,7 @@ package body Exp_Aggr is
-- Ada 2005 (AI-251): If tagged type has progenitors we must
-- also initialize tags of the secondary dispatch tables.
if Has_Abstract_Interfaces (Base_Type (Typ)) then
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
@ -3080,7 +3080,7 @@ package body Exp_Aggr is
-- abstract interfaces we must also initialize the tags of the
-- secondary dispatch tables.
if Has_Abstract_Interfaces (Base_Type (Typ)) then
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
@ -5369,7 +5369,7 @@ package body Exp_Aggr is
-- If the tagged types covers interface types we need to initialize all
-- hidden components containing pointers to secondary dispatch tables.
elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
elsif Is_Tagged_Type (Typ) and then Has_Interfaces (Typ) then
Convert_To_Assignments (N, Typ);
-- If some components are mutable, the size of the aggregate component

2
gcc/ada/exp_ch13.adb
View File

@ -299,7 +299,7 @@ package body Exp_Ch13 is
-- its secondary dispatch table and therefore the code generator
-- has nothing else to do with this freezing node.
Delete := Present (Abstract_Interface_Alias (E));
Delete := Present (Interface_Alias (E));
end if;
-- Analyze actions generated by freezing. The init_proc contains source

177
gcc/ada/exp_ch3.adb
View File

@ -57,6 +57,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Stand; use Stand;
@ -2166,7 +2167,7 @@ package body Exp_Ch3 is
-- If the interface is a parent of Rec_Type it shares the primary
-- dispatch table and hence there is no need to build the function
if not Is_Parent (Node (Iface_Elmt), Rec_Type) then
if not Is_Ancestor (Node (Iface_Elmt), Rec_Type) then
Build_Offset_To_Top_Function (Iface_Comp => Node (Comp_Elmt));
end if;
@ -2304,7 +2305,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05
and then not Is_Interface (Rec_Type)
and then Has_Abstract_Interfaces (Rec_Type)
and then Has_Interfaces (Rec_Type)
then
Init_Secondary_Tags
(Typ => Rec_Type,
@ -2398,8 +2399,7 @@ package body Exp_Ch3 is
if not Is_Imported (Prim)
and then Convention (Prim) = Convention_CPP
and then not Present (Abstract_Interface_Alias
(Prim))
and then not Present (Interface_Alias (Prim))
then
Register_Primitive (Loc,
Prim => Prim,
@ -2421,7 +2421,7 @@ package body Exp_Ch3 is
if Ada_Version >= Ada_05
and then not Is_Interface (Rec_Type)
and then Has_Abstract_Interfaces (Rec_Type)
and then Has_Interfaces (Rec_Type)
and then Has_Discriminants (Etype (Rec_Type))
and then Is_Variable_Size_Record (Etype (Rec_Type))
then
@ -4421,7 +4421,7 @@ package body Exp_Ch3 is
and then
(Is_Class_Wide_Type (Etype (Expr))
or else
not Is_Parent (Root_Type (Typ), Etype (Expr)))
not Is_Ancestor (Root_Type (Typ), Etype (Expr)))
and then Comes_From_Source (Def_Id)
and then VM_Target = No_VM
then
@ -5321,6 +5321,105 @@ package body Exp_Ch3 is
------------------------
procedure Freeze_Record_Type (N : Node_Id) is
procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id);
-- Add to the list of primitives of Tagged_Types the internal entities
-- associated with interface primitives that are located in secondary
-- dispatch tables.
-------------------------------------
-- Add_Internal_Interface_Entities --
-------------------------------------
procedure Add_Internal_Interface_Entities (Tagged_Type : Entity_Id) is
Elmt : Elmt_Id;
Iface : Entity_Id;
Iface_Elmt : Elmt_Id;
Iface_Prim : Entity_Id;
Ifaces_List : Elist_Id;
New_Subp : Entity_Id := Empty;
Prim : Entity_Id;
begin
pragma Assert (Ada_Version >= Ada_05
and then Is_Record_Type (Tagged_Type)
and then Is_Tagged_Type (Tagged_Type)
and then Has_Interfaces (Tagged_Type)
and then not Is_Interface (Tagged_Type));
Collect_Interfaces (Tagged_Type, Ifaces_List);
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
-- Exclude from this processing interfaces that are parents
-- of Tagged_Type because their primitives are located in the
-- primary dispatch table (and hence no auxiliary internal
-- entities are required to handle secondary dispatch tables
-- in such case).
if not Is_Ancestor (Iface, Tagged_Type) then
Elmt := First_Elmt (Primitive_Operations (Iface));
while Present (Elmt) loop
Iface_Prim := Node (Elmt);
if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
Prim :=
Find_Primitive_Covering_Interface
(Tagged_Type => Tagged_Type,
Iface_Prim => Iface_Prim);
pragma Assert (Present (Prim));
Derive_Subprogram
(New_Subp => New_Subp,
Parent_Subp => Iface_Prim,
Derived_Type => Tagged_Type,
Parent_Type => Iface);
-- Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-- associated with interface types. These entities are
-- only registered in the list of primitives of its
-- corresponding tagged type because they are only used
-- to fill the contents of the secondary dispatch tables.
-- Therefore they are removed from the homonym chains.
Set_Is_Hidden (New_Subp);
Set_Is_Internal (New_Subp);
Set_Alias (New_Subp, Prim);
Set_Is_Abstract_Subprogram (New_Subp,
Is_Abstract_Subprogram (Prim));
Set_Interface_Alias (New_Subp, Iface_Prim);
-- Internal entities associated with interface types are
-- only registered in the list of primitives of the
-- tagged type. They are only used to fill the contents
-- of the secondary dispatch tables. Therefore they are
-- not needed in the homonym chains.
Remove_Homonym (New_Subp);
-- Hidden entities associated with interfaces must have
-- set the Has_Delay_Freeze attribute to ensure that, in
-- case of locally defined tagged types (or compiling
-- with static dispatch tables generation disabled) the
-- corresponding entry of the secondary dispatch table is
-- filled when such entity is frozen.
Set_Has_Delayed_Freeze (New_Subp);
end if;
Next_Elmt (Elmt);
end loop;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end Add_Internal_Interface_Entities;
-- Local variables
Def_Id : constant Node_Id := Entity (N);
Type_Decl : constant Node_Id := Parent (Def_Id);
Comp : Entity_Id;
@ -5343,6 +5442,8 @@ package body Exp_Ch3 is
Wrapper_Body_List : List_Id := No_List;
Null_Proc_Decl_List : List_Id := No_List;
-- Start of processing for Freeze_Record_Type
begin
-- Build discriminant checking functions if not a derived type (for
-- derived types that are not tagged types, always use the discriminant
@ -5545,6 +5646,17 @@ package body Exp_Ch3 is
Insert_Actions (N, Null_Proc_Decl_List);
end if;
-- Ada 2005 (AI-251): Add internal entities associated with
-- secondary dispatch tables to the list of primitives of tagged
-- types that are not interfaces
if Ada_Version >= Ada_05
and then not Is_Interface (Def_Id)
and then Has_Interfaces (Def_Id)
then
Add_Internal_Interface_Entities (Def_Id);
end if;
Set_Is_Frozen (Def_Id);
Set_All_DT_Position (Def_Id);
@ -6678,7 +6790,7 @@ package body Exp_Ch3 is
-- Initialize the pointer to the secondary DT associated with the
-- interface.
if not Is_Parent (Iface, Typ) then
if not Is_Ancestor (Iface, Typ) then
Append_To (Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
@ -6776,7 +6888,7 @@ package body Exp_Ch3 is
-- Don't need to set any value if this interface shares
-- the primary dispatch table.
if not Is_Parent (Iface, Typ) then
if not Is_Ancestor (Iface, Typ) then
Append_To (Stmts_List,
Build_Set_Static_Offset_To_Top (Loc,
Iface_Tag => New_Reference_To (Iface_Tag, Loc),
@ -7499,27 +7611,42 @@ package body Exp_Ch3 is
-- User-defined equality
elsif Chars (Node (Prim)) = Name_Op_Eq
and then (No (Alias (Node (Prim)))
or else Nkind (Unit_Declaration_Node (Node (Prim))) =
N_Subprogram_Renaming_Declaration)
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then Base_Type (Etype (Node (Prim))) = Standard_Boolean
then
Eq_Needed := False;
exit;
if No (Alias (Node (Prim)))
or else Nkind (Unit_Declaration_Node (Node (Prim))) =
N_Subprogram_Renaming_Declaration
then
Eq_Needed := False;
exit;
-- If the parent is not an interface type and has an abstract
-- equality function, the inherited equality is abstract as well,
-- and no body can be created for it.
-- If the parent is not an interface type and has an abstract
-- equality function, the inherited equality is abstract as
-- well, and no body can be created for it.
elsif Chars (Node (Prim)) = Name_Op_Eq
and then not Is_Interface (Etype (Tag_Typ))
and then Present (Alias (Node (Prim)))
and then Is_Abstract_Subprogram (Alias (Node (Prim)))
then
Eq_Needed := False;
exit;
elsif not Is_Interface (Etype (Tag_Typ))
and then Present (Alias (Node (Prim)))
and then Is_Abstract_Subprogram (Alias (Node (Prim)))
then
Eq_Needed := False;
exit;
-- If the type has an equality function corresponding with
-- a primitive defined in an interface type, the inherited
-- equality is abstract as well, and no body can be created
-- for it.
elsif Present (Alias (Node (Prim)))
and then Comes_From_Source (Ultimate_Alias (Node (Prim)))
and then
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Node (Prim))))
then
Eq_Needed := False;
exit;
end if;
end if;
Next_Elmt (Prim);
@ -7663,7 +7790,7 @@ package body Exp_Ch3 is
and then Is_Limited_Record (Etype (Tag_Typ)))
or else
(Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Abstract_Interfaces (Tag_Typ))
and then Has_Interfaces (Tag_Typ))
then
Append_To (Res,
Make_Subprogram_Declaration (Loc,
@ -8116,7 +8243,7 @@ package body Exp_Ch3 is
((Is_Interface (Etype (Tag_Typ))
and then Is_Limited_Record (Etype (Tag_Typ)))
or else (Is_Concurrent_Record_Type (Tag_Typ)
and then Has_Abstract_Interfaces (Tag_Typ)))
and then Has_Interfaces (Tag_Typ)))
and then RTE_Available (RE_Select_Specific_Data)
then
Append_To (Res, Make_Disp_Asynchronous_Select_Body (Tag_Typ));

2
gcc/ada/exp_ch4.adb
View File

@ -9210,7 +9210,7 @@ package body Exp_Ch4 is
-- Obj1 in Iface'Class; -- Compile time error
if not Is_Class_Wide_Type (Left_Type)
and then (Is_Parent (Etype (Right_Type), Left_Type)
and then (Is_Ancestor (Etype (Right_Type), Left_Type)
or else (Is_Interface (Etype (Right_Type))
and then Interface_Present_In_Ancestor
(Typ => Left_Type,

4
gcc/ada/exp_ch6.adb
View File

@ -4728,7 +4728,7 @@ package body Exp_Ch6 is
Tagged_Typ := Find_Dispatching_Type (Prim);
if No (Access_Disp_Table (Tagged_Typ))
or else not Has_Abstract_Interfaces (Tagged_Typ)
or else not Has_Interfaces (Tagged_Typ)
or else not RTE_Available (RE_Interface_Tag)
or else Restriction_Active (No_Dispatching_Calls)
then
@ -4856,7 +4856,7 @@ package body Exp_Ch6 is
-- table slot.
if not Is_Interface (Typ)
or else Present (Abstract_Interface_Alias (Subp))
or else Present (Interface_Alias (Subp))
then
if Is_Predefined_Dispatching_Operation (Subp) then
Register_Predefined_DT_Entry (Subp);

35
gcc/ada/exp_ch9.adb
View File

@ -32,6 +32,7 @@ with Exp_Ch3; use Exp_Ch3;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
@ -1880,11 +1881,11 @@ package body Exp_Ch9 is
Iface := Etype (Iface);
end loop Examine_Parents;
if Present (Abstract_Interfaces
if Present (Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))))
then
Iface_Elmt := First_Elmt
(Abstract_Interfaces
(Interfaces
(Corresponding_Record_Type (Scope (Proc_Nam))));
Examine_Interfaces : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
@ -7091,7 +7092,7 @@ package body Exp_Ch9 is
-- an interface.
if Ada_Version >= Ada_05
and then Present (Abstract_Interfaces (
and then Present (Interfaces (
Corresponding_Record_Type (Pid)))
then
Disp_Op_Body :=
@ -7178,8 +7179,7 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then Present (Protected_Definition (Parent (Pid)))
and then Present (Abstract_Interfaces
(Corresponding_Record_Type (Pid)))
and then Present (Interfaces (Corresponding_Record_Type (Pid)))
then
declare
Vis_Decl : Node_Id :=
@ -7630,10 +7630,10 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then Present (Visible_Declarations (Pdef))
and then Present (Corresponding_Record_Type
(Defining_Identifier (Parent (Pdef))))
and then Present (Abstract_Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Pdef)))))
(Defining_Identifier (Parent (Pdef))))
and then Present (Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Pdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
@ -7750,8 +7750,7 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then
Present (Abstract_Interfaces
(Corresponding_Record_Type (Prot_Typ)))
Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
Sub :=
Make_Subprogram_Declaration (Loc,
@ -9535,8 +9534,7 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then Present (Task_Definition (Parent (Ttyp)))
and then Present (Abstract_Interfaces
(Corresponding_Record_Type (Ttyp)))
and then Present (Interfaces (Corresponding_Record_Type (Ttyp)))
then
declare
Current_Node : Node_Id;
@ -10030,10 +10028,10 @@ package body Exp_Ch9 is
if Ada_Version >= Ada_05
and then Present (Taskdef)
and then Present (Corresponding_Record_Type
(Defining_Identifier (Parent (Taskdef))))
and then Present (Abstract_Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Taskdef)))))
(Defining_Identifier (Parent (Taskdef))))
and then Present (Interfaces
(Corresponding_Record_Type
(Defining_Identifier (Parent (Taskdef)))))
then
declare
Current_Node : Node_Id := Rec_Decl;
@ -10087,7 +10085,6 @@ package body Exp_Ch9 is
declare
L : constant List_Id := Freeze_Entity (Rec_Ent, Loc);
begin
if Is_Non_Empty_List (L) then
Insert_List_After (Body_Decl, L);
@ -11576,7 +11573,7 @@ package body Exp_Ch9 is
if Has_Entry
or else Has_Interrupt_Handler (Ptyp)
or else Has_Attach_Handler (Ptyp)
or else Has_Abstract_Interfaces (Protect_Rec)
or else Has_Interfaces (Protect_Rec)
then
declare
Pkg_Id : constant RTU_Id :=

180
gcc/ada/exp_disp.adb
View File

@ -1080,7 +1080,7 @@ package body Exp_Disp is
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
elsif Is_Parent (Formal_Typ, Actual_Typ) then
elsif Is_Ancestor (Formal_Typ, Actual_Typ) then
null;
-- Implicit conversion to the class-wide formal type to force
@ -1126,7 +1126,7 @@ package body Exp_Disp is
-- a parent of the type of the actual because in this case the
-- interface primitives are located in the primary dispatch table.
elsif Is_Parent (Formal_DDT, Actual_DDT) then
elsif Is_Ancestor (Formal_DDT, Actual_DDT) then
null;
else
@ -1450,6 +1450,50 @@ package body Exp_Disp is
and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
-----------------------------------------
-- Is_Predefined_Dispatching_Operation --
-----------------------------------------
function Is_Predefined_Dispatching_Operation
(E : Entity_Id) return Boolean
is
TSS_Name : TSS_Name_Type;
begin
if not Is_Dispatching_Operation (E) then
return False;
end if;
Get_Name_String (Chars (E));
-- Most predefined primitives have internally generated names. Equality
-- must be treated differently; the predefined operation is recognized
-- as a homogeneous binary operator that returns Boolean.
if Name_Len > TSS_Name_Type'Last then
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
or else TSS_Name = TSS_Stream_Output
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
or else Is_Predefined_Interface_Primitive (E)
then
return True;
end if;
end if;
return False;
end Is_Predefined_Dispatching_Operation;
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
@ -1475,6 +1519,21 @@ package body Exp_Disp is
return False;
end Is_Predefined_Dispatching_Alias;
---------------------------------------
-- Is_Predefined_Interface_Primitive --
---------------------------------------
function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
begin
return Ada_Version >= Ada_05
and then (Chars (E) = Name_uDisp_Asynchronous_Select or else
Chars (E) = Name_uDisp_Conditional_Select or else
Chars (E) = Name_uDisp_Get_Prim_Op_Kind or else
Chars (E) = Name_uDisp_Get_Task_Id or else
Chars (E) = Name_uDisp_Requeue or else
Chars (E) = Name_uDisp_Timed_Select);
end Is_Predefined_Interface_Primitive;
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
@ -3401,7 +3460,7 @@ package body Exp_Disp is
or else Is_Controlled (Typ)
or else Restriction_Active (No_Dispatching_Calls)
or else not Is_Limited_Type (Typ)
or else not Has_Abstract_Interfaces (Typ)
or else not Has_Interfaces (Typ)
or else not Build_Thunks
then
-- No OSD table required
@ -3429,11 +3488,11 @@ package body Exp_Disp is
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
if Present (Abstract_Interface_Alias (Prim))
if Present (Interface_Alias (Prim))
and then Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)) = Iface
(Interface_Alias (Prim)) = Iface
then
Prim_Alias := Abstract_Interface_Alias (Prim);
Prim_Alias := Interface_Alias (Prim);
E := Prim;
while Present (Alias (E)) loop
@ -3544,31 +3603,29 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt);
if not Is_Predefined_Dispatching_Operation (Prim)
and then Present (Abstract_Interface_Alias (Prim))
and then Present (Interface_Alias (Prim))
and then not Is_Abstract_Subprogram (Alias (Prim))
and then not Is_Imported (Alias (Prim))
and then Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)) = Iface
(Interface_Alias (Prim)) = Iface
-- Generate the code of the thunk only if the abstract
-- interface type is not an immediate ancestor of
-- Tagged_Type; otherwise the DT associated with the
-- interface is the primary DT.
and then not Is_Parent (Iface, Typ)
and then not Is_Ancestor (Iface, Typ)
then
if not Build_Thunks then
Pos :=
UI_To_Int
(DT_Position (Abstract_Interface_Alias (Prim)));
UI_To_Int (DT_Position (Interface_Alias (Prim)));
Prim_Table (Pos) := Alias (Prim);
else
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then
Pos :=
UI_To_Int
(DT_Position (Abstract_Interface_Alias (Prim)));
UI_To_Int (DT_Position (Interface_Alias (Prim)));
Prim_Table (Pos) := Thunk_Id;
Append_To (Result, Thunk_Code);
@ -3843,7 +3900,7 @@ package body Exp_Disp is
-- Ada 2005 (AI-251): Build the secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
Suffix_Index := 0;
@ -4438,7 +4495,7 @@ package body Exp_Disp is
-- Count the number of interface types implemented by Typ
Collect_Abstract_Interfaces (Typ, Typ_Ifaces);
Collect_Interfaces (Typ, Typ_Ifaces);
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
@ -4460,7 +4517,7 @@ package body Exp_Disp is
begin
AI := First_Elmt (Typ_Ifaces);
while Present (AI) loop
if Is_Parent (Node (AI), Typ) then
if Is_Ancestor (Node (AI), Typ) then
Sec_DT_Tag :=
New_Reference_To (DT_Ptr, Loc);
else
@ -4471,7 +4528,7 @@ package body Exp_Disp is
while Ekind (Node (Elmt)) = E_Constant
and then not
Is_Parent (Node (AI), Related_Type (Node (Elmt)))
Is_Ancestor (Node (AI), Related_Type (Node (Elmt)))
loop
pragma Assert (Has_Thunks (Node (Elmt)));
Next_Elmt (Elmt);
@ -4582,7 +4639,7 @@ package body Exp_Disp is
if Ada_Version >= Ada_05
and then Has_DT (Typ)
and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ)
and then Has_Interfaces (Typ)
and then Nb_Prim > 0
and then not Is_Abstract_Type (Typ)
and then not Is_Controlled (Typ)
@ -4999,7 +5056,7 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt);
if Is_Imported (Prim)
or else Present (Abstract_Interface_Alias (Prim))
or else Present (Interface_Alias (Prim))
or else Is_Predefined_Dispatching_Operation (Prim)
then
null;
@ -5015,7 +5072,7 @@ package body Exp_Disp is
if not Is_Predefined_Dispatching_Operation (E)
and then not Is_Abstract_Subprogram (E)
and then not Present (Abstract_Interface_Alias (E))
and then not Present (Interface_Alias (E))
then
pragma Assert
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
@ -5225,11 +5282,10 @@ package body Exp_Disp is
Copy_Secondary_DTs (Etype (Typ));
end if;
if Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List
(Abstract_Interfaces (Typ))
if Present (Interfaces (Typ))
and then not Is_Empty_Elmt_List (Interfaces (Typ))
then
Iface := First_Elmt (Abstract_Interfaces (Typ));
Iface := First_Elmt (Interfaces (Typ));
E := First_Entity (Typ);
while Present (E)
and then Present (Node (Sec_DT_Ancestor))
@ -5392,7 +5448,7 @@ package body Exp_Disp is
if Ada_Version >= Ada_05
and then Is_Concurrent_Record_Type (Typ)
and then Has_Abstract_Interfaces (Typ)
and then Has_Interfaces (Typ)
then
Append_List_To (Result,
Make_Select_Specific_Data_Table (Typ));
@ -5547,7 +5603,7 @@ package body Exp_Disp is
-- Look for primitive overriding an abstract interface subprogram
if Present (Abstract_Interface_Alias (Prim))
if Present (Interface_Alias (Prim))
and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
then
Prim_Pos := DT_Position (Alias (Prim));
@ -5626,7 +5682,7 @@ package body Exp_Disp is
-- Collect the components associated with secondary dispatch tables
if Has_Abstract_Interfaces (Typ) then
if Has_Interfaces (Typ) then
Collect_Interface_Components (Typ, Typ_Comps);
end if;
@ -5777,7 +5833,7 @@ package body Exp_Disp is
-- 2) Generate the secondary tag entities
if Has_Abstract_Interfaces (Typ) then
if Has_Interfaces (Typ) then
Suffix_Index := 0;
-- For each interface type we build an unique external name
@ -6071,7 +6127,7 @@ package body Exp_Disp is
return;
end if;
if not Present (Abstract_Interface_Alias (Prim)) then
if not Present (Interface_Alias (Prim)) then
Tag_Typ := Scope (DTC_Entity (Prim));
Pos := DT_Position (Prim);
Tag := First_Tag_Component (Tag_Typ);
@ -6128,13 +6184,13 @@ package body Exp_Disp is
else
Tag_Typ := Find_Dispatching_Type (Alias (Prim));
Iface_Typ := Find_Dispatching_Type (Abstract_Interface_Alias (Prim));
Iface_Typ := Find_Dispatching_Type (Interface_Alias (Prim));
pragma Assert (Is_Interface (Iface_Typ));
Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
if not Is_Parent (Iface_Typ, Tag_Typ)
if not Is_Ancestor (Iface_Typ, Tag_Typ)
and then Present (Thunk_Code)
then
-- Comment needed on why checks are suppressed. This is not just
@ -6151,7 +6207,7 @@ package body Exp_Disp is
Iface_DT_Ptr := Node (Iface_DT_Elmt);
pragma Assert (Has_Thunks (Iface_DT_Ptr));
Iface_Prim := Abstract_Interface_Alias (Prim);
Iface_Prim := Interface_Alias (Prim);
Pos := DT_Position (Iface_Prim);
Tag := First_Tag_Component (Iface_Typ);
L := New_List;
@ -6263,7 +6319,7 @@ package body Exp_Disp is
-- Primitive operations covering abstract interfaces are
-- allocated later
elsif Present (Abstract_Interface_Alias (Op)) then
elsif Present (Interface_Alias (Op)) then
null;
-- Predefined dispatching operations are completely safe. They
@ -6343,6 +6399,8 @@ package body Exp_Disp is
-- Start of processing for Set_All_DT_Position
begin
pragma Assert (Present (First_Tag_Component (Typ)));
-- Set the DT_Position for each primitive operation. Perform some
-- sanity checks to avoid to build completely inconsistent dispatch
-- tables.
@ -6498,17 +6556,14 @@ package body Exp_Disp is
-- Overriding primitives of ancestor abstract interfaces
elsif Present (Abstract_Interface_Alias (Prim))
and then Is_Parent
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
elsif Present (Interface_Alias (Prim))
and then Is_Ancestor
(Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
then
pragma Assert (DT_Position (Prim) = No_Uint
and then Present (DTC_Entity
(Abstract_Interface_Alias (Prim))));
and then Present (DTC_Entity (Interface_Alias (Prim))));
E := Abstract_Interface_Alias (Prim);
E := Interface_Alias (Prim);
Set_DT_Position (Prim, DT_Position (E));
pragma Assert
@ -6520,11 +6575,11 @@ package body Exp_Disp is
-- Overriding primitives must use the same entry as the
-- overridden primitive.
elsif not Present (Abstract_Interface_Alias (Prim))
elsif not Present (Interface_Alias (Prim))
and then Present (Alias (Prim))
and then Chars (Prim) = Chars (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) /= Typ
and then Is_Parent
and then Is_Ancestor
(Find_Dispatching_Type (Alias (Prim)), Typ)
and then Present (DTC_Entity (Alias (Prim)))
then
@ -6554,7 +6609,7 @@ package body Exp_Disp is
-- Primitives covering interface primitives are handled later
elsif Present (Abstract_Interface_Alias (Prim)) then
elsif Present (Interface_Alias (Prim)) then
null;
else
@ -6583,16 +6638,15 @@ package body Exp_Disp is
Prim := Node (Prim_Elmt);
if DT_Position (Prim) = No_Uint
and then Present (Abstract_Interface_Alias (Prim))
and then Present (Interface_Alias (Prim))
then
pragma Assert (Present (Alias (Prim))
and then Find_Dispatching_Type (Alias (Prim)) = Typ);
-- Check if this entry will be placed in the primary DT
if Is_Parent (Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)),
Typ)
if Is_Ancestor
(Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim, DT_Position (Alias (Prim)));
@ -6601,9 +6655,9 @@ package body Exp_Disp is
else
pragma Assert
(DT_Position (Abstract_Interface_Alias (Prim)) /= No_Uint);
(DT_Position (Interface_Alias (Prim)) /= No_Uint);
Set_DT_Position (Prim,
DT_Position (Abstract_Interface_Alias (Prim)));
DT_Position (Interface_Alias (Prim)));
end if;
end if;
@ -6666,14 +6720,16 @@ package body Exp_Disp is
-- point of declaration, but for inherited operations it must
-- be done when building the dispatch table.
-- Ada 2005 (AI-251): Hidden entities associated with abstract
-- interface primitives are not taken into account because the
-- check is done with the aliased primitive.
-- Ada 2005 (AI-251): Primitives associated with interfaces are
-- excluded from this check because interfaces must be visible in
-- the public and private part (RM 7.3 (7.3/2))
if Is_Abstract_Type (Typ)
and then Is_Abstract_Subprogram (Prim)
and then Present (Alias (Prim))
and then not Present (Abstract_Interface_Alias (Prim))
and then not Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Prim)))
and then not Present (Interface_Alias (Prim))
and then Is_Derived_Type (Typ)
and then In_Private_Part (Current_Scope)
and then
@ -6789,16 +6845,14 @@ package body Exp_Disp is
Prim : Entity_Id)
is
begin
if Present (Abstract_Interface_Alias (Prim))
if Present (Interface_Alias (Prim))
and then Is_Interface
(Find_Dispatching_Type
(Abstract_Interface_Alias (Prim)))
(Find_Dispatching_Type (Interface_Alias (Prim)))
then
Set_DTC_Entity (Prim,
Find_Interface_Tag
(T => Tagged_Type,
Iface => Find_Dispatching_Type
(Abstract_Interface_Alias (Prim))));
Iface => Find_Dispatching_Type (Interface_Alias (Prim))));
else
Set_DTC_Entity (Prim,
First_Tag_Component (Tagged_Type));
@ -6927,12 +6981,12 @@ package body Exp_Disp is
Write_Name (Chars (Scope (DTC_Entity (Alias (Prim)))));
end if;
if Present (Abstract_Interface_Alias (Prim)) then
if Present (Interface_Alias (Prim)) then
Write_Str (", AI_Alias of ");
Write_Name (Chars (Scope (DTC_Entity
(Abstract_Interface_Alias (Prim)))));
Write_Name
(Chars (Find_Dispatching_Type (Interface_Alias (Prim))));
Write_Char (':');
Write_Int (Int (Abstract_Interface_Alias (Prim)));
Write_Int (Int (Interface_Alias (Prim)));
end if;
Write_Str (")");

9
gcc/ada/exp_disp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
@ -212,6 +212,13 @@ package Exp_Disp is
-- Otherwise they are set to the defining identifier and the subprogram
-- body of the generated thunk.
function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
-- required to implement interfaces.
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place

3
gcc/ada/exp_intr.adb
View File

@ -45,6 +45,7 @@ with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@ -165,7 +166,7 @@ package body Exp_Intr is
-- If the result type is not parent of Tag_Arg then we need to
-- locate the tag of the secondary dispatch table.
if not Is_Parent (Etype (Result_Typ), Etype (Tag_Arg)) then
if not Is_Ancestor (Etype (Result_Typ), Etype (Tag_Arg)) then
pragma Assert (not Is_Interface (Etype (Tag_Arg)));
Iface_Tag :=

331
gcc/ada/exp_util.adb
View File

@ -1386,73 +1386,8 @@ package body Exp_Util is
(T : Entity_Id;
Iface : Entity_Id) return Elmt_Id
is
ADT : Elmt_Id;
Found : Boolean := False;
Typ : Entity_Id := T;
procedure Find_Secondary_Table (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
--------------------------
-- Find_Secondary_Table --
--------------------------
procedure Find_Secondary_Table (Typ : Entity_Id) is
AI_Elmt : Elmt_Id;
AI : Node_Id;
begin
pragma Assert (Typ /= Iface);
-- Climb to the ancestor (if any) handling synchronized interface
-- derivations and private types
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Secondary_Table (Etype (First (Iface_List)));
end if;
end;
elsif Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Secondary_Table (Full_View (Etype (Typ)));
end if;
elsif Etype (Typ) /= Typ then
Find_Secondary_Table (Etype (Typ));
end if;
-- Traverse the list of interfaces implemented by the type
if not Found
and then Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ))
then
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
if AI = Iface or else Is_Ancestor (Iface, AI) then
Found := True;
return;
end if;
-- Document what is going on here, why four Next's???
Next_Elmt (ADT);
Next_Elmt (ADT);
Next_Elmt (ADT);
Next_Elmt (ADT);
Next_Elmt (AI_Elmt);
end loop;
end if;
end Find_Secondary_Table;
-- Start of processing for Find_Interface_ADT
ADT : Elmt_Id;
Typ : Entity_Id := T;
begin
pragma Assert (Is_Interface (Iface));
@ -1481,11 +1416,23 @@ package body Exp_Util is
(not Is_Class_Wide_Type (Typ)
and then Ekind (Typ) /= E_Incomplete_Type);
ADT := Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
pragma Assert (Present (Node (ADT)));
Find_Secondary_Table (Typ);
pragma Assert (Found);
return ADT;
if Is_Ancestor (Iface, Typ) then
return First_Elmt (Access_Disp_Table (Typ));
else
ADT :=
Next_Elmt (Next_Elmt (First_Elmt (Access_Disp_Table (Typ))));
while Present (ADT)
and then Present (Related_Type (Node (ADT)))
and then Related_Type (Node (ADT)) /= Iface
and then not Is_Ancestor (Iface, Related_Type (Node (ADT)))
loop
Next_Elmt (ADT);
end loop;
pragma Assert (Present (Related_Type (Node (ADT))));
return ADT;
end if;
end Find_Interface_ADT;
------------------------
@ -1500,14 +1447,6 @@ package body Exp_Util is
Found : Boolean := False;
Typ : Entity_Id := T;
Is_Primary_Tag : Boolean := False;
Is_Sync_Typ : Boolean := False;
-- In case of non concurrent-record-types each parent-type has the
-- tags associated with the interface types that are not implemented
-- by the ancestors; concurrent-record-types have their whole list of
-- interface tags (and this case requires some special management).
procedure Find_Tag (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
@ -1524,32 +1463,15 @@ package body Exp_Util is
-- therefore shares the main tag.
if Typ = Iface then
if Is_Sync_Typ then
Is_Primary_Tag := True;
else
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
end if;
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := First_Tag_Component (Typ);
Found := True;
return;
end if;
-- Handle synchronized interface derivations
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Tag (Etype (First (Iface_List)));
end if;
end;
-- Climb to the root type handling private types
elsif Present (Full_View (Etype (Typ))) then
if Present (Full_View (Etype (Typ))) then
if Full_View (Etype (Typ)) /= Typ then
Find_Tag (Full_View (Etype (Typ)));
end if;
@ -1561,19 +1483,16 @@ package body Exp_Util is
-- Traverse the list of interfaces implemented by the type
if not Found
and then Present (Abstract_Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
and then Present (Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Interfaces (Typ)))
then
-- Skip the tag associated with the primary table
if not Is_Sync_Typ then
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
end if;
pragma Assert (Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
AI_Elmt := First_Elmt (Interfaces (Typ));
while Present (AI_Elmt) loop
AI := Node (AI_Elmt);
@ -1624,149 +1543,10 @@ package body Exp_Util is
Typ := Non_Limited_View (Typ);
end if;
if not Is_Concurrent_Record_Type (Typ) then
Find_Tag (Typ);
pragma Assert (Found);
return AI_Tag;
-- Concurrent record types
else
Is_Sync_Typ := True;
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
Find_Tag (Typ);
pragma Assert (Found);
if Is_Primary_Tag then
return First_Tag_Component (Typ);
else
return AI_Tag;
end if;
end if;
end Find_Interface_Tag;
--------------------
-- Find_Interface --
--------------------
function Find_Interface
(T : Entity_Id;
Comp : Entity_Id) return Entity_Id
is
AI_Tag : Entity_Id;
Found : Boolean := False;
Iface : Entity_Id;
Typ : Entity_Id := T;
Is_Sync_Typ : Boolean := False;
-- In case of non concurrent-record-types each parent-type has the
-- tags associated with the interface types that are not implemented
-- by the ancestors; concurrent-record-types have their whole list of
-- interface tags (and this case requires some special management).
procedure Find_Iface (Typ : Entity_Id);
-- Internal subprogram used to recursively climb to the ancestors
----------------
-- Find_Iface --
----------------
procedure Find_Iface (Typ : Entity_Id) is
AI_Elmt : Elmt_Id;
begin
-- Climb to the root type
-- Handle synchronized interface derivations
if Is_Concurrent_Record_Type (Typ) then
declare
Iface_List : constant List_Id := Abstract_Interface_List (Typ);
begin
if Is_Non_Empty_List (Iface_List) then
Find_Iface (Etype (First (Iface_List)));
end if;
end;
-- Handle the common case
elsif Etype (Typ) /= Typ then
pragma Assert (not Present (Full_View (Etype (Typ))));
Find_Iface (Etype (Typ));
end if;
-- Traverse the list of interfaces implemented by the type
if not Found
and then Present (Abstract_Interfaces (Typ))
and then not (Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then
-- Skip the tag associated with the primary table
if not Is_Sync_Typ then
pragma Assert
(Etype (First_Tag_Component (Typ)) = RTE (RE_Tag));
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
pragma Assert (Present (AI_Tag));
end if;
AI_Elmt := First_Elmt (Abstract_Interfaces (Typ));
while Present (AI_Elmt) loop
if AI_Tag = Comp then
Iface := Node (AI_Elmt);
Found := True;
return;
end if;
AI_Tag := Next_Tag_Component (AI_Tag);
Next_Elmt (AI_Elmt);
end loop;
end if;
end Find_Iface;
-- Start of processing for Find_Interface
begin
-- Handle private types
if Has_Private_Declaration (Typ)
and then Present (Full_View (Typ))
then
Typ := Full_View (Typ);
end if;
-- Handle access types
if Is_Access_Type (Typ) then
Typ := Directly_Designated_Type (Typ);
end if;
-- Handle task and protected types implementing interfaces
if Is_Concurrent_Type (Typ) then
Typ := Corresponding_Record_Type (Typ);
end if;
if Is_Class_Wide_Type (Typ) then
Typ := Etype (Typ);
end if;
-- Handle entities from the limited view
if Ekind (Typ) = E_Incomplete_Type then
pragma Assert (Present (Non_Limited_View (Typ)));
Typ := Non_Limited_View (Typ);
end if;
if Is_Concurrent_Record_Type (Typ) then
Is_Sync_Typ := True;
AI_Tag := Next_Tag_Component (First_Tag_Component (Typ));
end if;
Find_Iface (Typ);
Find_Tag (Typ);
pragma Assert (Found);
return Iface;
end Find_Interface;
return AI_Tag;
end Find_Interface_Tag;
------------------
-- Find_Prim_Op --
@ -3062,55 +2842,6 @@ package body Exp_Util is
and then Is_Library_Level_Entity (Typ);
end Is_Library_Level_Tagged_Type;
-----------------------------------------
-- Is_Predefined_Dispatching_Operation --
-----------------------------------------
function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean
is
TSS_Name : TSS_Name_Type;
begin
if not Is_Dispatching_Operation (E) then
return False;
end if;
Get_Name_String (Chars (E));
-- Most predefined primitives have internally generated names. Equality
-- must be treated differently; the predefined operation is recognized
-- as a homogeneous binary operator that returns Boolean.
if Name_Len > TSS_Name_Type'Last then
TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
.. Name_Len));
if Chars (E) = Name_uSize
or else Chars (E) = Name_uAlignment
or else TSS_Name = TSS_Stream_Read
or else TSS_Name = TSS_Stream_Write
or else TSS_Name = TSS_Stream_Input
or else TSS_Name = TSS_Stream_Output
or else
(Chars (E) = Name_Op_Eq
and then Etype (First_Entity (E)) = Etype (Last_Entity (E)))
or else Chars (E) = Name_uAssign
or else TSS_Name = TSS_Deep_Adjust
or else TSS_Name = TSS_Deep_Finalize
or else (Ada_Version >= Ada_05
and then (Chars (E) = Name_uDisp_Asynchronous_Select
or else Chars (E) = Name_uDisp_Conditional_Select
or else Chars (E) = Name_uDisp_Get_Prim_Op_Kind
or else Chars (E) = Name_uDisp_Get_Task_Id
or else Chars (E) = Name_uDisp_Requeue
or else Chars (E) = Name_uDisp_Timed_Select))
then
return True;
end if;
end if;
return False;
end Is_Predefined_Dispatching_Operation;
----------------------------------
-- Is_Possibly_Unaligned_Object --
----------------------------------

10
gcc/ada/exp_util.ads
View File

@ -342,13 +342,6 @@ package Exp_Util is
-- declarations and/or allocations when the type is indefinite (including
-- class-wide).
function Find_Interface
(T : Entity_Id;
Comp : Entity_Id) return Entity_Id;
-- Ada 2005 (AI-251): Given a tagged type and one of its components
-- associated with the secondary dispatch table of an abstract interface
-- type, return the associated abstract interface type.
function Find_Interface_ADT
(T : Entity_Id;
Iface : Entity_Id) return Elmt_Id;
@ -462,9 +455,6 @@ package Exp_Util is
-- Return True if Typ is a library level tagged type. Currently we use
-- this information to build statically allocated dispatch tables.
function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
function Is_Ref_To_Bit_Packed_Array (N : Node_Id) return Boolean;
-- Determine whether the node P is a reference to a bit packed array, i.e.
-- whether the designated object is a component of a bit packed array, or a

1
gcc/ada/freeze.adb
View File

@ -30,6 +30,7 @@ with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;

12
gcc/ada/lib-xref.adb
View File

@ -1150,16 +1150,14 @@ package body Lib.Xref is
New_Entry (Tref);
if Is_Record_Type (Ent)
and then Present (Abstract_Interfaces (Ent))
and then Present (Interfaces (Ent))
then
-- Add an entry for each one of the given interfaces
-- implemented by type Ent.
declare
Elmt : Elmt_Id;
Elmt : Elmt_Id := First_Elmt (Interfaces (Ent));
begin
Elmt := First_Elmt (Abstract_Interfaces (Ent));
while Present (Elmt) loop
New_Entry (Node (Elmt));
Next_Elmt (Elmt);
@ -2032,13 +2030,11 @@ package body Lib.Xref is
-- Additional information for types with progenitors
if Is_Record_Type (XE.Ent)
and then Present (Abstract_Interfaces (XE.Ent))
and then Present (Interfaces (XE.Ent))
then
declare
Elmt : Elmt_Id;
Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
begin
Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
while Present (Elmt) loop
Check_Type_Reference (Node (Elmt), True);
Next_Elmt (Elmt);

2
gcc/ada/sem_cat.adb
View File

@ -28,7 +28,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Util; use Exp_Util;
with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Lib; use Lib;
with Namet; use Namet;

7
gcc/ada/sem_ch12.adb
View File

@ -9268,7 +9268,7 @@ package body Sem_Ch12 is
-- Now verify that the actual includes all other ancestors of
-- the formal.
Elmt := First_Elmt (Abstract_Interfaces (A_Gen_T));
Elmt := First_Elmt (Interfaces (A_Gen_T));
while Present (Elmt) loop
if not Interface_Present_In_Ancestor
(Act_T, Get_Instance_Of (Node (Elmt)))
@ -9575,7 +9575,6 @@ package body Sem_Ch12 is
function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean
is
Interfaces : Elist_Id;
Intfc_Elmt : Elmt_Id;
begin
@ -9599,9 +9598,7 @@ package body Sem_Ch12 is
-- progenitors.
else
Interfaces := Abstract_Interfaces (T2);
Intfc_Elmt := First_Elmt (Interfaces);
Intfc_Elmt := First_Elmt (Interfaces (T2));
while Present (Intfc_Elmt) loop
if Is_Ancestor (T1, Node (Intfc_Elmt)) then
return True;

1459
gcc/ada/sem_ch3.adb
View File

File diff suppressed because it is too large Load Diff

2
gcc/ada/sem_ch3.ads
View File

@ -26,7 +26,7 @@
with Nlists; use Nlists;
with Types; use Types;
package Sem_Ch3 is
package Sem_Ch3 is
procedure Analyze_Component_Declaration (N : Node_Id);
procedure Analyze_Incomplete_Type_Decl (N : Node_Id);
procedure Analyze_Itype_Reference (N : Node_Id);

13
gcc/ada/sem_ch4.adb
View File

@ -3525,7 +3525,6 @@ package body Sem_Ch4 is
Error_Msg_NE ("no selector& for}", N, Sel);
Check_Misspelled_Selector (Type_To_Use, Sel);
end if;
Set_Entity (Sel, Any_Id);
@ -6443,14 +6442,14 @@ package body Sem_Ch4 is
-- primitive is also in this list of primitive operations and
-- will be used instead.
if (Present (Abstract_Interface_Alias (Prim_Op))
and then Is_Ancestor (Find_Dispatching_Type
(Alias (Prim_Op)), Corr_Type))
if (Present (Interface_Alias (Prim_Op))
and then Is_Ancestor (Find_Dispatching_Type
(Alias (Prim_Op)), Corr_Type))
or else
-- Do not consider hidden primitives unless the type is in an
-- open scope or we are within an instance, where visibility
-- is known to be correct.
-- Do not consider hidden primitives unless the type is
-- in an open scope or we are within an instance, where
-- visibility is known to be correct.
(Is_Hidden (Prim_Op)
and then not Is_Immediately_Visible (Obj_Type)

236
gcc/ada/sem_ch6.adb
View File

@ -33,6 +33,7 @@ with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
@ -1827,7 +1828,7 @@ package body Sem_Ch6 is
and then Ekind (Etype (First_Entity (Spec_Id))) = E_Record_Type
and then Is_Tagged_Type (Etype (First_Entity (Spec_Id)))
and then
Present (Abstract_Interfaces (Etype (First_Entity (Spec_Id))))
Present (Interfaces (Etype (First_Entity (Spec_Id))))
and then
Present
(Corresponding_Concurrent_Type
@ -2471,8 +2472,8 @@ package body Sem_Ch6 is
if (Ekind (Formal_Typ) = E_Protected_Type
or else Ekind (Formal_Typ) = E_Task_Type)
and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Abstract_Interfaces
(Corresponding_Record_Type (Formal_Typ)))
and then Present (Interfaces
(Corresponding_Record_Type (Formal_Typ)))
then
Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ));
@ -3506,18 +3507,9 @@ package body Sem_Ch6 is
-----------------------
procedure Check_Conventions (Typ : Entity_Id) is
Ifaces_List : Elist_Id;
function Skip_Check (Op : Entity_Id) return Boolean;
pragma Inline (Skip_Check);
-- A small optimization: skip the predefined dispatching operations,
-- since they always have the same convention. Also do not consider
-- abstract primitives since those are left by an erroneous overriding.
-- This function returns True for any operation that is thus exempted
-- exempted from checking.
procedure Check_Convention
(Op : Entity_Id;
Search_From : Elmt_Id);
procedure Check_Convention (Op : Entity_Id);
-- Verify that the convention of inherited dispatching operation Op is
-- consistent among all subprograms it overrides. In order to minimize
-- the search, Search_From is utilized to designate a specific point in
@ -3527,89 +3519,62 @@ package body Sem_Ch6 is
-- Check_Convention --
----------------------
procedure Check_Convention
(Op : Entity_Id;
Search_From : Elmt_Id)
is
procedure Error_Msg_Operation (Op : Entity_Id);
-- Emit a continuation to an error message depicting the kind, name,
-- convention and source location of subprogram Op.
procedure Check_Convention (Op : Entity_Id) is
Iface_Elmt : Elmt_Id;
Iface_Prim_Elmt : Elmt_Id;
Iface_Prim : Entity_Id;
-------------------------
-- Error_Msg_Operation --
-------------------------
begin
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
Iface_Prim_Elmt :=
First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
while Present (Iface_Prim_Elmt) loop
Iface_Prim := Node (Iface_Prim_Elmt);
procedure Error_Msg_Operation (Op : Entity_Id) is
begin
Error_Msg_Name_1 := Chars (Op);
if Is_Interface_Conformant (Typ, Iface_Prim, Op)
and then Convention (Iface_Prim) /= Convention (Op)
then
Error_Msg_N
("inconsistent conventions in primitive operations", Typ);
-- Error messages of primitive subprograms do not contain a
-- convention attribute since the convention may have been first
-- inherited from a parent subprogram, then changed by a pragma.
Error_Msg_Name_1 := Chars (Op);
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
Error_Msg_Sloc := Sloc (Op);
if Comes_From_Source (Op) then
Error_Msg_Sloc := Sloc (Op);
Error_Msg_N
("\ primitive % defined #", Typ);
if Comes_From_Source (Op) then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
else
Error_Msg_N ("\\overridding operation % with " &
"convention % defined #", Typ);
end if;
else
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
else pragma Assert (Present (Alias (Op)));
Error_Msg_Sloc := Sloc (Alias (Op));
Error_Msg_N ("\\inherited operation % with " &
"convention % defined #", Typ);
end if;
if Present (Abstract_Interface_Alias (Op)) then
Error_Msg_Sloc := Sloc (Abstract_Interface_Alias (Op));
Error_Msg_Name_1 := Chars (Op);
Error_Msg_Name_2 :=
Get_Convention_Name (Convention (Iface_Prim));
Error_Msg_Sloc := Sloc (Iface_Prim);
Error_Msg_N ("\\overridden operation % with " &
"convention % defined #", Typ);
else pragma Assert (Present (Alias (Op)));
Error_Msg_Sloc := Sloc (Alias (Op));
Error_Msg_N ("\\inherited operation % with " &
"convention % defined #", Typ);
-- Avoid cascading errors
return;
end if;
end if;
end Error_Msg_Operation;
-- Local variables
Next_Elmt (Iface_Prim_Elmt);
end loop;
Second_Prim_Op : Entity_Id;
Second_Prim_Op_Elmt : Elmt_Id;
-- Start of processing for Check_Convention
begin
Second_Prim_Op_Elmt := Next_Elmt (Search_From);
while Present (Second_Prim_Op_Elmt) loop
Second_Prim_Op := Node (Second_Prim_Op_Elmt);
if not Skip_Check (Second_Prim_Op)
and then Chars (Second_Prim_Op) = Chars (Op)
and then Type_Conformant (Second_Prim_Op, Op)
and then Convention (Second_Prim_Op) /= Convention (Op)
then
Error_Msg_N
("inconsistent conventions in primitive operations", Typ);
Error_Msg_Operation (Op);
Error_Msg_Operation (Second_Prim_Op);
-- Avoid cascading errors
return;
end if;
Next_Elmt (Second_Prim_Op_Elmt);
Next_Elmt (Iface_Elmt);
end loop;
end Check_Convention;
----------------
-- Skip_Check --
----------------
function Skip_Check (Op : Entity_Id) return Boolean is
begin
return Is_Predefined_Dispatching_Operation (Op)
or else Is_Abstract_Subprogram (Op);
end Skip_Check;
-- Local variables
Prim_Op : Entity_Id;
@ -3618,6 +3583,12 @@ package body Sem_Ch6 is
-- Start of processing for Check_Conventions
begin
if not Has_Interfaces (Typ) then
return;
end if;
Collect_Interfaces (Typ, Ifaces_List);
-- The algorithm checks every overriding dispatching operation against
-- all the corresponding overridden dispatching operations, detecting
-- differences in conventions.
@ -3627,13 +3598,10 @@ package body Sem_Ch6 is
Prim_Op := Node (Prim_Op_Elmt);
-- A small optimization: skip the predefined dispatching operations
-- since they always have the same convention. Also avoid processing
-- of abstract primitives left from an erroneous overriding.
-- since they always have the same convention.
if not Skip_Check (Prim_Op) then
Check_Convention
(Op => Prim_Op,
Search_From => Prim_Op_Elmt);
if not Is_Predefined_Dispatching_Operation (Prim_Op) then
Check_Convention (Prim_Op);
end if;
Next_Elmt (Prim_Op_Elmt);
@ -4497,15 +4465,17 @@ package body Sem_Ch6 is
------------------------------
procedure Check_Subtype_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Err_Loc : Node_Id := Empty)
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Err_Loc : Node_Id := Empty;
Skip_Controlling_Formals : Boolean := False)
is
Result : Boolean;
pragma Warnings (Off, Result);
begin
Check_Conformance
(New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc);
(New_Id, Old_Id, Subtype_Conformant, True, Result, Err_Loc,
Skip_Controlling_Formals => Skip_Controlling_Formals);
end Check_Subtype_Conformant;
---------------------------
@ -5795,6 +5765,76 @@ package body Sem_Ch6 is
end loop;
end Install_Formals;
-----------------------------
-- Is_Interface_Conformant --
-----------------------------
function Is_Interface_Conformant
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id;
Prim : Entity_Id) return Boolean
is
begin
pragma Assert (Is_Subprogram (Iface_Prim)
and then Is_Subprogram (Prim)
and then Is_Dispatching_Operation (Iface_Prim)
and then Is_Dispatching_Operation (Prim));
pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
or else (Present (Alias (Iface_Prim))
and then
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
if Prim = Iface_Prim
or else not Is_Subprogram (Prim)
or else Ekind (Prim) /= Ekind (Iface_Prim)
or else not Is_Dispatching_Operation (Prim)
or else Scope (Prim) /= Scope (Tagged_Type)
or else No (Find_Dispatching_Type (Prim))
or else Base_Type (Find_Dispatching_Type (Prim)) /= Tagged_Type
or else not Primitive_Names_Match (Iface_Prim, Prim)
then
return False;
-- Case of a procedure, or a function not returning an interface
elsif Ekind (Iface_Prim) = E_Procedure
or else Etype (Prim) = Etype (Iface_Prim)
or else not Is_Interface (Etype (Iface_Prim))
then
return Type_Conformant (Prim, Iface_Prim,
Skip_Controlling_Formals => True);
-- Case of a function returning an interface
elsif Implements_Interface (Etype (Prim), Etype (Iface_Prim)) then
declare
Ret_Typ : constant Entity_Id := Etype (Prim);
Is_Conformant : Boolean;
begin
-- Temporarly set both entities returning exactly the same type to
-- be able to call Type_Conformant (because that routine has no
-- machinery to handle interfaces).
Set_Etype (Prim, Etype (Iface_Prim));
Is_Conformant :=
Type_Conformant (Prim, Iface_Prim,
Skip_Controlling_Formals => True);
-- Restore proper decoration of returned type
Set_Etype (Prim, Ret_Typ);
return Is_Conformant;
end;
end if;
return False;
end Is_Interface_Conformant;
---------------------------------
-- Is_Non_Overriding_Operation --
---------------------------------
@ -6422,7 +6462,7 @@ package body Sem_Ch6 is
N_Task_Type_Declaration,
N_Protected_Type_Declaration)
then
Collect_Abstract_Interfaces (Typ, Ifaces_List);
Collect_Interfaces (Typ, Ifaces_List);
if not Is_Empty_Elmt_List (Ifaces_List) then
Overridden_Subp :=
@ -6555,7 +6595,6 @@ package body Sem_Ch6 is
and then Is_Dispatching_Operation (Alias (S))
and then Present (Find_Dispatching_Type (Alias (S)))
and then Is_Interface (Find_Dispatching_Type (Alias (S)))
and then not Is_Predefined_Dispatching_Operation (Alias (S))
then
goto Add_New_Entity;
end if;
@ -7669,10 +7708,15 @@ package body Sem_Ch6 is
-- Subtype_Conformant --
------------------------
function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean is
function Subtype_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Skip_Controlling_Formals : Boolean := False) return Boolean
is
Result : Boolean;
begin
Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result);
Check_Conformance (New_Id, Old_Id, Subtype_Conformant, False, Result,
Skip_Controlling_Formals => Skip_Controlling_Formals);
return Result;
end Subtype_Conformant;

20
gcc/ada/sem_ch6.ads
View File

@ -111,9 +111,10 @@ package Sem_Ch6 is
-- Is_Primitive indicates whether the subprogram is primitive.
procedure Check_Subtype_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Err_Loc : Node_Id := Empty);
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Err_Loc : Node_Id := Empty;
Skip_Controlling_Formals : Boolean := False);
-- Check that two callable entities (subprograms, entries, literals)
-- are subtype conformant, post error message if not (RM 6.3.1(16))
-- the flag being placed on the Err_Loc node if it is specified, and
@ -173,6 +174,14 @@ package Sem_Ch6 is
-- procedure is also used to get visibility to the formals when analyzing
-- preconditions and postconditions appearing in the spec.
function Is_Interface_Conformant
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id;
Prim : Entity_Id) return Boolean;
-- Returns true if both primitives have a matching name and they are also
-- type conformant. Special management is done for functions returning
-- interfaces.
function Mode_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are mode conformant (RM 6.3.1(15))
@ -212,7 +221,10 @@ package Sem_Ch6 is
procedure Set_Formal_Mode (Formal_Id : Entity_Id);
-- Set proper Ekind to reflect formal mode (in, out, in out)
function Subtype_Conformant (New_Id, Old_Id : Entity_Id) return Boolean;
function Subtype_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
Skip_Controlling_Formals : Boolean := False) return Boolean;
-- Determine whether two callable entities (subprograms, entries,
-- literals) are subtype conformant (RM6.3.1(16)).

8
gcc/ada/sem_ch9.adb
View File

@ -2417,16 +2417,16 @@ package body Sem_Ch9 is
if Present (Interface_List (N))
or else (Is_Tagged_Type (Priv_T)
and then Has_Abstract_Interfaces
(Priv_T, Use_Full_View => False))
and then Has_Interfaces
(Priv_T, Use_Full_View => False))
then
if Is_Tagged_Type (Priv_T) then
Collect_Abstract_Interfaces
Collect_Interfaces
(Priv_T, Priv_T_Ifaces, Use_Full_View => False);
end if;
if Is_Tagged_Type (T) then
Collect_Abstract_Interfaces (T, Full_T_Ifaces);
Collect_Interfaces (T, Full_T_Ifaces);
end if;
Iface := Find_Hidden_Interface (Priv_T_Ifaces, Full_T_Ifaces);

141
gcc/ada/sem_disp.adb
View File

@ -618,6 +618,19 @@ package body Sem_Disp is
Tagged_Type := Corresponding_Record_Type (Tagged_Type);
end if;
-- (AI-345): The task body procedure is not a primitive of the tagged
-- type
if Present (Tagged_Type)
and then Is_Concurrent_Record_Type (Tagged_Type)
and then Present (Corresponding_Concurrent_Type (Tagged_Type))
and then Is_Task_Type (Corresponding_Concurrent_Type (Tagged_Type))
and then Subp = Get_Task_Body_Procedure
(Corresponding_Concurrent_Type (Tagged_Type))
then
return;
end if;
-- If Subp is derived from a dispatching operation then it should
-- always be treated as dispatching. In this case various checks
-- below will be bypassed. Makes sure that late declarations for
@ -870,6 +883,10 @@ package body Sem_Disp is
-- Now it should be a correct primitive operation, put it in the list
if Present (Old_Subp) then
-- If the type has interfaces we complete this check after we
-- set attribute Is_Dispatching_Operation
Check_Subtype_Conformant (Subp, Old_Subp);
if (Chars (Subp) = Name_Initialize
@ -902,7 +919,7 @@ package body Sem_Disp is
Prim := Node (Elmt);
if Present (Alias (Prim))
and then Present (Abstract_Interface_Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Subp
then
Register_Primitive (Sloc (Prim),
@ -933,6 +950,78 @@ package body Sem_Disp is
Set_Is_Dispatching_Operation (Subp, True);
-- Ada 2005 (AI-251): If the type implements interfaces we must check
-- subtype conformance against all the interfaces covered by this
-- primitive.
if Present (Old_Subp)
and then Has_Interfaces (Tagged_Type)
then
declare
Ifaces_List : Elist_Id;
Iface_Elmt : Elmt_Id;
Iface_Prim_Elmt : Elmt_Id;
Iface_Prim : Entity_Id;
Ret_Typ : Entity_Id;
begin
Collect_Interfaces (Tagged_Type, Ifaces_List);
Iface_Elmt := First_Elmt (Ifaces_List);
while Present (Iface_Elmt) loop
if not Is_Ancestor (Node (Iface_Elmt), Tagged_Type) then
Iface_Prim_Elmt :=
First_Elmt (Primitive_Operations (Node (Iface_Elmt)));
while Present (Iface_Prim_Elmt) loop
Iface_Prim := Node (Iface_Prim_Elmt);
if Is_Interface_Conformant
(Tagged_Type, Iface_Prim, Subp)
then
-- Handle procedures, functions whose return type
-- matches, or functions not returning interfaces
if Ekind (Subp) = E_Procedure
or else Etype (Iface_Prim) = Etype (Subp)
or else not Is_Interface (Etype (Iface_Prim))
then
Check_Subtype_Conformant
(New_Id => Subp,
Old_Id => Iface_Prim,
Err_Loc => Subp,
Skip_Controlling_Formals => True);
-- Handle functions returning interfaces
elsif Implements_Interface
(Etype (Subp), Etype (Iface_Prim))
then
-- Temporarily force both entities to return the
-- same type. Required because Subtype_Conformant
-- does not handle this case.
Ret_Typ := Etype (Iface_Prim);
Set_Etype (Iface_Prim, Etype (Subp));
Check_Subtype_Conformant
(New_Id => Subp,
Old_Id => Iface_Prim,
Err_Loc => Subp,
Skip_Controlling_Formals => True);
Set_Etype (Iface_Prim, Ret_Typ);
end if;
end if;
Next_Elmt (Iface_Prim_Elmt);
end loop;
end if;
Next_Elmt (Iface_Elmt);
end loop;
end;
end if;
if not Body_Is_Last_Primitive then
Set_DT_Position (Subp, No_Uint);
@ -1083,7 +1172,13 @@ package body Sem_Disp is
if Derives_From (Node (Op1)) then
if No (Prev) then
Prepend_Elmt (Subp, New_Prim);
-- Avoid adding it to the list of primitives if already there!
if Node (Op2) /= Subp then
Prepend_Elmt (Subp, New_Prim);
end if;
else
Insert_Elmt_After (Subp, Prev);
end if;
@ -1302,6 +1397,38 @@ package body Sem_Disp is
return Empty;
end Find_Dispatching_Type;
---------------------------------------
-- Find_Primitive_Covering_Interface --
---------------------------------------
function Find_Primitive_Covering_Interface
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id
is
E : Entity_Id;
begin
pragma Assert (Is_Interface (Find_Dispatching_Type (Iface_Prim))
or else (Present (Alias (Iface_Prim))
and then
Is_Interface
(Find_Dispatching_Type (Ultimate_Alias (Iface_Prim)))));
E := Current_Entity (Iface_Prim);
while Present (E) loop
if Is_Subprogram (E)
and then Is_Dispatching_Operation (E)
and then Is_Interface_Conformant (Tagged_Type, Iface_Prim, E)
then
return E;
end if;
E := Homonym (E);
end loop;
return Empty;
end Find_Primitive_Covering_Interface;
---------------------------
-- Is_Dynamically_Tagged --
---------------------------
@ -1425,7 +1552,7 @@ package body Sem_Disp is
Replace_Elmt (Elmt, New_Op);
if Ada_Version >= Ada_05
and then Has_Abstract_Interfaces (Tagged_Type)
and then Has_Interfaces (Tagged_Type)
then
-- Ada 2005 (AI-251): Update the attribute alias of all the aliased
-- entities of the overridden primitive to reference New_Op, and also
@ -1434,6 +1561,8 @@ package body Sem_Disp is
-- operations that it implements (for operations inherited from the
-- parent itself, this check is made when building the derived type).
-- Note: This code is only executed in case of late overriding
Elmt := First_Elmt (Primitive_Operations (Tagged_Type));
while Present (Elmt) loop
Prim := Node (Elmt);
@ -1445,14 +1574,14 @@ package body Sem_Disp is
-- reading attributes in entities that are not yet fully decorated
elsif Is_Subprogram (Prim)
and then Present (Abstract_Interface_Alias (Prim))
and then Present (Interface_Alias (Prim))
and then Alias (Prim) = Prev_Op
and then Present (Etype (New_Op))
then
Set_Alias (Prim, New_Op);
Check_Subtype_Conformant (New_Op, Prim);
Set_Is_Abstract_Subprogram
(Prim, Is_Abstract_Subprogram (New_Op));
Set_Is_Abstract_Subprogram (Prim,
Is_Abstract_Subprogram (New_Op));
-- Ensure that this entity will be expanded to fill the
-- corresponding entry in its dispatch table.

10
gcc/ada/sem_disp.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2008, 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- --
@ -69,6 +69,14 @@ package Sem_Disp is
-- Check whether a subprogram is dispatching, and find the tagged
-- type of the controlling argument or arguments.
function Find_Primitive_Covering_Interface
(Tagged_Type : Entity_Id;
Iface_Prim : Entity_Id) return Entity_Id;
-- Search in the homonym chain for the primitive of Tagged_Type that
-- covers Iface_Prim. The homonym chain traversal is required to catch
-- primitives associated with the partial view of private types when
-- processing the corresponding full view.
function Is_Dynamically_Tagged (N : Node_Id) return Boolean;
-- Used to determine whether a call is dispatching, i.e. if is an
-- an expression of a class_Wide type, or a call to a function with

24
gcc/ada/sem_type.adb
View File

@ -421,7 +421,7 @@ package body Sem_Type is
elsif Is_Hidden (E)
and then Is_Subprogram (E)
and then Present (Abstract_Interface_Alias (E))
and then Present (Interface_Alias (E))
then
-- Ada 2005 (AI-251): If this primitive operation corresponds with
-- an immediate ancestor interface there is no need to add it to the
@ -431,10 +431,10 @@ package body Sem_Type is
-- subprograms which are in fact the same.
if not Is_Ancestor
(Find_Dispatching_Type (Abstract_Interface_Alias (E)),
(Find_Dispatching_Type (Interface_Alias (E)),
Find_Dispatching_Type (E))
then
Add_One_Interp (N, Abstract_Interface_Alias (E), T);
Add_One_Interp (N, Interface_Alias (E), T);
end if;
return;
@ -783,7 +783,7 @@ package body Sem_Type is
-- Literals are compatible with types in a given "class"
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
elsif (T2 = Universal_Integer and then Is_Integer_Type (T1))
or else (T2 = Universal_Real and then Is_Real_Type (T1))
or else (T2 = Universal_Fixed and then Is_Fixed_Point_Type (T1))
or else (T2 = Any_Fixed and then Is_Fixed_Point_Type (T1))
@ -849,9 +849,9 @@ package body Sem_Type is
-- Note: test for presence of E is defense against previous error.
if Present (E)
and then Present (Abstract_Interfaces (E))
and then Present (Interfaces (E))
then
Elmt := First_Elmt (Abstract_Interfaces (E));
Elmt := First_Elmt (Interfaces (E));
while Present (Elmt) loop
if Is_Ancestor (Etype (T1), Node (Elmt)) then
return True;
@ -1032,7 +1032,7 @@ package body Sem_Type is
return True;
elsif Is_Type (T1)
and then Is_Generic_Actual_Type (T1)
and then Is_Generic_Actual_Type (T1)
and then Full_View_Covers (T2, T1)
then
return True;
@ -2251,11 +2251,11 @@ package body Sem_Type is
end if;
loop
if Present (Abstract_Interfaces (E))
and then Present (Abstract_Interfaces (E))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (E))
if Present (Interfaces (E))
and then Present (Interfaces (E))
and then not Is_Empty_Elmt_List (Interfaces (E))
then
Elmt := First_Elmt (Abstract_Interfaces (E));
Elmt := First_Elmt (Interfaces (E));
while Present (Elmt) loop
AI := Node (Elmt);
@ -2334,7 +2334,7 @@ package body Sem_Type is
if Etype (AI) = Iface_Typ then
return True;
elsif Present (Abstract_Interfaces (Etype (AI)))
elsif Present (Interfaces (Etype (AI)))
and then Iface_Present_In_Ancestor (Etype (AI))
then
return True;

444
gcc/ada/sem_util.adb
View File

@ -29,6 +29,7 @@ with Checks; use Checks;
with Debug; use Debug;
with Errout; use Errout;
with Elists; use Elists;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
@ -1235,48 +1236,20 @@ package body Sem_Util is
end if;
end Check_VMS;
---------------------------------
-- Collect_Abstract_Interfaces --
---------------------------------
------------------------
-- Collect_Interfaces --
------------------------
procedure Collect_Abstract_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Exclude_Parent_Interfaces : Boolean := False;
Use_Full_View : Boolean := True)
procedure Collect_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Exclude_Parents : Boolean := False;
Use_Full_View : Boolean := True)
is
procedure Add_Interface (Iface : Entity_Id);
-- Add the interface it if is not already in the list
procedure Collect (Typ : Entity_Id);
-- Subsidiary subprogram used to traverse the whole list
-- of directly and indirectly implemented interfaces
function Interface_Present_In_Parent
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean;
-- Typ must be a tagged record type/subtype and Iface must be an
-- abstract interface type. This function is used to check if Typ
-- or some parent of Typ implements Iface.
-------------------
-- Add_Interface --
-------------------
procedure Add_Interface (Iface : Entity_Id) is
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Ifaces_List);
while Present (Elmt) and then Node (Elmt) /= Iface loop
Next_Elmt (Elmt);
end loop;
if No (Elmt) then
Append_Elmt (Iface, Ifaces_List);
end if;
end Add_Interface;
-------------
-- Collect --
-------------
@ -1284,7 +1257,6 @@ package body Sem_Util is
procedure Collect (Typ : Entity_Id) is
Ancestor : Entity_Id;
Full_T : Entity_Id;
Iface_List : List_Id;
Id : Node_Id;
Iface : Entity_Id;
@ -1300,27 +1272,10 @@ package body Sem_Util is
Full_T := Full_View (Typ);
end if;
Iface_List := Abstract_Interface_List (Full_T);
-- Include the ancestor if we are generating the whole list of
-- abstract interfaces.
-- In concurrent types the ancestor interface (if any) is the
-- first element of the list of interface types.
if Is_Concurrent_Type (Full_T)
or else Is_Concurrent_Record_Type (Full_T)
then
if Is_Non_Empty_List (Iface_List) then
Ancestor := Etype (First (Iface_List));
Collect (Ancestor);
if not Exclude_Parent_Interfaces then
Add_Interface (Ancestor);
end if;
end if;
elsif Etype (Full_T) /= Typ
if Etype (Full_T) /= Typ
-- Protect the frontend against wrong sources. For example:
@ -1339,27 +1294,16 @@ package body Sem_Util is
Collect (Ancestor);
if Is_Interface (Ancestor)
and then not Exclude_Parent_Interfaces
and then not Exclude_Parents
then
Add_Interface (Ancestor);
Append_Unique_Elmt (Ancestor, Ifaces_List);
end if;
end if;
-- Traverse the graph of ancestor interfaces
if Is_Non_Empty_List (Iface_List) then
Id := First (Iface_List);
-- In concurrent types the ancestor interface (if any) is the
-- first element of the list of interface types and we have
-- already processed them while climbing to the root type.
if Is_Concurrent_Type (Full_T)
or else Is_Concurrent_Record_Type (Full_T)
then
Next (Id);
end if;
if Is_Non_Empty_List (Abstract_Interface_List (Full_T)) then
Id := First (Abstract_Interface_List (Full_T));
while Present (Id) loop
Iface := Etype (Id);
@ -1369,13 +1313,14 @@ package body Sem_Util is
-- type Wrong is new I and O with null record; -- ERROR
if Is_Interface (Iface) then
if Exclude_Parent_Interfaces
and then Interface_Present_In_Parent (T, Iface)
if Exclude_Parents
and then Etype (T) /= T
and then Interface_Present_In_Ancestor (Etype (T), Iface)
then
null;
else
Collect (Iface);
Add_Interface (Iface);
Collect (Iface);
Append_Unique_Elmt (Iface, Ifaces_List);
end if;
end if;
@ -1384,40 +1329,13 @@ package body Sem_Util is
end if;
end Collect;
---------------------------------
-- Interface_Present_In_Parent --
---------------------------------
function Interface_Present_In_Parent
(Typ : Entity_Id;
Iface : Entity_Id) return Boolean
is
Aux : Entity_Id := Typ;
Iface_List : List_Id;
begin
if Is_Concurrent_Type (Typ)
or else Is_Concurrent_Record_Type (Typ)
then
Iface_List := Abstract_Interface_List (Typ);
if Is_Non_Empty_List (Iface_List) then
Aux := Etype (First (Iface_List));
else
return False;
end if;
end if;
return Interface_Present_In_Ancestor (Aux, Iface);
end Interface_Present_In_Parent;
-- Start of processing for Collect_Abstract_Interfaces
-- Start of processing for Collect_Interfaces
begin
pragma Assert (Is_Tagged_Type (T) or else Is_Concurrent_Type (T));
Ifaces_List := New_Elmt_List;
Collect (T);
end Collect_Abstract_Interfaces;
end Collect_Interfaces;
----------------------------------
-- Collect_Interface_Components --
@ -1526,7 +1444,7 @@ package body Sem_Util is
-- Start of processing for Collect_Interfaces_Info
begin
Collect_Abstract_Interfaces (T, Ifaces_List);
Collect_Interfaces (T, Ifaces_List);
Collect_Interface_Components (T, Comps_List);
-- Search for the record component and tag associated with each
@ -1542,7 +1460,7 @@ package body Sem_Util is
-- Associate the primary tag component and the primary dispatch table
-- with all the interfaces that are parents of T
if Is_Parent (Iface, T) then
if Is_Ancestor (Iface, T) then
Append_Elmt (First_Tag_Component (T), Components_List);
Append_Elmt (Node (First_Elmt (Access_Disp_Table (T))), Tags_List);
@ -1555,7 +1473,7 @@ package body Sem_Util is
Comp_Iface := Related_Type (Node (Comp_Elmt));
if Comp_Iface = Iface
or else Is_Parent (Iface, Comp_Iface)
or else Is_Ancestor (Iface, Comp_Iface)
then
Append_Elmt (Node (Comp_Elmt), Components_List);
Append_Elmt (Search_Tag (Comp_Iface), Tags_List);
@ -4085,83 +4003,6 @@ package body Sem_Util is
return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
end Get_Task_Body_Procedure;
-----------------------------
-- Has_Abstract_Interfaces --
-----------------------------
function Has_Abstract_Interfaces
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
Typ : Entity_Id;
begin
-- Handle concurrent types
if Is_Concurrent_Type (T) then
Typ := Corresponding_Record_Type (T);
else
Typ := T;
end if;
if not Present (Typ)
or else not Is_Tagged_Type (Typ)
then
return False;
end if;
pragma Assert (Is_Record_Type (Typ));
-- Handle private types
if Use_Full_View
and then Present (Full_View (Typ))
then
Typ := Full_View (Typ);
end if;
-- Handle concurrent record types
if Is_Concurrent_Record_Type (Typ)
and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
then
return True;
end if;
loop
if Is_Interface (Typ)
or else
(Is_Record_Type (Typ)
and then Present (Abstract_Interfaces (Typ))
and then not Is_Empty_Elmt_List (Abstract_Interfaces (Typ)))
then
return True;
end if;
exit when Etype (Typ) = Typ
-- Handle private types
or else (Present (Full_View (Etype (Typ)))
and then Full_View (Etype (Typ)) = Typ)
-- Protect the frontend against wrong source with cyclic
-- derivations
or else Etype (Typ) = T;
-- Climb to the ancestor type handling private types
if Present (Full_View (Etype (Typ))) then
Typ := Full_View (Etype (Typ));
else
Typ := Etype (Typ);
end if;
end loop;
return False;
end Has_Abstract_Interfaces;
-----------------------
-- Has_Access_Values --
-----------------------
@ -4616,6 +4457,82 @@ package body Sem_Util is
and then Includes_Infinities (Scalar_Range (E));
end Has_Infinities;
--------------------
-- Has_Interfaces --
--------------------
function Has_Interfaces
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean
is
Typ : Entity_Id;
begin
-- Handle concurrent types
if Is_Concurrent_Type (T) then
Typ := Corresponding_Record_Type (T);
else
Typ := T;
end if;
if not Present (Typ)
or else not Is_Record_Type (Typ)
or else not Is_Tagged_Type (Typ)
then
return False;
end if;
-- Handle private types
if Use_Full_View
and then Present (Full_View (Typ))
then
Typ := Full_View (Typ);
end if;
-- Handle concurrent record types
if Is_Concurrent_Record_Type (Typ)
and then Is_Non_Empty_List (Abstract_Interface_List (Typ))
then
return True;
end if;
loop
if Is_Interface (Typ)
or else
(Is_Record_Type (Typ)
and then Present (Interfaces (Typ))
and then not Is_Empty_Elmt_List (Interfaces (Typ)))
then
return True;
end if;
exit when Etype (Typ) = Typ
-- Handle private types
or else (Present (Full_View (Etype (Typ)))
and then Full_View (Etype (Typ)) = Typ)
-- Protect the frontend against wrong source with cyclic
-- derivations
or else Etype (Typ) = T;
-- Climb to the ancestor type handling private types
if Present (Full_View (Etype (Typ))) then
Typ := Full_View (Etype (Typ));
else
Typ := Etype (Typ);
end if;
end loop;
return False;
end Has_Interfaces;
------------------------
-- Has_Null_Exclusion --
------------------------
@ -5219,6 +5136,56 @@ package body Sem_Util is
end if;
end Has_Tagged_Component;
--------------------------
-- Implements_Interface --
--------------------------
function Implements_Interface
(Typ_Ent : Entity_Id;
Iface_Ent : Entity_Id;
Exclude_Parents : Boolean := False) return Boolean
is
Ifaces_List : Elist_Id;
Elmt : Elmt_Id;
Iface : Entity_Id;
Typ : Entity_Id;
begin
if Is_Class_Wide_Type (Typ_Ent) then
Typ := Etype (Typ_Ent);
else
Typ := Typ_Ent;
end if;
if Is_Class_Wide_Type (Iface_Ent) then
Iface := Etype (Iface_Ent);
else
Iface := Iface_Ent;
end if;
if not Has_Interfaces (Typ) then
return False;
end if;
Collect_Interfaces (Typ, Ifaces_List);
Elmt := First_Elmt (Ifaces_List);
while Present (Elmt) loop
if Is_Ancestor (Node (Elmt), Typ)
and then Exclude_Parents
then
null;
elsif Node (Elmt) = Iface then
return True;
end if;
Next_Elmt (Elmt);
end loop;
return False;
end Implements_Interface;
-----------------
-- In_Instance --
-----------------
@ -6524,33 +6491,6 @@ package body Sem_Util is
end if;
end Is_OK_Variable_For_Out_Formal;
---------------
-- Is_Parent --
---------------
function Is_Parent
(E1 : Entity_Id;
E2 : Entity_Id) return Boolean
is
Iface_List : List_Id;
T : Entity_Id := E2;
begin
if Is_Concurrent_Type (T)
or else Is_Concurrent_Record_Type (T)
then
Iface_List := Abstract_Interface_List (E2);
if Is_Empty_List (Iface_List) then
return False;
end if;
T := Etype (First (Iface_List));
end if;
return Is_Ancestor (E1, T);
end Is_Parent;
-----------------------------------
-- Is_Partially_Initialized_Type --
-----------------------------------
@ -8494,6 +8434,48 @@ package body Sem_Util is
return Trace_Components (Type_Id, False);
end Private_Component;
---------------------------
-- Primitive_Names_Match --
---------------------------
function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
function Non_Internal_Name (E : Entity_Id) return Name_Id;
-- Given an internal name, returns the corresponding non-internal name
------------------------
-- Non_Internal_Name --
------------------------
function Non_Internal_Name (E : Entity_Id) return Name_Id is
begin
Get_Name_String (Chars (E));
Name_Len := Name_Len - 1;
return Name_Find;
end Non_Internal_Name;
-- Start of processing for Primitive_Names_Match
begin
pragma Assert (Present (E1) and then Present (E2));
return Chars (E1) = Chars (E2)
or else
(not Is_Internal_Name (Chars (E1))
and then Is_Internal_Name (Chars (E2))
and then Non_Internal_Name (E2) = Chars (E1))
or else
(not Is_Internal_Name (Chars (E2))
and then Is_Internal_Name (Chars (E1))
and then Non_Internal_Name (E1) = Chars (E2))
or else
(Is_Predefined_Dispatching_Operation (E1)
and then Is_Predefined_Dispatching_Operation (E2)
and then Same_TSS (E1, E2))
or else
(Is_Init_Proc (E1) and then Is_Init_Proc (E2));
end Primitive_Names_Match;
-----------------------
-- Process_End_Label --
-----------------------
@ -8703,6 +8685,32 @@ package body Sem_Util is
return Token_Node;
end Real_Convert;
--------------------
-- Remove_Homonym --
--------------------
procedure Remove_Homonym (E : Entity_Id) is
Prev : Entity_Id := Empty;
H : Entity_Id;
begin
if E = Current_Entity (E) then
if Present (Homonym (E)) then
Set_Current_Entity (Homonym (E));
else
Set_Name_Entity_Id (Chars (E), Empty);
end if;
else
H := Current_Entity (E);
while Present (H) and then H /= E loop
Prev := H;
H := Homonym (H);
end loop;
Set_Homonym (Prev, Homonym (E));
end if;
end Remove_Homonym;
---------------------
-- Rep_To_Pos_Flag --
---------------------
@ -9745,6 +9753,22 @@ package body Sem_Util is
return Scope_Depth (Enclosing_Dynamic_Scope (Btyp));
end Type_Access_Level;
--------------------
-- Ultimate_Alias --
--------------------
-- To do: add occurrences calling this new subprogram
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is
E : Entity_Id := Prim;
begin
while Present (Alias (E)) loop
E := Alias (E);
end loop;
return E;
end Ultimate_Alias;
--------------------------
-- Unit_Declaration_Node --
--------------------------

57
gcc/ada/sem_util.ads
View File

@ -152,14 +152,14 @@ package Sem_Util is
-- with OpenVMS ports. The argument is the construct in question
-- and is used to post the error message.
procedure Collect_Abstract_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Exclude_Parent_Interfaces : Boolean := False;
Use_Full_View : Boolean := True);
procedure Collect_Interfaces
(T : Entity_Id;
Ifaces_List : out Elist_Id;
Exclude_Parents : Boolean := False;
Use_Full_View : Boolean := True);
-- Ada 2005 (AI-251): Collect whole list of abstract interfaces that are
-- directly or indirectly implemented by T. Exclude_Parent_Interfaces is
-- used to avoid addition of inherited interfaces to the generated list.
-- directly or indirectly implemented by T. Exclude_Parents is used to
-- avoid the addition of inherited interfaces to the generated list.
-- Use_Full_View is used to collect the interfaces using the full-view
-- (if available).
@ -498,14 +498,6 @@ package Sem_Util is
-- as an access type internally, this function tests only for access types
-- known to the programmer. See also Has_Tagged_Component.
function Has_Abstract_Interfaces
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean;
-- Where T is a concurrent type or a record type, returns true if T covers
-- any abstract interface types. In case of private types the argument
-- Use_Full_View controls if the check is done using its full view (if
-- available).
type Alignment_Result is (Known_Compatible, Unknown, Known_Incompatible);
-- Result of Has_Compatible_Alignment test, description found below. Note
-- that the values are arranged in increasing order of problematicness.
@ -542,6 +534,14 @@ package Sem_Util is
-- Determines if the range of the floating-point type E includes
-- infinities. Returns False if E is not a floating-point type.
function Has_Interfaces
(T : Entity_Id;
Use_Full_View : Boolean := True) return Boolean;
-- Where T is a concurrent type or a record type, returns true if T covers
-- any abstract interface types. In case of private types the argument
-- Use_Full_View controls if the check is done using its full view (if
-- available).
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
@ -572,6 +572,12 @@ package Sem_Util is
-- component is present. This function is used to check if '=' has to be
-- expanded into a bunch component comparisons.
function Implements_Interface
(Typ_Ent : Entity_Id;
Iface_Ent : Entity_Id;
Exclude_Parents : Boolean := False) return Boolean;
-- Returns true if the Typ implements interface Iface
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
@ -716,13 +722,6 @@ package Sem_Util is
-- is a variable (in the Is_Variable sense) with a non-tagged type
-- target are considered view conversions and hence variables.
function Is_Parent
(E1 : Entity_Id;
E2 : Entity_Id) return Boolean;
-- Determine whether E1 is a parent of E2. For a concurrent type, the
-- parent is the first element of its list of interface types; for other
-- types, this function provides the same result as Is_Ancestor.
function Is_Partially_Initialized_Type (Typ : Entity_Id) return Boolean;
-- Typ is a type entity. This function returns true if this type is
-- partly initialized, meaning that an object of the type is at least
@ -951,6 +950,13 @@ package Sem_Util is
-- For convenience, qualified expressions applied to object names
-- are also allowed as actuals for this function.
function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean;
-- Returns True if the names of both entities correspond with matching
-- primitives. This routine includes support for the case in which one
-- or both entities correspond with entities built by Derive_Subprogram
-- with a special name to avoid being overriden (ie. return true in case
-- of entities with names "nameP" and "name" or viceversa).
function Private_Component (Type_Id : Entity_Id) return Entity_Id;
-- Returns some private component (if any) of the given Type_Id.
-- Used to enforce the rules on visibility of operations on composite
@ -974,6 +980,9 @@ package Sem_Util is
-- S is a possibly signed syntactically valid real literal. The result
-- returned is an N_Real_Literal node representing the literal value.
procedure Remove_Homonym (E : Entity_Id);
-- Removes E from the homonym chain
function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id;
-- This is used to construct the second argument in a call to Rep_To_Pos
-- which is Standard_True if range checks are enabled (E is an entity to
@ -1147,6 +1156,10 @@ package Sem_Util is
function Type_Access_Level (Typ : Entity_Id) return Uint;
-- Return the accessibility level of Typ
function Ultimate_Alias (Prim : Entity_Id) return Entity_Id;
-- Return the last entity in the chain of aliased entities of Prim.
-- If Prim has no alias return Prim.
function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id;
-- Unit_Id is the simple name of a program unit, this function returns the
-- corresponding xxx_Declaration node for the entity. Also applies to the

11
gcc/ada/sprint.adb
View File

@ -1577,6 +1577,11 @@ package body Sprint is
Write_Str_With_Col_Check_Sloc ("new ");
Sprint_Node (Subtype_Mark (Node));
if Present (Interface_List (Node)) then
Write_Str_With_Col_Check (" and ");
Sprint_And_List (Interface_List (Node));
end if;
if Private_Present (Node) then
Write_Str_With_Col_Check (" with private");
end if;
@ -2442,6 +2447,12 @@ package body Sprint is
Write_Str_With_Col_Check (" is new ");
Sprint_Node (Subtype_Indication (Node));
if Present (Interface_List (Node)) then
Write_Str_With_Col_Check (" and ");
Sprint_And_List (Interface_List (Node));
end if;
Write_Str_With_Col_Check (" with private;");
when N_Procedure_Call_Statement =>