diff options
author | Ed Schonberg <schonberg@adacore.com> | 2005-11-15 15:02:46 +0100 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2005-11-15 15:02:46 +0100 |
commit | 950d3e7dae82649e89b09b4b471914a061bad5b9 (patch) | |
tree | b8252a5759d785b023e59a4ccb542ef6464937aa /gcc/ada | |
parent | 04814daddf1ff25af29ca2bf11e3e0dbbfc9e780 (diff) | |
download | gcc-950d3e7dae82649e89b09b4b471914a061bad5b9.zip gcc-950d3e7dae82649e89b09b4b471914a061bad5b9.tar.gz gcc-950d3e7dae82649e89b09b4b471914a061bad5b9.tar.bz2 |
sem_ch3.ads, [...] (Build_Discriminal): Add link to original discriminant.
2005-11-14 Ed Schonberg <schonberg@adacore.com>
Javier Miranda <miranda@adacore.com>
* sem_ch3.ads, sem_ch3.adb (Build_Discriminal): Add link to original
discriminant.
(Build_Private_Derived_Type): The entity of the created full view of the
derived type does not come from source. If after installing the private
declarations of the parent scope the parent is still private, use its
full view to construct the full declaration of the derived type.
(Build_Derived_Record_Type): Relax the condition that controls the
execution of the check that verifies that the partial view and
the full view agree in the set of implemented interfaces. In
addition, this test now only takes into account the progenitors.
(Derive_Interface_Subprograms): No need to derive subprograms
of ancestors that are interfaces.
(Derive_Subprograms): Remove formal No_Predefined_Prims and the
associated code.
Change name Is_Package to Is_Package_Or_Generic_Package
(Complete_Subprograms_Derivation): Handle the case in which the full
view is a transitive derivation of the ancestor of the partial view.
(Process_Full_View): Rename local subprogram Find_Interface_In_
Descendant to Find_Ancestor_Interface to leave the code more clear.
Remove wrong code that avoids the generation of an error message
when the immediate ancestor of the partial view is an interface.
In addition some minor reorganization of the code has been done to
leave it more clear.
(Analyze_Type_Declaration): If type has previous incomplete tagged
partial view, inherit properly its primitive operations.
(Collect_Interfaces): Make public, for analysis of formal
interfaces.
(Analyze_Interface_Declaration): New procedure for use for regular and
formal interface declarations.
(Build_Derived_Record_Type): Add support for private types to the code
that checks if a tagged type implements abstract interfaces.
(Check_Aliased_Component_Type): The test applies in the spec of an
instance as well.
(Access_Type_Declaration): Clean up declaration of malformed type
declared as an access to its own classwide type, to prevent cascaded
crash.
(Collect_Interfaces): For private extensions and for derived task types
and derived protected types, the parent may be an interface that must
be included in the interface list.
(Access_Definition): If the designated type is an interface that may
contain tasks, create Master_Id for it before analyzing the expression
of the declaration, which may be an allocator.
(Record_Type_Declaration): Set properly the interface kind, for use
in allocators, the creation of master id's for task interfaces, etc.
From-SVN: r107000
Diffstat (limited to 'gcc/ada')
-rw-r--r-- | gcc/ada/sem_ch3.adb | 434 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.ads | 21 |
2 files changed, 261 insertions, 194 deletions
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index adefc6a..a799427 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -171,14 +171,6 @@ package body Sem_Ch3 is -- False is for an implicit derived full type for a type derived from a -- private type (see Build_Derived_Type). - procedure Collect_Interfaces - (N : Node_Id; - Derived_Type : Entity_Id); - -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type. - -- Collect the list of interfaces that are not already implemented by the - -- ancestors. This is the list of interfaces for which we must provide - -- additional tag components. - procedure Complete_Subprograms_Derivation (Partial_View : Entity_Id; Derived_Type : Entity_Id); @@ -799,6 +791,20 @@ package body Sem_Ch3 is Set_Has_Delayed_Freeze (Current_Scope); end if; + -- Ada 2005: if the designated type is an interface that may contain + -- tasks, create a Master entity for the declaration. This must be done + -- before expansion of the full declaration, because the declaration + -- may include an expression that is an allocator, whose expansion needs + -- the proper Master for the created tasks. + + if Nkind (Related_Nod) = N_Object_Declaration + and then Expander_Active + and then Is_Interface (Desig_Type) + and then Is_Limited_Record (Desig_Type) + then + Build_Class_Wide_Master (Anon_Type); + end if; + return Anon_Type; end Access_Definition; @@ -985,6 +991,10 @@ package body Sem_Ch3 is then Error_Msg_N ("access type cannot designate its own classwide type", S); + + -- Clean up indication of tagged status to prevent cascaded errors + + Set_Is_Tagged_Type (T, False); end if; Set_Etype (T, T); @@ -1584,6 +1594,33 @@ package body Sem_Ch3 is Set_Is_Pure (T, F); end Analyze_Incomplete_Type_Decl; + ----------------------------------- + -- Analyze_Interface_Declaration -- + ----------------------------------- + + procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id) is + begin + 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)); + + -- Type is abstract if full declaration carries keyword, or if + -- previous partial view did. + + Set_Is_Abstract (T); + Set_Is_Interface (T); + + Set_Is_Limited_Interface (T, Limited_Present (Def)); + Set_Is_Protected_Interface (T, Protected_Present (Def)); + Set_Is_Synchronized_Interface (T, Synchronized_Present (Def)); + Set_Is_Task_Interface (T, Task_Present (Def)); + Set_Abstract_Interfaces (T, New_Elmt_List); + Set_Primitive_Operations (T, New_Elmt_List); + end Analyze_Interface_Declaration; + ----------------------------- -- Analyze_Itype_Reference -- ----------------------------- @@ -1958,7 +1995,7 @@ package body Sem_Ch3 is if Constant_Present (N) and then No (E) then - if not Is_Package (Current_Scope) then + if not Is_Package_Or_Generic_Package (Current_Scope) then Error_Msg_N ("invalid context for deferred constant declaration ('R'M 7.4)", N); @@ -2589,7 +2626,7 @@ package body Sem_Ch3 is return; end if; - if (not Is_Package (Current_Scope) + if (not Is_Package_Or_Generic_Package (Current_Scope) and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration) or else In_Private_Part (Current_Scope) @@ -3011,6 +3048,51 @@ package body Sem_Ch3 is or else In_Package_Body (Current_Scope)); + procedure Check_Ops_From_Incomplete_Type; + -- If there is a tagged incomplete partial view of the type, transfer + -- its operations to the full view, and indicate that the type of the + -- controlling parameter (s) is this full view. + + ------------------------------------ + -- Check_Ops_From_Incomplete_Type -- + ------------------------------------ + + procedure Check_Ops_From_Incomplete_Type is + Elmt : Elmt_Id; + Formal : Entity_Id; + Op : Entity_Id; + + begin + if Prev /= T + and then Ekind (Prev) = E_Incomplete_Type + and then Is_Tagged_Type (Prev) + and then Is_Tagged_Type (T) + then + Elmt := First_Elmt (Primitive_Operations (Prev)); + while Present (Elmt) loop + Op := Node (Elmt); + Prepend_Elmt (Op, Primitive_Operations (T)); + + Formal := First_Formal (Op); + while Present (Formal) loop + if Etype (Formal) = Prev then + Set_Etype (Formal, T); + end if; + + Next_Formal (Formal); + end loop; + + if Etype (Op) = Prev then + Set_Etype (Op, T); + end if; + + Next_Elmt (Elmt); + end loop; + end if; + end Check_Ops_From_Incomplete_Type; + + -- Start of processing for Analyze_Type_Declaration + begin Prev := Find_Type_Name (N); @@ -3149,6 +3231,7 @@ package body Sem_Ch3 is -- Some common processing for all types Set_Depends_On_Private (T, Has_Private_Component (T)); + Check_Ops_From_Incomplete_Type; -- Both the declared entity, and its anonymous base type if one -- was created, need freeze nodes allocated. @@ -3787,7 +3870,8 @@ package body Sem_Ch3 is if Number_Dimensions (Parent_Type) = 1 and then not Is_Limited_Type (Parent_Type) and then not Is_Derived_Type (Parent_Type) - and then not Is_Package (Scope (Base_Type (Parent_Type))) + and then not Is_Package_Or_Generic_Package + (Scope (Base_Type (Parent_Type))) then if not Is_Constrained (Parent_Type) and then Is_Constrained (Derived_Type) @@ -4438,6 +4522,7 @@ package body Sem_Ch3 is Full_Decl := New_Copy_Tree (N); Full_Der := New_Copy (Derived_Type); Set_Comes_From_Source (Full_Decl, False); + Set_Comes_From_Source (Full_Der, False); Insert_After (N, Full_Decl); @@ -4493,8 +4578,18 @@ package body Sem_Ch3 is -- view, the completion does not derive them anew. if not Is_Tagged_Type (Parent_Type) then - Build_Derived_Record_Type - (Full_Decl, Parent_Type, Full_Der, False); + + -- If the parent is itself derived from another private type, + -- installing the private declarations has not affected its + -- privacy status, so use its own full view explicitly. + + if Is_Private_Type (Parent_Type) then + Build_Derived_Record_Type + (Full_Decl, Full_View (Parent_Type), Full_Der, False); + else + Build_Derived_Record_Type + (Full_Decl, Parent_Type, Full_Der, False); + end if; else -- If full view of parent is tagged, the completion @@ -5895,113 +5990,37 @@ package body Sem_Ch3 is Collect_Interfaces (Type_Definition (N), Derived_Type); end if; - -- Check that the full view and the partial view agree - -- in the set of implemented interfaces + -- Ada 2005 (AI-251): The progenitor types specified in a private + -- extension declaration and the progenitor types specified in the + -- corresponding declaration of a record extension given in the + -- private part need not be the same; the only requirement is that + -- the private extension must be descended from each interface + -- from which the record extension is descended (AARM 7.3, 20.1/2) - if Has_Private_Declaration (Derived_Type) - and then Present (Abstract_Interfaces (Derived_Type)) - and then not Is_Empty_Elmt_List - (Abstract_Interfaces (Derived_Type)) - then + if Has_Private_Declaration (Derived_Type) then declare N_Partial : constant Node_Id := Parent (Tagged_Partial_View); - N_Full : constant Node_Id := Parent (Derived_Type); - - Iface_Partial : Entity_Id; - Iface_Full : Entity_Id; - Num_Ifaces_Partial : Natural := 0; - Num_Ifaces_Full : Natural := 0; - Same_Interfaces : Boolean := True; + Iface_Partial : Entity_Id; begin - if Nkind (N_Partial) /= N_Private_Extension_Declaration then - Error_Msg_N - ("(Ada 2005) interfaces only allowed in private" - & " extension declarations", N_Partial); - end if; - - -- Count the interfaces implemented by the partial view - if Nkind (N_Partial) = N_Private_Extension_Declaration and then not Is_Empty_List (Interface_List (N_Partial)) then Iface_Partial := First (Interface_List (N_Partial)); - while Present (Iface_Partial) loop - Num_Ifaces_Partial := Num_Ifaces_Partial + 1; - Next (Iface_Partial); - end loop; - end if; - - -- Take into account the case in which the partial - -- view is a directly derived from an interface - - if Is_Interface (Etype - (Defining_Identifier (N_Partial))) - then - Num_Ifaces_Partial := Num_Ifaces_Partial + 1; - end if; - - -- Count the interfaces implemented by the full view - - if not Is_Empty_List (Interface_List - (Type_Definition (N_Full))) - then - Iface_Full := First (Interface_List - (Type_Definition (N_Full))); - while Present (Iface_Full) loop - Num_Ifaces_Full := Num_Ifaces_Full + 1; - Next (Iface_Full); - end loop; - end if; - - -- Take into account the case in which the full - -- view is a directly derived from an interface - - if Is_Interface (Etype - (Defining_Identifier (N_Full))) - then - Num_Ifaces_Full := Num_Ifaces_Full + 1; - end if; - - if Num_Ifaces_Full > 0 - and then Num_Ifaces_Full = Num_Ifaces_Partial - then - -- Check that the full-view and the private-view have - -- the same list of interfaces. - - Iface_Full := First (Interface_List - (Type_Definition (N_Full))); - while Present (Iface_Full) loop - Iface_Partial := First (Interface_List (N_Partial)); - while Present (Iface_Partial) - and then Etype (Iface_Partial) /= Etype (Iface_Full) - loop - Next (Iface_Partial); - end loop; - -- If not found we check if the partial view is a - -- direct derivation of the interface. - - if not Present (Iface_Partial) - and then - Etype (Tagged_Partial_View) /= Etype (Iface_Full) + while Present (Iface_Partial) loop + if not Interface_Present_In_Ancestor + (Derived_Type, Etype (Iface_Partial)) then - Same_Interfaces := False; + Error_Msg_N + ("(Ada 2005) full type and private extension must" + & " have the same progenitors", Derived_Type); exit; end if; - Next (Iface_Full); + Next (Iface_Partial); end loop; end if; - - if Num_Ifaces_Partial /= Num_Ifaces_Full - or else not Same_Interfaces - then - Error_Msg_N - ("(Ada 2005) full declaration and private declaration" - & " must have the same list of interfaces", - Derived_Type); - end if; end; end if; end if; @@ -6132,7 +6151,14 @@ package body Sem_Ch3 is E : Entity_Id; begin - E := Derived_Type; + -- Handle private types + + if Present (Full_View (Derived_Type)) then + E := Full_View (Derived_Type); + else + E := Derived_Type; + end if; + loop if Is_Interface (E) or else (Present (Abstract_Interfaces (E)) @@ -6145,11 +6171,22 @@ package body Sem_Ch3 is exit when Etype (E) = E + -- Handle private types + + or else (Present (Full_View (Etype (E))) + and then Full_View (Etype (E)) = E) + -- Protect the frontend against wrong source or else Etype (E) = Derived_Type; - E := Etype (E); + -- Climb to the ancestor type handling private types + + if Present (Full_View (Etype (E))) then + E := Full_View (Etype (E)); + else + E := Etype (E); + end if; end loop; end; end if; @@ -6168,7 +6205,7 @@ package body Sem_Ch3 is if Present (Tagged_Partial_View) then Derive_Subprograms - (Parent_Type, Derived_Type, Predefined_Prims_Only => True); + (Parent_Type, Derived_Type); Complete_Subprograms_Derivation (Partial_View => Tagged_Partial_View, @@ -6452,10 +6489,11 @@ package body Sem_Ch3 is then CR_Disc := Make_Defining_Identifier (Sloc (Discrim), Chars (Discrim)); - Set_Ekind (CR_Disc, E_In_Parameter); - Set_Mechanism (CR_Disc, Default_Mechanism); - Set_Etype (CR_Disc, Etype (Discrim)); - Set_CR_Discriminant (Discrim, CR_Disc); + Set_Ekind (CR_Disc, E_In_Parameter); + Set_Mechanism (CR_Disc, Default_Mechanism); + Set_Etype (CR_Disc, Etype (Discrim)); + Set_Discriminal_Link (CR_Disc, Discrim); + Set_CR_Discriminant (Discrim, CR_Disc); end if; end Build_Discriminal; @@ -7179,7 +7217,7 @@ package body Sem_Ch3 is if Is_Aliased (C) and then Has_Discriminants (Etype (C)) and then not Is_Constrained (Etype (C)) - and then not In_Instance + and then not In_Instance_Body and then Ada_Version < Ada_05 then Error_Msg_N @@ -7194,7 +7232,8 @@ package body Sem_Ch3 is if Has_Aliased_Components (T) and then Has_Discriminants (Component_Type (T)) and then not Is_Constrained (Component_Type (T)) - and then not In_Instance + and then not In_Instance_Body + and then Ada_Version < Ada_05 then Error_Msg_N ("aliased component type must be constrained ('R'M 3.6(11))", @@ -7363,7 +7402,7 @@ package body Sem_Ch3 is Post_Error; end if; - elsif Is_Package (E) then + elsif Is_Package_Or_Generic_Package (E) then if Unit_Requires_Body (E) then if not Has_Completion (E) and then Nkind (Parent (Unit_Declaration_Node (E))) /= @@ -7643,6 +7682,29 @@ package body Sem_Ch3 is Next (Intf); end loop; + + -- A type extension may be written as a derivation from an interface. + -- The completion will have to implement the same, or derive from a + -- type that implements it as well. + + elsif Nkind (N) = N_Private_Extension_Declaration + and then Is_Interface (Etype (Derived_Type)) + then + Add_Interface (Etype (Derived_Type)); + end if; + + -- Same for task and protected types, that can derive directly from + -- an interface (and implement additional interfaces that will be + -- present in the interface list of the declaration). + + if Nkind (N) = N_Task_Type_Declaration + or else Nkind (N) = N_Protected_Type_Declaration + or else Nkind (N) = N_Single_Protected_Declaration + or else Nkind (N) = N_Single_Task_Declaration + then + if Is_Interface (Etype (Derived_Type)) then + Add_Interface (Etype (Derived_Type)); + end if; end if; end Collect_Interfaces; @@ -7873,6 +7935,25 @@ package body Sem_Ch3 is E : Entity_Id; begin + -- Handle the case in which the full-view is a transitive + -- derivation of the ancestor of the partial view. + + -- type I is interface; + -- type T is new I with ... + + -- package H is + -- type DT is new I with private; + -- private + -- type DT is new T with ... + -- end; + + if Etype (Partial_View) /= Etype (Derived_Type) + and then Is_Interface (Etype (Partial_View)) + and then Is_Ancestor (Etype (Partial_View), Etype (Derived_Type)) + then + return; + end if; + if Is_Tagged_Type (Partial_View) then Elmt_P := First_Elmt (Primitive_Operations (Partial_View)); else @@ -8795,7 +8876,7 @@ package body Sem_Ch3 is -- For concurrent types, the associated record value type carries the same -- discriminants, so when we constrain a concurrent type, we must constrain - -- the value type as well. + -- the corresponding record type as well. procedure Constrain_Concurrent (Def_Id : in out Entity_Id; @@ -9970,10 +10051,12 @@ package body Sem_Ch3 is then AI := First_Elmt (Abstract_Interfaces (T)); while Present (AI) loop - Derive_Subprograms - (Parent_Type => Node (AI), - Derived_Type => Derived_Type, - No_Predefined_Prims => True); + if not Is_Ancestor (Node (AI), Derived_Type) then + Derive_Subprograms + (Parent_Type => Node (AI), + Derived_Type => Derived_Type, + No_Predefined_Prims => True); + end if; Next_Elmt (AI); end loop; @@ -10391,8 +10474,7 @@ package body Sem_Ch3 is (Parent_Type : Entity_Id; Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty; - No_Predefined_Prims : Boolean := False; - Predefined_Prims_Only : Boolean := False) + No_Predefined_Prims : Boolean := False) is Op_List : constant Elist_Id := Collect_Primitive_Operations (Parent_Type); @@ -10436,7 +10518,13 @@ package body Sem_Ch3 is if No_Predefined_Prims and then Is_Predef then null; - elsif Predefined_Prims_Only and then not Is_Predef then + -- We don't need to derive alias entities associated with + -- abstract interfaces + + elsif Is_Dispatching_Operation (Subp) + and then Present (Alias (Subp)) + and then Present (Abstract_Interface_Alias (Subp)) + then null; elsif No (Generic_Actual) then @@ -13098,15 +13186,15 @@ package body Sem_Ch3 is Full_Parent : Entity_Id; Full_Indic : Node_Id; - function Find_Interface_In_Descendant + function Find_Ancestor_Interface (Typ : Entity_Id) return Entity_Id; -- Find an implemented interface in the derivation chain of Typ - ---------------------------------- - -- Find_Interface_In_Descendant -- - ---------------------------------- + ----------------------------- + -- Find_Ancestor_Interface -- + ----------------------------- - function Find_Interface_In_Descendant + function Find_Ancestor_Interface (Typ : Entity_Id) return Entity_Id is T : Entity_Id; @@ -13127,7 +13215,7 @@ package body Sem_Ch3 is end loop; return Empty; - end Find_Interface_In_Descendant; + end Find_Ancestor_Interface; -- Start of processing for Process_Full_View @@ -13180,37 +13268,36 @@ package body Sem_Ch3 is Iface_Def : Node_Id; begin - Iface := Find_Interface_In_Descendant (Full_T); + Iface := Find_Ancestor_Interface (Full_T); if Present (Iface) then Iface_Def := Type_Definition (Parent (Iface)); - end if; - -- The full view derives from an interface descendant, but the - -- partial view does not share the same tagged type. + -- The full view derives from an interface descendant, but the + -- partial view does not share the same tagged type. - if Present (Iface) - and then Is_Tagged_Type (Priv_T) - and then Etype (Full_T) /= Etype (Priv_T) - then - Error_Msg_N ("(Ada 2005) tagged partial view cannot be " & - "completed by a type that implements an " & - "interface", Priv_T); - end if; + if Is_Tagged_Type (Priv_T) + and then Etype (Priv_T) /= Etype (Full_T) + and then Etype (Priv_T) /= Iface + then + Error_Msg_N ("(Ada 2005) tagged partial view cannot be " & + "completed by a type that implements an " & + "interface", Priv_T); + end if; - -- The full view derives from a limited, protected, - -- synchronized or task interface descendant, but the - -- partial view is not labeled as limited. + -- The full view derives from a limited, protected, + -- synchronized or task interface descendant, but the + -- partial view is not labeled as limited. - if Present (Iface) - and then (Limited_Present (Iface_Def) - or Protected_Present (Iface_Def) - or Synchronized_Present (Iface_Def) - or Task_Present (Iface_Def)) - and then not Limited_Present (Parent (Priv_T)) - then - Error_Msg_N ("(Ada 2005) non-limited private type cannot be " & - "completed by a limited type", Priv_T); + if (Limited_Present (Iface_Def) + or else Protected_Present (Iface_Def) + or else Synchronized_Present (Iface_Def) + or else Task_Present (Iface_Def)) + and then not Limited_Present (Parent (Priv_T)) + then + Error_Msg_N ("(Ada 2005) non-limited private type cannot be " + & "completed by a limited type", Priv_T); + end if; end if; end; end if; @@ -13242,24 +13329,9 @@ package body Sem_Ch3 is return; elsif not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent) then - - -- Ada 2005 (AI-251): No error needed if the immediate - -- ancestor of the partial view is an interface - -- - -- Example: - -- - -- type PT1 is new I1 with private; - -- private - -- type PT1 is new T and I1 with null record; - - if Is_Interface (Base_Type (Priv_Parent)) then - null; - - else - Error_Msg_N - ("parent of full type must descend from parent" - & " of private extension", Full_Indic); - end if; + Error_Msg_N + ("parent of full type must descend from parent" + & " of private extension", Full_Indic); -- Check the rules of 7.3(10): if the private extension inherits -- known discriminants, then the full type must also inherit those @@ -14409,17 +14481,7 @@ package body Sem_Ch3 is else Is_Tagged := True; - Set_Is_Tagged_Type (T); - - Set_Is_Limited_Record (T, Limited_Present (Def) - or else Task_Present (Def) - or else Protected_Present (Def)); - - -- Type is abstract if full declaration carries keyword, or if - -- previous partial view did. - - Set_Is_Abstract (T); - Set_Is_Interface (T); + Analyze_Interface_Declaration (T, Def); end if; -- First pass: if there are self-referential access components, @@ -14428,10 +14490,6 @@ package body Sem_Ch3 is Check_Anonymous_Access_Types (Component_List (Def)); - -- Ada 2005 (AI-251): Complete the initialization of attributes - -- associated with abstract interfaces and decorate the names in the - -- list of ancestor interfaces (if any). - if Ada_Version >= Ada_05 and then Present (Interface_List (Def)) then @@ -14439,6 +14497,7 @@ package body Sem_Ch3 is Iface : Node_Id; Iface_Def : Node_Id; Iface_Typ : Entity_Id; + begin Iface := First (Interface_List (Def)); while Present (Iface) loop @@ -14521,9 +14580,8 @@ package body Sem_Ch3 is Next (Iface); end loop; - Set_Abstract_Interfaces (T, New_Elmt_List); - Collect_Interfaces (Type_Definition (N), T); + Collect_Interfaces (Def, T); end; end if; diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads index 608666d..95354d6 100644 --- a/gcc/ada/sem_ch3.ads +++ b/gcc/ada/sem_ch3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, 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- -- @@ -62,6 +62,9 @@ package Sem_Ch3 is -- Called to analyze a list of declarations (in what context ???). Also -- performs necessary freezing actions (more description needed ???) + procedure Analyze_Interface_Declaration (T : Entity_Id; Def : Node_Id); + -- Analyze an interface declaration or a formal interface declaration + procedure Analyze_Per_Use_Expression (N : Node_Id; T : Entity_Id); -- Default and per object expressions do not freeze their components, -- and must be analyzed and resolved accordingly. The analysis is @@ -97,6 +100,15 @@ package Sem_Ch3 is -- rather than on the declarations that require completion in the package -- declaration. + procedure Collect_Interfaces + (N : Node_Id; + Derived_Type : Entity_Id); + -- Ada 2005 (AI-251): Subsidiary procedure to Build_Derived_Record_Type + -- and Analyze_Formal_Interface_Type. + -- Collect the list of interfaces that are not already implemented by the + -- ancestors. This is the list of interfaces for which we must provide + -- additional tag components. + procedure Derive_Subprogram (New_Subp : in out Entity_Id; Parent_Subp : Entity_Id; @@ -114,8 +126,7 @@ package Sem_Ch3 is (Parent_Type : Entity_Id; Derived_Type : Entity_Id; Generic_Actual : Entity_Id := Empty; - No_Predefined_Prims : Boolean := False; - Predefined_Prims_Only : Boolean := False); + No_Predefined_Prims : Boolean := False); -- To complete type derivation, collect/retrieve the primitive operations -- of the parent type, and replace the subsidiary subtypes with the derived -- type, to build the specs of the inherited ops. For generic actuals, the @@ -124,9 +135,7 @@ package Sem_Ch3 is -- the derived subprograms are aliased to those of the actual, not those of -- the ancestor. The last two params are used in case of derivation from -- abstract interface types: No_Predefined_Prims is used to avoid the - -- derivation of predefined primitives from the interface, and Predefined - -- Prims_Only is used to complete the derivation predefined primitives - -- in case of private tagged types implementing interfaces. + -- derivation of predefined primitives from an abstract interface. -- -- Note: one might expect this to be private to the package body, but -- there is one rather unusual usage in package Exp_Dist. |