Patchwork [Ada] Wrong management of null interface primitives in private type

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 5, 2010, 10:26 a.m.
Message ID <20101005102620.GA8121@adacore.com>
Download mbox | patch
Permalink /patch/66814/
State New
Headers show

Comments

Arnaud Charlet - Oct. 5, 2010, 10:26 a.m.
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.

Patch

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