Comments
Patch
===================================================================
@@ -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;
- <<Continue>>
Next_Elmt (Elmt);
end loop;
===================================================================
@@ -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;
- <<Add_New_Entity>>
-
-- On exit, we know that S is a new entity
Enter_Overloaded_Entity (S);
===================================================================
@@ -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;
------------------------------------------
===================================================================
@@ -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);
===================================================================
@@ -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
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 <miranda@adacore.com> * 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.