From patchwork Tue Oct 5 10:26:20 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Subject: [Ada] Wrong management of null interface primitives in private type From: Arnaud Charlet X-Patchwork-Id: 66814 Message-Id: <20101005102620.GA8121@adacore.com> To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Date: Tue, 5 Oct 2010 12:26:20 +0200 The frontend does not handle well private types that cover null interface primitives. After this patch the following packages compiles silently. package Ifaces is type SAX_Content_Handler is tagged limited null record; type SAX_Decl_Handler is limited interface; procedure Attribute_Decl (Self : SAX_Decl_Handler) is null; end; with Ifaces; use Ifaces; package Demo_Handlers is type Demo_Handler is limited new SAX_Content_Handler and SAX_Decl_Handler with private; private type Demo_Handler is limited new SAX_Content_Handler and SAX_Decl_Handler with null record; end; Command: gcc -c -gnat05 demo_handler.ads Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-05 Javier Miranda * sem_ch3.adb (Add_Internal_Interface_Entities): Removing code that is no longer required after change in New_Overloaded_Entity. * sem_ch6.adb (New_Overloaded_Entity): Code reorganization to isolate the fragment of code that handles derivations of interface primitives. Add missing dependence on global variable Inside_Freezing_Actions to ensure the correct management of internal interface entities. * sem_ch13.adb (Analyze_Freeze_Entity): Add missing increase/decrease of the global variable Inside_Freezing_Actions to ensure that internal interface entities are well handled by New_Overloaded_Entity. * sem_disp.adb (Find_Primitive_Covering_Interface): Add documentation and complete the algorithm to catch hidden primitives derived of private type that covers the interface. * sem_disp.ads (Find_Primitive_Covering_Interface): Add missing documentation. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 164976) +++ sem_ch3.adb (working copy) @@ -1550,22 +1550,7 @@ package body Sem_Ch3 is (Tagged_Type => Tagged_Type, Iface_Prim => Iface_Prim); - -- Handle cases where the type has no primitive covering this - -- interface primitive. - - if No (Prim) then - - -- Skip non-overridden null interface primitives because - -- their wrappers will be generated later. - - if Is_Null_Interface_Primitive (Iface_Prim) then - goto Continue; - - else - pragma Assert (False); - raise Program_Error; - end if; - end if; + pragma Assert (Present (Prim)); Derive_Subprogram (New_Subp => New_Subp, @@ -1605,7 +1590,6 @@ package body Sem_Ch3 is Set_Has_Delayed_Freeze (New_Subp); end if; - <> Next_Elmt (Elmt); end loop; Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 164972) +++ sem_ch6.adb (working copy) @@ -7542,6 +7542,53 @@ package body Sem_Ch6 is E := Current_Entity_In_Scope (S); + -- Ada 2005 (AI-251): Derivation of abstract interface primitives. + -- They are directly added to the list of primitive operations of + -- Derived_Type, unless this is a rederivation in the private part + -- of an operation that was already derived in the visible part of + -- the current package. + + if Ada_Version >= Ada_05 + and then Present (Derived_Type) + and then Present (Alias (S)) + and then Is_Dispatching_Operation (Alias (S)) + and then Present (Find_Dispatching_Type (Alias (S))) + and then Is_Interface (Find_Dispatching_Type (Alias (S))) + then + -- For private types, when the full-view is processed we propagate to + -- the full view the non-overridden entities whose attribute "alias" + -- references an interface primitive. These entities were added by + -- Derive_Subprograms to ensure that interface primitives are + -- covered. + + -- Inside_Freeze_Actions is non zero when S corresponds with an + -- internal entity that links an interface primitive with its + -- covering primitive through attribute Interface_Alias (see + -- Add_Internal_Interface_Entities) + + if Inside_Freezing_Actions = 0 + and then Is_Package_Or_Generic_Package (Current_Scope) + and then In_Private_Part (Current_Scope) + and then Nkind (Parent (E)) = N_Private_Extension_Declaration + and then Nkind (Parent (S)) = N_Full_Type_Declaration + and then Full_View (Defining_Identifier (Parent (E))) + = Defining_Identifier (Parent (S)) + and then Alias (E) = Alias (S) + then + Check_Operation_From_Private_View (S, E); + Set_Is_Dispatching_Operation (S); + + -- Common case + + else + Enter_Overloaded_Entity (S); + Check_Dispatching_Operation (S, Empty); + Check_For_Primitive_Subprogram (Is_Primitive_Subp); + end if; + + return; + end if; + -- If there is no homonym then this is definitely not overriding if No (E) then @@ -7617,31 +7664,6 @@ package body Sem_Ch6 is -- E exists and is overloadable else - -- Ada 2005 (AI-251): Derivation of abstract interface primitives. - -- They are directly added to the list of primitive operations of - -- Derived_Type, unless this is a rederivation in the private part - -- of an operation that was already derived in the visible part of - -- the current package. - - if Ada_Version >= Ada_05 - and then Present (Derived_Type) - and then Present (Alias (S)) - and then Is_Dispatching_Operation (Alias (S)) - and then Present (Find_Dispatching_Type (Alias (S))) - and then Is_Interface (Find_Dispatching_Type (Alias (S))) - then - if Type_Conformant (E, S) - and then Is_Package_Or_Generic_Package (Current_Scope) - and then In_Private_Part (Current_Scope) - and then Parent (E) /= Parent (S) - and then Alias (E) = Alias (S) - then - Check_Operation_From_Private_View (S, E); - else - goto Add_New_Entity; - end if; - end if; - Check_Synchronized_Overriding (S, Overridden_Subp); -- Loop through E and its homonyms to determine if any of them is @@ -7999,8 +8021,6 @@ package body Sem_Ch6 is E := Homonym (E); end loop; - <> - -- On exit, we know that S is a new entity Enter_Overloaded_Entity (S); Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 164940) +++ sem_ch13.adb (working copy) @@ -2396,9 +2396,14 @@ package body Sem_Ch13 is E : constant Entity_Id := Entity (N); begin + -- Remember that we are processing a freezing entity. Required to + -- ensure correct decoration of internal entities associated with + -- interfaces (see New_Overloaded_Entity). + + Inside_Freezing_Actions := Inside_Freezing_Actions + 1; + -- For tagged types covering interfaces add internal entities that link -- the primitives of the interfaces with the primitives that cover them. - -- Note: These entities were originally generated only when generating -- code because their main purpose was to provide support to initialize -- the secondary dispatch tables. They are now generated also when @@ -2485,6 +2490,8 @@ package body Sem_Ch13 is end loop; end; end if; + + Inside_Freezing_Actions := Inside_Freezing_Actions - 1; end Analyze_Freeze_Entity; ------------------------------------------ Index: sem_disp.adb =================================================================== --- sem_disp.adb (revision 164972) +++ sem_disp.adb (working copy) @@ -1661,7 +1661,9 @@ package body Sem_Disp is Is_Interface (Find_Dispatching_Type (Ultimate_Alias (Iface_Prim))))); - -- Search in the homonym chain + -- Search in the homonym chain. Done to speed up locating visible + -- entities and required to catch primitives associated with the partial + -- view of private types when processing the corresponding full view. E := Current_Entity (Iface_Prim); while Present (E) loop @@ -1675,16 +1677,39 @@ package body Sem_Disp is E := Homonym (E); end loop; - -- Search in the list of primitives of the type + -- Search in the list of primitives of the type. Required to locate the + -- covering primitive if the covering primitive is not visible (for + -- example, non-visible inherited primitive of private type). El := First_Elmt (Primitive_Operations (Tagged_Type)); while Present (El) loop E := Node (El); - if No (Interface_Alias (E)) - and then Alias (E) = Iface_Prim - then - return Node (El); + -- Keep separate the management of internal entities that link + -- primitives with interface primitives from tagged type primitives. + + if No (Interface_Alias (E)) then + if Present (Alias (E)) then + + -- This interface primitive has not been covered yet + + if Alias (E) = Iface_Prim then + return E; + + -- The covering primitive was inherited + + elsif Overridden_Operation (Ultimate_Alias (E)) + = Iface_Prim + then + return E; + end if; + end if; + + -- Use the internal entity that links the interface primitive with + -- the covering primitive to locate the entity + + elsif Interface_Alias (E) = Iface_Prim then + return Alias (E); end if; Next_Elmt (El); Index: sem_disp.ads =================================================================== --- sem_disp.ads (revision 164972) +++ sem_disp.ads (working copy) @@ -87,7 +87,11 @@ package Sem_Disp is -- associated with the partial view of private types when processing the -- corresponding full view. If the entity is not found then search for it -- in the list of primitives of Tagged_Type. This latter search is needed - -- when the interface primitive is covered by a private subprogram. + -- when the interface primitive is covered by a private subprogram. If the + -- primitive has not been covered yet then return the entity that will be + -- overriden when the primitive is covered (that is, return the entity + -- whose alias attribute references the interface primitive). If none of + -- these entities is found then return Empty. function Is_Dynamically_Tagged (N : Node_Id) return Boolean; -- Used to determine whether a call is dispatching, i.e. if is an