[Ada] Wrong management of null interface primitives in private type
Arnaud Charlet
charlet@adacore.com
Tue Oct 5 10:26:00 GMT 2010
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.
-------------- next part --------------
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;
- <<Continue>>
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;
- <<Add_New_Entity>>
-
-- 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
More information about the Gcc-patches
mailing list