diff options
| -rw-r--r-- | gcc/ada/einfo.adb | 67 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 64 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 6 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 177 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 35 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 180 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.ads | 9 | ||||
| -rw-r--r-- | gcc/ada/exp_intr.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 331 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/sem_cat.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 1415 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 238 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.ads | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_ch9.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.adb | 141 | ||||
| -rw-r--r-- | gcc/ada/sem_disp.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/sem_type.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 444 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 57 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 11 |
29 files changed, 1762 insertions, 1533 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7d3fbdf..fa212a7 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index e162304..c0377a5 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index af531ab..34b5644 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 3ba47ec..4d2967b 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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 diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 89ae08f..c119551 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -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)); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index f009f00..2d275a9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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, diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 8791fcf..9b47185 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 33d129c..572dae0 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -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 := diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 58bd28b..860fd17 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -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 (")"); diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 5bf2b6c..abdc949 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -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 diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index 6f29b37..a33bf04 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -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 := diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index c6b61d5..058c549 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 -- ---------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 30d417f..5f35d4e 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 21b1ad5..bf4f946 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index a7cc61a..8af553f 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -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); diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index fcb0177..3e4a036 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3efe7fc..4a7c91f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -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; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a79e304..a3f036a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -31,6 +31,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Eval_Fat; use Eval_Fat; with Exp_Ch3; use Exp_Ch3; +with Exp_Disp; use Exp_Disp; with Exp_Dist; use Exp_Dist; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; @@ -253,9 +254,6 @@ package body Sem_Ch3 is -- view cannot itself have a full view (it would get clobbered during -- view exchanges). - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id); - -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) - procedure Check_Access_Discriminant_Requires_Limited (D : Node_Id; Loc : Node_Id); @@ -289,6 +287,9 @@ package body Sem_Ch3 is -- Validate the initialization of an object declaration. T is the required -- type, and Exp is the initialization expression. + procedure Check_Interfaces (N : Node_Id; Def : Node_Id); + -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) + procedure Check_Or_Process_Discriminants (N : Node_Id; T : Entity_Id; @@ -486,14 +487,16 @@ package body Sem_Ch3 is -- appropriate semantic fields. If the full view of the parent is a record -- type, build constrained components of subtype. - procedure Derive_Interface_Subprograms + procedure Derive_Progenitor_Subprograms (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id; - Ifaces_List : Elist_Id); - -- Ada 2005 (AI-251): Derive primitives of abstract interface types that - -- are not immediate ancestors of Tagged type and associate them their - -- aliased primitive. Ifaces_List contains the abstract interface - -- primitives that have been derived from Parent_Type. + Tagged_Type : Entity_Id); + -- Ada 2005 (AI-251): To complete type derivation, collect the primitive + -- operations of progenitors of Tagged_Type, and replace the subsidiary + -- subtypes with Tagged_Type, to build the specs of the inherited interface + -- primitives. The derived primitives are aliased to those of the + -- interface. This routine takes care also of transferring to the full-view + -- subprograms associated with the partial-view of Tagged_Type that cover + -- interface primitives. procedure Derived_Standard_Character (N : Node_Id; @@ -1273,36 +1276,12 @@ package body Sem_Ch3 is procedure Add_Interface_Tag_Components (N : Node_Id; Typ : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); - Elmt : Elmt_Id; - Ext : Node_Id; L : List_Id; Last_Tag : Node_Id; - Comp : Node_Id; - - procedure Add_Sync_Iface_Tags (T : Entity_Id); - -- Local subprogram used to recursively climb through the parents - -- of T to add the tags of all the progenitor interfaces. procedure Add_Tag (Iface : Entity_Id); -- Add tag for one of the progenitor interfaces - ------------------------- - -- Add_Sync_Iface_Tags -- - ------------------------- - - procedure Add_Sync_Iface_Tags (T : Entity_Id) is - begin - if Etype (T) /= T then - Add_Sync_Iface_Tags (Etype (T)); - end if; - - Elmt := First_Elmt (Abstract_Interfaces (T)); - while Present (Elmt) loop - Add_Tag (Node (Elmt)); - Next_Elmt (Elmt); - end loop; - end Add_Sync_Iface_Tags; - ------------- -- Add_Tag -- ------------- @@ -1387,7 +1366,9 @@ package body Sem_Ch3 is -- Local variables - Iface_List : List_Id; + Elmt : Elmt_Id; + Ext : Node_Id; + Comp : Node_Id; -- Start of processing for Add_Interface_Tag_Components @@ -1403,8 +1384,8 @@ package body Sem_Ch3 is or else (Is_Concurrent_Record_Type (Typ) and then Is_Empty_List (Abstract_Interface_List (Typ))) or else (not Is_Concurrent_Record_Type (Typ) - and then No (Abstract_Interfaces (Typ)) - and then Is_Empty_Elmt_List (Abstract_Interfaces (Typ))) + and then No (Interfaces (Typ)) + and then Is_Empty_Elmt_List (Interfaces (Typ))) then return; end if; @@ -1458,16 +1439,8 @@ package body Sem_Ch3 is -- corresponding with all the interfaces that are not implemented -- by the parent. - if Is_Concurrent_Record_Type (Typ) then - Iface_List := Abstract_Interface_List (Typ); - - if Is_Non_Empty_List (Iface_List) then - Add_Sync_Iface_Tags (Etype (First (Iface_List))); - end if; - end if; - - if Present (Abstract_Interfaces (Typ)) then - Elmt := First_Elmt (Abstract_Interfaces (Typ)); + if Present (Interfaces (Typ)) then + Elmt := First_Elmt (Interfaces (Typ)); while Present (Elmt) loop Add_Tag (Node (Elmt)); Next_Elmt (Elmt); @@ -1993,18 +1966,18 @@ package body Sem_Ch3 is CW : constant Entity_Id := Class_Wide_Type (T); begin - Set_Is_Tagged_Type (T); + Set_Is_Tagged_Type (T); - Set_Is_Limited_Record (T, Limited_Present (Def) - or else Task_Present (Def) - or else Protected_Present (Def) - or else Synchronized_Present (Def)); + Set_Is_Limited_Record (T, Limited_Present (Def) + or else Task_Present (Def) + or else Protected_Present (Def) + or else Synchronized_Present (Def)); -- Type is abstract if full declaration carries keyword, or if previous -- partial view did. Set_Is_Abstract_Type (T); - Set_Is_Interface (T); + Set_Is_Interface (T); -- Type is a limited interface if it includes the keyword limited, task, -- protected, or synchronized. @@ -2015,8 +1988,8 @@ package body Sem_Ch3 is or else Synchronized_Present (Def) or else Task_Present (Def)); - Set_Is_Protected_Interface (T, Protected_Present (Def)); - Set_Is_Task_Interface (T, Task_Present (Def)); + Set_Is_Protected_Interface (T, Protected_Present (Def)); + Set_Is_Task_Interface (T, Task_Present (Def)); -- Type is a synchronized interface if it includes the keyword task, -- protected, or synchronized. @@ -2026,8 +1999,8 @@ package body Sem_Ch3 is or else Protected_Present (Def) or else Task_Present (Def)); - Set_Abstract_Interfaces (T, New_Elmt_List); - Set_Primitive_Operations (T, New_Elmt_List); + Set_Interfaces (T, New_Elmt_List); + Set_Primitive_Operations (T, New_Elmt_List); -- Complete the decoration of the class-wide entity if it was already -- built (i.e. during the creation of the limited view) @@ -3236,13 +3209,13 @@ package body Sem_Ch3 is -- The progenitors (if any) must be limited or synchronized -- interfaces. - if Present (Abstract_Interfaces (T)) then + if Present (Interfaces (T)) then declare Iface : Entity_Id; Iface_Elmt : Elmt_Id; begin - Iface_Elmt := First_Elmt (Abstract_Interfaces (T)); + Iface_Elmt := First_Elmt (Interfaces (T)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -6770,7 +6743,7 @@ package body Sem_Ch3 is Analyze_Interface_Declaration (Derived_Type, Type_Def); end if; - Set_Abstract_Interfaces (Derived_Type, No_Elist); + Set_Interfaces (Derived_Type, No_Elist); end if; -- Fields inherited from the Parent_Type @@ -6804,9 +6777,9 @@ package body Sem_Ch3 is if Is_Record_Type (Derived_Type) then Set_OK_To_Reorder_Components - (Derived_Type, OK_To_Reorder_Components (Parent_Base)); + (Derived_Type, OK_To_Reorder_Components (Parent_Base)); Set_Reverse_Bit_Order - (Derived_Type, Reverse_Bit_Order (Parent_Base)); + (Derived_Type, Reverse_Bit_Order (Parent_Base)); end if; -- Direct controlled types do not inherit Finalize_Storage_Only flag @@ -6896,16 +6869,17 @@ package body Sem_Ch3 is -- Check ARM rules 3.9.4 (15/2), 9.1 (9.d/2) and 9.4 (11.d/2) - Check_Abstract_Interfaces (N, Type_Def); + Check_Interfaces (N, Type_Def); -- Ada 2005 (AI-251): Collect the list of progenitors that are -- not already in the parents. - Collect_Abstract_Interfaces - (T => Derived_Type, - Ifaces_List => Ifaces_List, - Exclude_Parent_Interfaces => True); - Set_Abstract_Interfaces (Derived_Type, Ifaces_List); + Collect_Interfaces + (T => Derived_Type, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); + + Set_Interfaces (Derived_Type, Ifaces_List); end; end if; @@ -7003,7 +6977,7 @@ package body Sem_Ch3 is -- implemented interfaces if we are in expansion mode if Expander_Active - and then Has_Abstract_Interfaces (Derived_Type) + and then Has_Interfaces (Derived_Type) then Add_Interface_Tag_Components (N, Derived_Type); end if; @@ -7888,236 +7862,6 @@ package body Sem_Ch3 is end Build_Underlying_Full_View; ------------------------------- - -- Check_Abstract_Interfaces -- - ------------------------------- - - procedure Check_Abstract_Interfaces (N : Node_Id; Def : Node_Id) is - Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); - - Iface : Node_Id; - Iface_Def : Node_Id; - Iface_Typ : Entity_Id; - Parent_Node : Node_Id; - - Is_Task : Boolean := False; - -- Set True if parent type or any progenitor is a task interface - - Is_Protected : Boolean := False; - -- Set True if parent type or any progenitor is a protected interface - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); - -- Check that a progenitor is compatible with declaration. - -- Error is posted on Error_Node. - - ------------------ - -- Check_Ifaces -- - ------------------ - - procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is - Iface_Id : constant Entity_Id := - Defining_Identifier (Parent (Iface_Def)); - Type_Def : Node_Id; - - begin - if Nkind (N) = N_Private_Extension_Declaration then - Type_Def := N; - else - Type_Def := Type_Definition (N); - end if; - - if Is_Task_Interface (Iface_Id) then - Is_Task := True; - - elsif Is_Protected_Interface (Iface_Id) then - Is_Protected := True; - end if; - - -- Check that the characteristics of the progenitor are compatible - -- with the explicit qualifier in the declaration. - -- The check only applies to qualifiers that come from source. - -- Limited_Present also appears in the declaration of corresponding - -- records, and the check does not apply to them. - - if Limited_Present (Type_Def) - and then not - Is_Concurrent_Record_Type (Defining_Identifier (N)) - then - if Is_Limited_Interface (Parent_Type) - and then not Is_Limited_Interface (Iface_Id) - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); - - elsif - (Task_Present (Iface_Def) - or else Protected_Present (Iface_Def) - or else Synchronized_Present (Iface_Def)) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_NE - ("progenitor& must be limited interface", - Error_Node, Iface_Id); - end if; - - -- Protected interfaces can only inherit from limited, synchronized - -- or protected interfaces. - - elsif Nkind (N) = N_Full_Type_Declaration - and then Protected_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Protected_Present (Iface_Def) - then - null; - - elsif Task_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from task interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) protected interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from - -- limited and synchronized. - - elsif Synchronized_Present (Type_Def) then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from protected interface", Error_Node); - - elsif Task_Present (Iface_Def) - and then Nkind (N) /= N_Private_Extension_Declaration - then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from task interface", Error_Node); - - elsif not Is_Limited_Interface (Iface_Id) then - Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" - & " from non-limited interface", Error_Node); - end if; - - -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, - -- synchronized or task interfaces. - - elsif Nkind (N) = N_Full_Type_Declaration - and then Task_Present (Type_Def) - then - if Limited_Present (Iface_Def) - or else Synchronized_Present (Iface_Def) - or else Task_Present (Iface_Def) - then - null; - - elsif Protected_Present (Iface_Def) then - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " protected interface", Error_Node); - - else - Error_Msg_N ("(Ada 2005) task interface cannot inherit from" - & " non-limited interface", Error_Node); - end if; - end if; - end Check_Ifaces; - - -- Start of processing for Check_Abstract_Interfaces - - begin - if Is_Interface (Parent_Type) then - if Is_Task_Interface (Parent_Type) then - Is_Task := True; - - elsif Is_Protected_Interface (Parent_Type) then - Is_Protected := True; - end if; - end if; - - if Nkind (N) = N_Private_Extension_Declaration then - - -- Check that progenitors are compatible with declaration - - Iface := First (Interface_List (Def)); - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - Check_Ifaces (Iface_Def, Iface); - end if; - - Next (Iface); - end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - - return; - end if; - - -- Full type declaration of derived type. - -- Check compatibility with parent if it is interface type - - if Nkind (Type_Definition (N)) = N_Derived_Type_Definition - and then Is_Interface (Parent_Type) - then - Parent_Node := Parent (Parent_Type); - - -- More detailed checks for interface varieties - - Check_Ifaces - (Iface_Def => Type_Definition (Parent_Node), - Error_Node => Subtype_Indication (Type_Definition (N))); - end if; - - Iface := First (Interface_List (Def)); - - while Present (Iface) loop - Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); - - Parent_Node := Parent (Base_Type (Iface_Typ)); - Iface_Def := Type_Definition (Parent_Node); - - if not Is_Interface (Iface_Typ) then - Error_Msg_NE ("(Ada 2005) & must be an interface", - Iface, Iface_Typ); - - else - -- "The declaration of a specific descendant of an interface - -- type freezes the interface type" RM 13.14 - - Freeze_Before (N, Iface_Typ); - Check_Ifaces (Iface_Def, Error_Node => Iface); - end if; - - Next (Iface); - end loop; - - if Is_Task and Is_Protected then - Error_Msg_N - ("type cannot derive from task and protected interface", N); - end if; - - end Check_Abstract_Interfaces; - - ------------------------------- -- Check_Abstract_Overriding -- ------------------------------- @@ -8162,13 +7906,20 @@ package body Sem_Ch3 is if Is_Null_Extension (T) and then Has_Controlling_Result (Subp) and then Ada_Version >= Ada_05 - and then Present (Alias (Subp)) + and then Present (Alias_Subp) and then not Comes_From_Source (Subp) - and then not Is_Abstract_Subprogram (Alias (Subp)) + and then not Is_Abstract_Subprogram (Alias_Subp) and then not Is_Access_Type (Etype (Subp)) then null; + -- Ada 2005 (AI-251): Internal entities of interfaces need no + -- processing because this check is done with the aliased + -- entity + + elsif Present (Interface_Alias (Subp)) then + null; + elsif (Is_Abstract_Subprogram (Subp) or else Requires_Overriding (Subp) or else @@ -8180,18 +7931,14 @@ package body Sem_Ch3 is and then not Is_TSS (Subp, TSS_Stream_Output) and then not Is_Abstract_Type (T) and then Convention (T) /= Convention_CIL - and then Chars (Subp) /= Name_uDisp_Asynchronous_Select - and then Chars (Subp) /= Name_uDisp_Conditional_Select - and then Chars (Subp) /= Name_uDisp_Get_Prim_Op_Kind - and then Chars (Subp) /= Name_uDisp_Requeue - and then Chars (Subp) /= Name_uDisp_Timed_Select + and then not Is_Predefined_Interface_Primitive (Subp) -- Ada 2005 (AI-251): Do not consider hidden entities associated -- with abstract interface types because the check will be done -- with the aliased entity (otherwise we generate a duplicated -- error message). - and then not Present (Abstract_Interface_Alias (Subp)) + and then not Present (Interface_Alias (Subp)) then if Present (Alias_Subp) then @@ -8222,13 +7969,15 @@ package body Sem_Ch3 is or else Requires_Overriding (Subp) or else Is_Access_Type (Etype (Subp))) then - -- The body of predefined primitives of tagged types derived - -- from interface types are generated later by Freeze_Type. - - if Is_Predefined_Dispatching_Operation (Subp) - and then Is_Abstract_Subprogram (Alias_Subp) - and then Is_Interface - (Root_Type (Find_Dispatching_Type (Subp))) + -- 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 + + if Is_Interface (Root_Type (T)) + and then Is_Abstract_Subprogram (Subp) + and then Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) then null; @@ -8268,7 +8017,7 @@ package body Sem_Ch3 is -- abstract interfaces. elsif Is_Concurrent_Record_Type (T) - and then Present (Abstract_Interfaces (T)) + and then Present (Interfaces (T)) then -- The controlling formal of Subp must be of mode "out", -- "in out" or an access-to-variable to be overridden. @@ -8277,12 +8026,14 @@ package body Sem_Ch3 is -- in -gnatj mode) ??? if Ekind (First_Formal (Subp)) = E_In_Parameter then - Error_Msg_NE - ("first formal of & must be of mode `OUT`, `IN OUT` " & - "or access-to-variable", T, Subp); - Error_Msg_N - ("\to be overridden by protected procedure or " & - "entry (RM 9.4(11.9/2))", T); + if not Is_Predefined_Dispatching_Operation (Subp) then + Error_Msg_NE + ("first formal of & must be of mode `OUT`, " & + "`IN OUT` or access-to-variable", T, Subp); + Error_Msg_N + ("\to be overridden by protected procedure or " & + "entry (RM 9.4(11.9/2))", T); + end if; -- Some other kind of overriding failure @@ -8315,8 +8066,8 @@ package body Sem_Ch3 is if Ada_Version >= Ada_05 and then Is_Hidden (Subp) - and then Present (Abstract_Interface_Alias (Subp)) - and then Implemented_By_Entry (Abstract_Interface_Alias (Subp)) + and then Present (Interface_Alias (Subp)) + and then Implemented_By_Entry (Interface_Alias (Subp)) and then Present (Alias_Subp) and then (not Is_Primitive_Wrapper (Alias_Subp) @@ -8330,7 +8081,7 @@ package body Sem_Ch3 is Error_Ent := Corresponding_Concurrent_Type (Error_Ent); end if; - Error_Msg_Node_2 := Abstract_Interface_Alias (Subp); + Error_Msg_Node_2 := Interface_Alias (Subp); Error_Msg_NE ("type & must implement abstract subprogram & with an entry", Error_Ent, Error_Ent); @@ -8742,6 +8493,234 @@ package body Sem_Ch3 is end if; end Check_Initialization; + ---------------------- + -- Check_Interfaces -- + ---------------------- + + procedure Check_Interfaces (N : Node_Id; Def : Node_Id) is + Parent_Type : constant Entity_Id := Etype (Defining_Identifier (N)); + + Iface : Node_Id; + Iface_Def : Node_Id; + Iface_Typ : Entity_Id; + Parent_Node : Node_Id; + + Is_Task : Boolean := False; + -- Set True if parent type or any progenitor is a task interface + + Is_Protected : Boolean := False; + -- Set True if parent type or any progenitor is a protected interface + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id); + -- Check that a progenitor is compatible with declaration. + -- Error is posted on Error_Node. + + ------------------ + -- Check_Ifaces -- + ------------------ + + procedure Check_Ifaces (Iface_Def : Node_Id; Error_Node : Node_Id) is + Iface_Id : constant Entity_Id := + Defining_Identifier (Parent (Iface_Def)); + Type_Def : Node_Id; + + begin + if Nkind (N) = N_Private_Extension_Declaration then + Type_Def := N; + else + Type_Def := Type_Definition (N); + end if; + + if Is_Task_Interface (Iface_Id) then + Is_Task := True; + + elsif Is_Protected_Interface (Iface_Id) then + Is_Protected := True; + end if; + + -- Check that the characteristics of the progenitor are compatible + -- with the explicit qualifier in the declaration. + -- The check only applies to qualifiers that come from source. + -- Limited_Present also appears in the declaration of corresponding + -- records, and the check does not apply to them. + + if Limited_Present (Type_Def) + and then not + Is_Concurrent_Record_Type (Defining_Identifier (N)) + then + if Is_Limited_Interface (Parent_Type) + and then not Is_Limited_Interface (Iface_Id) + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + + elsif + (Task_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def)) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_NE + ("progenitor& must be limited interface", + Error_Node, Iface_Id); + end if; + + -- Protected interfaces can only inherit from limited, synchronized + -- or protected interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Protected_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Protected_Present (Iface_Def) + then + null; + + elsif Task_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from task interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) protected interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Synchronized interfaces can only inherit from + -- limited and synchronized. + + elsif Synchronized_Present (Type_Def) then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from protected interface", Error_Node); + + elsif Task_Present (Iface_Def) + and then Nkind (N) /= N_Private_Extension_Declaration + then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from task interface", Error_Node); + + elsif not Is_Limited_Interface (Iface_Id) then + Error_Msg_N ("(Ada 2005) synchronized interface cannot inherit" + & " from non-limited interface", Error_Node); + end if; + + -- Ada 2005 (AI-345): Task interfaces can only inherit from limited, + -- synchronized or task interfaces. + + elsif Nkind (N) = N_Full_Type_Declaration + and then Task_Present (Type_Def) + then + if Limited_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def) + then + null; + + elsif Protected_Present (Iface_Def) then + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " protected interface", Error_Node); + + else + Error_Msg_N ("(Ada 2005) task interface cannot inherit from" + & " non-limited interface", Error_Node); + end if; + end if; + end Check_Ifaces; + + -- Start of processing for Check_Interfaces + + begin + if Is_Interface (Parent_Type) then + if Is_Task_Interface (Parent_Type) then + Is_Task := True; + + elsif Is_Protected_Interface (Parent_Type) then + Is_Protected := True; + end if; + end if; + + if Nkind (N) = N_Private_Extension_Declaration then + + -- Check that progenitors are compatible with declaration + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + Check_Ifaces (Iface_Def, Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + + return; + end if; + + -- Full type declaration of derived type. + -- Check compatibility with parent if it is interface type + + if Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then Is_Interface (Parent_Type) + then + Parent_Node := Parent (Parent_Type); + + -- More detailed checks for interface varieties + + Check_Ifaces + (Iface_Def => Type_Definition (Parent_Node), + Error_Node => Subtype_Indication (Type_Definition (N))); + end if; + + Iface := First (Interface_List (Def)); + while Present (Iface) loop + Iface_Typ := Find_Type_Of_Subtype_Indic (Iface); + + Parent_Node := Parent (Base_Type (Iface_Typ)); + Iface_Def := Type_Definition (Parent_Node); + + if not Is_Interface (Iface_Typ) then + Error_Msg_NE ("(Ada 2005) & must be an interface", + Iface, Iface_Typ); + + else + -- "The declaration of a specific descendant of an interface + -- type freezes the interface type" RM 13.14 + + Freeze_Before (N, Iface_Typ); + Check_Ifaces (Iface_Def, Error_Node => Iface); + end if; + + Next (Iface); + end loop; + + if Is_Task and Is_Protected then + Error_Msg_N + ("type cannot derive from task and protected interface", N); + end if; + end Check_Interfaces; + ------------------------------------ -- Check_Or_Process_Discriminants -- ------------------------------------ @@ -11188,8 +11167,6 @@ package body Sem_Ch3 is Scale_Val : Uint; Bound_Val : Ureal; - -- Start of processing for Decimal_Fixed_Point_Type_Declaration - begin Check_Restriction (No_Fixed_Point, Def); @@ -11331,222 +11308,123 @@ package body Sem_Ch3 is Set_Is_Constrained (T); end Decimal_Fixed_Point_Type_Declaration; - ---------------------------------- - -- Derive_Interface_Subprograms -- - ---------------------------------- + ----------------------------------- + -- Derive_Progenitor_Subprograms -- + ----------------------------------- - procedure Derive_Interface_Subprograms + procedure Derive_Progenitor_Subprograms (Parent_Type : Entity_Id; - Tagged_Type : Entity_Id; - Ifaces_List : Elist_Id) + Tagged_Type : Entity_Id) is - function Collect_Interface_Primitives - (Tagged_Type : Entity_Id) return Elist_Id; - -- Ada 2005 (AI-251): Collect the primitives of all the implemented - -- interfaces. - - function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean; - -- Determine if Subp already in the list L + E : Entity_Id; + Elmt : Elmt_Id; + Iface : Entity_Id; + Iface_Elmt : Elmt_Id; + Iface_Subp : Entity_Id; + New_Subp : Entity_Id := Empty; + Prim_Elmt : Elmt_Id; + Subp : Entity_Id; + Typ : Entity_Id; - procedure Remove_Homonym (E : Entity_Id); - -- Removes E from the homonym chain + 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)); + + -- Step 1: Transfer to the full-view primitives asociated with the + -- partial-view that cover interface primitives. Conceptually this + -- work should be done later by Process_Full_View; done here to + -- simplify its implementation at later stages. It can be safely + -- done here because interfaces must be visible in the partial and + -- private view (RM 7.3(7.3/2)). + + -- Small optimization: This work is only required if the parent is + -- abstract. If the tagged type is not abstract, it cannot have + -- abstract primitives (the only entities in the list of primitives of + -- non-abstract tagged types that can reference abstract primitives + -- through its Alias attribute are the internal entities that have + -- attribute Interface_Alias, and these entities are generated later + -- by Freeze_Record_Type). - ---------------------------------- - -- Collect_Interface_Primitives -- - ---------------------------------- + if In_Private_Part (Current_Scope) + and then Is_Abstract_Type (Parent_Type) + then + Elmt := First_Elmt (Primitive_Operations (Tagged_Type)); + while Present (Elmt) loop + Subp := Node (Elmt); - function Collect_Interface_Primitives - (Tagged_Type : Entity_Id) return Elist_Id - is - Op_List : constant Elist_Id := New_Elmt_List; - Elmt : Elmt_Id; - Ifaces_List : Elist_Id; - Iface_Elmt : Elmt_Id; - Prim : Entity_Id; + -- At this stage it is not possible to have entities in the list + -- of primitives that have attribute Interface_Alias - begin - pragma Assert (Is_Tagged_Type (Tagged_Type) - and then Has_Abstract_Interfaces (Tagged_Type)); + pragma Assert (No (Interface_Alias (Subp))); - Collect_Abstract_Interfaces (Tagged_Type, Ifaces_List); + Typ := Find_Dispatching_Type (Ultimate_Alias (Subp)); - Iface_Elmt := First_Elmt (Ifaces_List); - while Present (Iface_Elmt) loop - Elmt := First_Elmt (Primitive_Operations (Node (Iface_Elmt))); - while Present (Elmt) loop - Prim := Node (Elmt); + if Is_Interface (Typ) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Subp); - if not Is_Predefined_Dispatching_Operation (Prim) then - Append_Elmt (Prim, Op_List); + if Present (E) + and then Find_Dispatching_Type (Ultimate_Alias (E)) /= Typ + then + Replace_Elmt (Elmt, E); + Remove_Homonym (Subp); end if; - - Next_Elmt (Elmt); - end loop; - - Next_Elmt (Iface_Elmt); - end loop; - - return Op_List; - end Collect_Interface_Primitives; - - ------------- - -- In_List -- - ------------- - - function In_List (L : Elist_Id; Subp : Entity_Id) return Boolean is - Elmt : Elmt_Id; - - begin - Elmt := First_Elmt (L); - while Present (Elmt) loop - if Node (Elmt) = Subp then - return True; end if; Next_Elmt (Elmt); end loop; - - return False; - end In_List; - - -------------------- - -- Remove_Homonym -- - -------------------- - - procedure Remove_Homonym (E : Entity_Id) is - Prev : Entity_Id := Empty; - H : Entity_Id; - - begin - if E = Current_Entity (E) then - Set_Current_Entity (Homonym (E)); - 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; - - -- Local Variables - - E : Entity_Id; - Elmt : Elmt_Id; - Iface : Entity_Id; - Iface_Subp : Entity_Id; - New_Subp : Entity_Id := Empty; - Op_List : Elist_Id; - Parent_Base : Entity_Id; - Subp : Entity_Id; - - -- Start of processing for Derive_Interface_Subprograms - - begin - if Ada_Version < Ada_05 - or else not Is_Record_Type (Tagged_Type) - or else not Is_Tagged_Type (Tagged_Type) - or else not Has_Abstract_Interfaces (Tagged_Type) - then - return; end if; - -- Add to the list of interface subprograms all the primitives inherited - -- from abstract interfaces that are not immediate ancestors and also - -- add their derivation to the list of interface primitives. + -- Step 2: Add primitives of progenitors that are not implemented by + -- parents of Tagged_Type - Op_List := Collect_Interface_Primitives (Tagged_Type); + if Present (Interfaces (Tagged_Type)) then + Iface_Elmt := First_Elmt (Interfaces (Tagged_Type)); + while Present (Iface_Elmt) loop + Iface := Node (Iface_Elmt); - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); - Iface := Find_Dispatching_Type (Subp); + Prim_Elmt := First_Elmt (Primitive_Operations (Iface)); + while Present (Prim_Elmt) loop + Iface_Subp := Node (Prim_Elmt); - if Is_Concurrent_Record_Type (Tagged_Type) then - if not Present (Abstract_Interface_Alias (Subp)) then - Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); - Append_Elmt (New_Subp, Ifaces_List); - end if; + if not Is_Predefined_Dispatching_Operation (Iface_Subp) then + E := Find_Primitive_Covering_Interface + (Tagged_Type => Tagged_Type, + Iface_Prim => Iface_Subp); - elsif not Is_Parent (Iface, Tagged_Type) then - Derive_Subprogram (New_Subp, Subp, Tagged_Type, Iface); - Append_Elmt (New_Subp, Ifaces_List); - end if; + -- If not found we derive a new primitive leaving its alias + -- attribute referencing the interface primitive - Next_Elmt (Elmt); - end loop; + if No (E) then + Derive_Subprogram + (New_Subp, Iface_Subp, Tagged_Type, Iface); - -- Complete the derivation of the interface subprograms. Assign to each - -- entity associated with abstract interfaces their aliased entity and - -- complete their decoration as hidden interface entities that will be - -- used later to build the secondary dispatch tables. + -- Propagate to the full view interface entities associated + -- with the partial view - if not Is_Empty_Elmt_List (Ifaces_List) then - if Ekind (Parent_Type) = E_Record_Type_With_Private - and then Has_Discriminants (Parent_Type) - and then Present (Full_View (Parent_Type)) - then - Parent_Base := Full_View (Parent_Type); - else - Parent_Base := Parent_Type; - end if; - - Elmt := First_Elmt (Ifaces_List); - while Present (Elmt) loop - Iface_Subp := Node (Elmt); - - -- Look for the first overriding entity in the homonym chain. - -- In this way if we are in the private part of a package spec - -- we get the last overriding subprogram. - - E := Current_Entity_In_Scope (Iface_Subp); - while Present (E) loop - if Is_Dispatching_Operation (E) - and then Scope (E) = Scope (Iface_Subp) - and then Type_Conformant (E, Iface_Subp) - and then not In_List (Ifaces_List, E) - then - exit; + elsif In_Private_Part (Current_Scope) + and then Present (Alias (E)) + and then Alias (E) = Iface_Subp + and then + List_Containing (Parent (E)) /= + Private_Declarations + (Specification + (Unit_Declaration_Node (Current_Scope))) + then + Append_Elmt (E, Primitive_Operations (Tagged_Type)); + end if; end if; - E := Homonym (E); + Next_Elmt (Prim_Elmt); end loop; - -- Create an overriding entity if not found in the homonym chain - - if not Present (E) then - Derive_Subprogram - (E, Alias (Iface_Subp), Tagged_Type, Parent_Base); - - elsif not In_List (Primitive_Operations (Tagged_Type), E) then - - -- Inherit the operation from the private view - - Append_Elmt (E, Primitive_Operations (Tagged_Type)); - end if; - - -- Complete the decoration of the hidden interface entity - - Set_Is_Hidden (Iface_Subp); - Set_Abstract_Interface_Alias (Iface_Subp, Alias (Iface_Subp)); - Set_Alias (Iface_Subp, E); - Set_Is_Abstract_Subprogram (Iface_Subp, - Is_Abstract_Subprogram (E)); - Remove_Homonym (Iface_Subp); - - -- Hidden entities associated with interfaces must have set the - -- Has_Delay_Freeze attribute to ensure that the corresponding - -- entry of the secondary dispatch table is filled when such - -- entity is frozen. - - Set_Has_Delayed_Freeze (Iface_Subp); - - Next_Elmt (Elmt); + Next_Elmt (Iface_Elmt); end loop; end if; - end Derive_Interface_Subprograms; + end Derive_Progenitor_Subprograms; ----------------------- -- Derive_Subprogram -- @@ -11764,6 +11642,10 @@ package body Sem_Ch3 is end if; end Set_Derived_Name; + -- Local variables + + Parent_Overrides_Interface_Primitive : Boolean := False; + -- Start of processing for Derive_Subprogram begin @@ -11771,6 +11653,23 @@ package body Sem_Ch3 is New_Entity (Nkind (Parent_Subp), Sloc (Derived_Type)); Set_Ekind (New_Subp, Ekind (Parent_Subp)); + -- Check whether the parent overrides an interface primitive + + if Is_Overriding_Operation (Parent_Subp) then + declare + E : Entity_Id := Parent_Subp; + begin + while Present (Overridden_Operation (E)) loop + E := Ultimate_Alias (Overridden_Operation (E)); + end loop; + + Parent_Overrides_Interface_Primitive := + Is_Dispatching_Operation (E) + and then Present (Find_Dispatching_Type (E)) + and then Is_Interface (Find_Dispatching_Type (E)); + end; + end if; + -- Check whether the inherited subprogram is a private operation that -- should be inherited but not yet made visible. Such subprograms can -- become visible at a later point (e.g., the private part of a public @@ -11816,10 +11715,11 @@ package body Sem_Ch3 is then Set_Derived_Name; - -- Ada 2005 (AI-251): Hidden entity associated with abstract interface - -- primitive + -- Ada 2005 (AI-251): Regular derivation if the parent subprogram + -- overrides an interface primitive because interface primitives + -- must be visible in the partial view of the parent (RM 7.3 (7.3/2)) - elsif Present (Abstract_Interface_Alias (Parent_Subp)) then + elsif Parent_Overrides_Interface_Primitive then Set_Derived_Name; -- The type is inheriting a private operation, so enter @@ -12035,17 +11935,102 @@ package body Sem_Ch3 is Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty) is - Op_List : constant Elist_Id := - Collect_Primitive_Operations (Parent_Type); - Ifaces_List : constant Elist_Id := New_Elmt_List; - Predef_Prims : constant Elist_Id := New_Elmt_List; + Op_List : constant Elist_Id := + Collect_Primitive_Operations (Parent_Type); + + function Check_Derived_Type return Boolean; + -- Check that all primitive inherited from Parent_Type are found in + -- the list of primitives of Derived_Type exactly in the same order. + + function Check_Derived_Type return Boolean is + E : Entity_Id; + Elmt : Elmt_Id; + List : Elist_Id; + New_Subp : Entity_Id; + Op_Elmt : Elmt_Id; + Subp : Entity_Id; + + begin + -- Traverse list of entities in the current scope searching for + -- an incomplete type whose full-view is derived type + + E := First_Entity (Scope (Derived_Type)); + while Present (E) + and then E /= Derived_Type + loop + if Ekind (E) = E_Incomplete_Type + and then Present (Full_View (E)) + and then Full_View (E) = Derived_Type + then + -- Disable this test if Derived_Type completes an incomplete + -- type because in such case more primitives can be added + -- later to the list of primitives of Derived_Type by routine + -- Process_Incomplete_Dependents + + return True; + end if; + + E := Next_Entity (E); + end loop; + + List := Collect_Primitive_Operations (Derived_Type); + Elmt := First_Elmt (List); + + Op_Elmt := First_Elmt (Op_List); + while Present (Op_Elmt) loop + Subp := Node (Op_Elmt); + New_Subp := Node (Elmt); + + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. + + exit when Present (Interface_Alias (Subp)); + + -- Handle hidden entities + + if not Is_Predefined_Dispatching_Operation (Subp) + and then Is_Hidden (Subp) + then + if Present (New_Subp) + and then Primitive_Names_Match (Subp, New_Subp) + then + Next_Elmt (Elmt); + end if; + + else + if not Present (New_Subp) + or else Ekind (Subp) /= Ekind (New_Subp) + or else not Primitive_Names_Match (Subp, New_Subp) + then + return False; + end if; + + Next_Elmt (Elmt); + end if; + + Next_Elmt (Op_Elmt); + end loop; + + return True; + end Check_Derived_Type; + + -- Local variables + + Alias_Subp : Entity_Id; Act_List : Elist_Id; - Act_Elmt : Elmt_Id; + Act_Elmt : Elmt_Id := No_Elmt; + Act_Subp : Entity_Id := Empty; Elmt : Elmt_Id; + Need_Search : Boolean := False; New_Subp : Entity_Id := Empty; Parent_Base : Entity_Id; Subp : Entity_Id; + -- Start of processing for Derive_Subprograms + begin if Ekind (Parent_Type) = E_Record_Type_With_Private and then Has_Discriminants (Parent_Type) @@ -12056,126 +12041,266 @@ package body Sem_Ch3 is Parent_Base := Parent_Type; end if; - -- Derive primitives inherited from the parent. Note that if the generic - -- actual is present, this is not really a type derivation, it is a - -- completion within an instance. - if Present (Generic_Actual) then Act_List := Collect_Primitive_Operations (Generic_Actual); Act_Elmt := First_Elmt (Act_List); - else - Act_Elmt := No_Elmt; end if; - -- Literals are derived earlier in the process of building the derived - -- type, and are skipped here. + -- Derive primitives inherited from the parent. Note that if the generic + -- actual is present, this is not really a type derivation, it is a + -- completion within an instance. + + -- Case 1: Derived_Type does not implement interfaces - Elmt := First_Elmt (Op_List); - while Present (Elmt) loop - Subp := Node (Elmt); + if not Is_Tagged_Type (Derived_Type) + or else (not Has_Interfaces (Derived_Type) + and then not (Present (Generic_Actual) + and then + Has_Interfaces (Generic_Actual))) + then + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); - if Ekind (Subp) /= E_Enumeration_Literal then + -- Literals are derived earlier in the process of building the + -- derived type, and are skipped here. - if Ada_Version >= Ada_05 - and then Present (Abstract_Interface_Alias (Subp)) - then + if Ekind (Subp) = E_Enumeration_Literal then null; - -- We derive predefined primitives in a later round to ensure that - -- they are always added to the list of primitives after user - -- defined primitives (because predefined primitives have to be - -- skipped when matching the operations of a parent interface to - -- those of a concrete type). However it is unclear why those - -- primitives would be needed in an instantiation??? + -- The actual is a direct descendant and the common primitive + -- operations appear in the same order. - elsif Is_Predefined_Dispatching_Operation (Subp) then - Append_Elmt (Subp, Predef_Prims); + -- If the generic parent type is present, the derived type is an + -- instance of a formal derived type, and within the instance its + -- operations are those of the actual. We derive from the formal + -- type but make the inherited operations aliases of the + -- corresponding operations of the actual. - elsif No (Generic_Actual) then - Derive_Subprogram (New_Subp, Subp, Derived_Type, Parent_Base); + else + Derive_Subprogram + (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); - -- Ada 2005 (AI-251): Add derivation of an abstract interface - -- primitive to the list of entities to which we have to - -- associate an aliased entity. + if Present (Act_Elmt) then + Next_Elmt (Act_Elmt); + end if; + end if; - if Ada_Version >= Ada_05 - and then Is_Dispatching_Operation (Subp) - and then Present (Find_Dispatching_Type (Subp)) - and then Is_Interface (Find_Dispatching_Type (Subp)) - then - Append_Elmt (New_Subp, Ifaces_List); + Next_Elmt (Elmt); + end loop; + + -- Case 2: Derived_Type implements interfaces + + else + -- If the parent type has no predefined primitives we remove + -- predefined primitives from the list of primitives of generic + -- actual to simplify the complexity of this algorithm. + + if Present (Generic_Actual) then + declare + Has_Predefined_Primitives : Boolean := False; + + begin + -- Check if the parent type has predefined primitives + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if Is_Predefined_Dispatching_Operation (Subp) + and then not Comes_From_Source (Ultimate_Alias (Subp)) + then + Has_Predefined_Primitives := True; + exit; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Remove predefined primitives of Generic_Actual. We must use + -- an auxiliary list because in case of tagged types the value + -- returned by Collect_Primitive_Operations is the value stored + -- in its Primitive_Operations attribute (and we don't want to + -- modify its current contents). + + if not Has_Predefined_Primitives then + declare + Aux_List : constant Elist_Id := New_Elmt_List; + + begin + Elmt := First_Elmt (Act_List); + while Present (Elmt) loop + Subp := Node (Elmt); + + if not Is_Predefined_Dispatching_Operation (Subp) + or else Comes_From_Source (Subp) + then + Append_Elmt (Subp, Aux_List); + end if; + + Next_Elmt (Elmt); + end loop; + + Act_List := Aux_List; + end; end if; - else - -- If the generic parent type is present, the derived type - -- is an instance of a formal derived type, and within the - -- instance its operations are those of the actual. We derive - -- from the formal type but make the inherited operations - -- aliases of the corresponding operations of the actual. - - if Is_Interface (Parent_Type) - and then Root_Type (Derived_Type) /= Parent_Type + Act_Elmt := First_Elmt (Act_List); + Act_Subp := Node (Act_Elmt); + end; + end if; + + -- Stage 1: If the generic actual is not present we derive the + -- primitives inherited from the parent type. If the generic parent + -- type is present, the derived type is an instance of a formal + -- derived type, and within the instance its operations are those of + -- the actual. We derive from the formal type but make the inherited + -- operations aliases of the corresponding operations of the actual. + + Elmt := First_Elmt (Op_List); + while Present (Elmt) loop + Subp := Node (Elmt); + Alias_Subp := Ultimate_Alias (Subp); + + -- At this early stage Derived_Type has no entities with attribute + -- Interface_Alias. In addition, such primitives are always + -- located at the end of the list of primitives of Parent_Type. + -- Therefore, if found we can safely stop processing pending + -- entities. + + exit when Present (Interface_Alias (Subp)); + + -- If the generic actual is present find the corresponding + -- operation in the generic actual. If the parent type is a + -- direct ancestor of the derived type then, even if it is an + -- interface, the operations are inherited from the primary + -- dispatch table and are in the proper order. If we detect here + -- that primitives are not in the same order we traverse the list + -- of primitive operations of the actual to find the one that + -- implements the interface primitive. + + if Need_Search + or else + (Present (Generic_Actual) + and then Present (Act_Subp) + and then not Primitive_Names_Match (Subp, Act_Subp)) + then + pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual)); + pragma Assert (Is_Interface (Parent_Base)); + + -- Remember that we need searching for all the pending + -- primitives + + Need_Search := True; + + -- Handle entities associated with interface primitives + + if Present (Alias (Subp)) + and then Is_Interface (Find_Dispatching_Type (Alias (Subp))) + and then not Is_Predefined_Dispatching_Operation (Subp) then - -- Find the corresponding operation in the generic actual. - -- Given that the actual is not a direct descendant of the - -- parent, as in Ada 95, the primitives are not necessarily - -- in the same order, so we have to traverse the list of - -- primitive operations of the actual to find the one that - -- implements the interface operation. - - -- Note that if the parent type is the direct ancestor of - -- the derived type, then even if it is an interface the - -- operations are inherited from the primary dispatch table - -- and are in the proper order. + Act_Subp := + Find_Primitive_Covering_Interface + (Tagged_Type => Generic_Actual, + Iface_Prim => Subp); + -- Handle predefined primitives plus the rest of user-defined + -- primitives + + else Act_Elmt := First_Elmt (Act_List); while Present (Act_Elmt) loop - exit when - Abstract_Interface_Alias (Node (Act_Elmt)) = Subp; + Act_Subp := Node (Act_Elmt); + + exit when Primitive_Names_Match (Subp, Act_Subp) + and then Type_Conformant (Subp, Act_Subp, + Skip_Controlling_Formals => True) + and then No (Interface_Alias (Act_Subp)); + Next_Elmt (Act_Elmt); end loop; end if; + end if; - -- If the formal is not an interface, the actual is a direct - -- descendant and the common primitive operations appear in - -- the same order. + -- Case 1: If the parent is a limited interface then it has the + -- predefined primitives of synchronized interfaces. However, the + -- actual type may be a non-limited type and hence it does not + -- have such primitives. - Derive_Subprogram - (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt)); + if Present (Generic_Actual) + and then not Present (Act_Subp) + and then Is_Limited_Interface (Parent_Base) + and then Is_Predefined_Interface_Primitive (Subp) + then + null; - if Present (Act_Elmt) then - Next_Elmt (Act_Elmt); + -- Case 2: Inherit entities associated with interfaces that + -- were not covered by the parent type. We exclude here null + -- interface primitives because they do not need special + -- management. + + elsif Present (Alias (Subp)) + and then Is_Interface (Find_Dispatching_Type (Alias_Subp)) + and then not + (Nkind (Parent (Alias_Subp)) = N_Procedure_Specification + and then Null_Present (Parent (Alias_Subp))) + then + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Alias_Subp, + Derived_Type => Derived_Type, + Parent_Type => Find_Dispatching_Type (Alias_Subp), + Actual_Subp => Act_Subp); + + if No (Generic_Actual) then + Set_Alias (New_Subp, Subp); end if; - end if; - end if; - Next_Elmt (Elmt); - end loop; + -- Case 3: Common derivation - -- Inherit additional operations from progenitor interfaces. However, - -- if the derived type is a generic actual, there are not new primitive - -- operations for the type, because it has those of the actual, so - -- nothing needs to be done. The renamings generated above are not - -- primitive operations, and their purpose is simply to make the proper - -- operations visible within an instantiation. + else + Derive_Subprogram + (New_Subp => New_Subp, + Parent_Subp => Subp, + Derived_Type => Derived_Type, + Parent_Type => Parent_Base, + Actual_Subp => Act_Subp); + end if; - if Ada_Version >= Ada_05 - and then Is_Tagged_Type (Derived_Type) - and then No (Generic_Actual) - then - Derive_Interface_Subprograms (Parent_Type, Derived_Type, Ifaces_List); - end if; + -- No need to update Act_Elm if we must search for the + -- corresponding operation in the generic actual - -- Derive predefined primitives + if not Need_Search + and then Present (Act_Elmt) + then + Next_Elmt (Act_Elmt); + Act_Subp := Node (Act_Elmt); + end if; - if not Is_Empty_Elmt_List (Predef_Prims) then - Elmt := First_Elmt (Predef_Prims); - while Present (Elmt) loop - Derive_Subprogram - (New_Subp, Node (Elmt), Derived_Type, Parent_Base); Next_Elmt (Elmt); end loop; + + -- Inherit additional operations from progenitors. If the derived + -- type is a generic actual, there are not new primitive operations + -- for the type because it has those of the actual, and therefore + -- nothing needs to be done. The renamings generated above are not + -- primitive operations, and their purpose is simply to make the + -- proper operations visible within an instantiation. + + if No (Generic_Actual) then + Derive_Progenitor_Subprograms (Parent_Base, Derived_Type); + end if; end if; + + -- Final check: Direct descendants must have their primitives in the + -- same order. We exclude from this test non-tagged types and instances + -- of formal derived types. We skip this test if we have already + -- reported serious errors in the sources. + + pragma Assert (not Is_Tagged_Type (Derived_Type) + or else Present (Generic_Actual) + or else Serious_Errors_Detected > 0 + or else Check_Derived_Type); end Derive_Subprograms; -------------------------------- @@ -14046,48 +14171,9 @@ package body Sem_Ch3 is (Iface : Entity_Id; Typ : Entity_Id) return Boolean is - Iface_Elmt : Elmt_Id; - I_Name : Entity_Id; - begin - if No (Abstract_Interfaces (Typ)) then - return False; - - else - Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); - while Present (Iface_Elmt) loop - I_Name := Node (Iface_Elmt); - if Base_Type (I_Name) = Base_Type (Iface) then - return True; - - elsif Is_Derived_Type (I_Name) - and then Is_Ancestor (Iface, I_Name) - then - return True; - - else - Next_Elmt (Iface_Elmt); - end if; - end loop; - - -- For concurrent record types, they have the interfaces of the - -- parent synchronized type. However these have no ancestors that - -- implement anything, so assume it is a progenitor. - -- Should be cleaned up in Collect_Abstract_Interfaces??? - - if Is_Concurrent_Record_Type (Typ) then - return Present (Abstract_Interfaces (Typ)); - end if; - - -- If type is a derived type, check recursively its ancestors - - if Is_Derived_Type (Typ) then - return Etype (Typ) = Iface - or else Is_Progenitor (Iface, Etype (Typ)); - else - return False; - end if; - end if; + return Implements_Interface (Typ, Iface, + Exclude_Parents => True); end Is_Progenitor; ------------------------------ @@ -15366,8 +15452,8 @@ package body Sem_Ch3 is -- Handle entities in the list of abstract interfaces - if Present (Abstract_Interfaces (Typ)) then - Iface_Elmt := First_Elmt (Abstract_Interfaces (Typ)); + if Present (Interfaces (Typ)) then + Iface_Elmt := First_Elmt (Interfaces (Typ)); while Present (Iface_Elmt) loop Iface := Node (Iface_Elmt); @@ -15697,6 +15783,9 @@ package body Sem_Ch3 is -- If the private view was tagged, copy the new primitive operations -- from the private view to the full view. + -- Note: Subprograms covering interface primitives were previously + -- propagated to the full view by Derive_Progenitor_Primitives + if Is_Tagged_Type (Full_T) and then not Is_Concurrent_Type (Full_T) then @@ -16902,11 +16991,11 @@ package body Sem_Ch3 is -- These flags must be initialized before calling Process_Discriminants -- because this routine makes use of them. - Set_Ekind (T, E_Record_Type); - Set_Etype (T, T); - Init_Size_Align (T); - Set_Abstract_Interfaces (T, No_Elist); - Set_Stored_Constraint (T, No_Elist); + Set_Ekind (T, E_Record_Type); + Set_Etype (T, T); + Init_Size_Align (T); + Set_Interfaces (T, No_Elist); + Set_Stored_Constraint (T, No_Elist); -- Normal case @@ -16952,7 +17041,7 @@ package body Sem_Ch3 is if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then - Check_Abstract_Interfaces (N, Def); + Check_Interfaces (N, Def); declare Ifaces_List : Elist_Id; @@ -16961,12 +17050,12 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Collect the list of progenitors that are not -- already in the parents. - Collect_Abstract_Interfaces - (T => T, - Ifaces_List => Ifaces_List, - Exclude_Parent_Interfaces => True); + Collect_Interfaces + (T => T, + Ifaces_List => Ifaces_List, + Exclude_Parents => True); - Set_Abstract_Interfaces (T, Ifaces_List); + Set_Interfaces (T, Ifaces_List); end; end if; @@ -17013,7 +17102,7 @@ package body Sem_Ch3 is -- Ada 2005 (AI-251): Addition of the Tag corresponding to all the -- implemented interfaces. - if Has_Abstract_Interfaces (T) then + if Has_Interfaces (T) then Add_Interface_Tag_Components (N, T); end if; end if; @@ -17050,11 +17139,7 @@ package body Sem_Ch3 is if Is_Tagged and then not Is_Empty_List (Interface_List (Def)) then - declare - Ifaces_List : constant Elist_Id := New_Elmt_List; - begin - Derive_Interface_Subprograms (T, T, Ifaces_List); - end; + Derive_Progenitor_Subprograms (T, T); end if; end Record_Type_Declaration; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 0dff777..a341069 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -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); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index db5c112..b59cd4b 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index b4b1dcf..037ccf9 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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. - - ------------------------- - -- Error_Msg_Operation -- - ------------------------- + procedure Check_Convention (Op : Entity_Id) is + Iface_Elmt : Elmt_Id; + Iface_Prim_Elmt : Elmt_Id; + Iface_Prim : Entity_Id; - procedure Error_Msg_Operation (Op : Entity_Id) is - begin - Error_Msg_Name_1 := Chars (Op); + 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); + + 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); - end if; - end if; - end Error_Msg_Operation; - - -- Local variables - - 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); + -- Avoid cascading errors - Error_Msg_Operation (Op); - Error_Msg_Operation (Second_Prim_Op); - - -- Avoid cascading errors + return; + end if; - return; - end if; + Next_Elmt (Iface_Prim_Elmt); + end loop; - 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; diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads index a535bd1..689ac8b 100644 --- a/gcc/ada/sem_ch6.ads +++ b/gcc/ada/sem_ch6.ads @@ -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)). diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 9482b56..8a85b11 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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); diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index c990800..a8eb3df 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -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. diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads index 496a003..c0195ec 100644 --- a/gcc/ada/sem_disp.ads +++ b/gcc/ada/sem_disp.ads @@ -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 diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb index c36125f..4a170d8 100644 --- a/gcc/ada/sem_type.adb +++ b/gcc/ada/sem_type.adb @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 95fd0c5..895491e 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 175b315..aeedc7d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 0545f25..4306ce4 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -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 => |