Patchwork [Ada] Wrong derivation of interfaces in generic formals

login
register
mail settings
Submitter Arnaud Charlet
Date June 23, 2010, 6:26 a.m.
Message ID <20100623062635.GA28490@adacore.com>
Download mbox | patch
Permalink /patch/56592/
State New
Headers show

Comments

Arnaud Charlet - June 23, 2010, 6:26 a.m.
This patch improves the derivation of generic formals that are types
that cover interfaces. Previous support required only name consistency;
the new implementation is more complete because types of arguments
are also checked. The following test now compiles silently.

generic
package Gen is
   type Root is abstract tagged null record;
   type Rec  is record null; end record;

   type Iface is interface;
   procedure Prim1 (Obj : Iface; R : Rec) is abstract;
   procedure Prim2 (Obj : Iface; R : Rec) is abstract;

   type Iface2 is interface;
   procedure Prim1 (Obj : Iface2; R : Rec; V : Natural) is abstract;

   type Iface3 is interface and Iface;

   type DT2 is new Root and Iface2 and Iface3 with null record;
   procedure Prim1 (Obj : DT2; R : Rec; V : Natural);
   procedure Prim2 (Obj : DT2; R : Rec);
   procedure Prim1 (Obj : DT2; R : Rec);
end;

with Gen;
generic
   with package Formal_Pkg is new Gen;
   type Formal_Type is new Formal_Pkg.Root and Formal_Pkg.Iface with private;
package Test_Matching_Formals is
   procedure Do_Test;
end;

package body Test_Matching_Formals is
   procedure Do_Test is
      Obj1 : Formal_Pkg.DT2;
      Obj2 : Formal_Type;
      Rec  : Formal_Pkg.Rec;
   begin
      Formal_Pkg.Iface'Class (Obj1).Prim1 (Rec);
      Formal_Pkg.Iface'Class (Obj2).Prim1 (Rec);
   end;
end;

with Gen;
with Test_Matching_Formals;
package Main_Pkg is
   package Root_Inst is new Gen;
   package Test_Pkg  is new Test_Matching_Formals (
     Formal_Pkg   => Root_Inst,
     Formal_Type  => Root_Inst.DT2);
   procedure Do_Test;
end;

package body Main_Pkg is
   procedure Do_Test is
      Obj : Root_Inst.DT2;
      Rec : Root_Inst.Rec;
   begin
      Root_Inst.Iface'Class (Obj).Prim1 (Rec);
   end;
end;

package body Gen is
   procedure Prim1 (Obj : DT2; R : Rec; V : Natural) is
   begin
     raise Program_Error;
   end;
   procedure Prim2 (Obj : DT2; R : Rec) is begin null; end;
   procedure Prim1 (Obj : DT2; R : Rec) is begin null; end;
end;

with Main_Pkg; use Main_Pkg;
procedure Test_Iface_Formals is
begin
   Do_Test;
   Test_Pkg.Do_Test;
end Main;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-23  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Add_Internal_Interface_Entities): Generate internal
	entities for parent types that are interfaces. Needed in generics to
	handle formals that implement interfaces.
	(Derive_Subprograms): Add assertion for derivation of tagged types that
	do not cover interfaces. For generics, complete code that handles
	derivation of type that covers interfaces because the previous
	condition was weak (it required only name consistency; arguments were
	not checked). Add new code to locate primitives covering interfaces
	defined in generic units or instantiatons.
	* sem_util.adb (Has_Interfaces): Add missing support for derived types.
	* sem_ch6.adb (Check_Overriding_Indicator): Minor code cleanups.
	* exp_disp.adb (Make_Select_Specific_Data_Table): Skip primitives of
	interfaces that are parents of the type because they share the primary
	dispatch table.
	(Register_Primitive): Do not register primitives of interfaces that
	are parents of the type.
	* sem_ch13.adb (Analyze_Freeze_Entity): Add documentation.
	* exp_cg.adb (Write_Type_Info): When displaying overriding of interface
	primitives skip primitives of interfaces that are parents of the type.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 161198)
+++ sem_ch3.adb	(working copy)
@@ -68,6 +68,7 @@  with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
 with Stand;    use Stand;
 with Sinfo;    use Sinfo;
+with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Targparm; use Targparm;
 with Tbuild;   use Tbuild;
@@ -1537,90 +1538,92 @@  package body Sem_Ch3 is
       while Present (Iface_Elmt) loop
          Iface := Node (Iface_Elmt);
 
-         --  Exclude from this processing interfaces that are parents of
-         --  Tagged_Type because their primitives are located in the primary
-         --  dispatch table (and hence no auxiliary internal entities are
-         --  required to handle secondary dispatch tables in such case).
+         --  Originally we excluded here from this processing interfaces that
+         --  are parents of Tagged_Type because their primitives are located
+         --  in the primary dispatch table (and hence no auxiliary internal
+         --  entities are required to handle secondary dispatch tables in such
+         --  case). However, these auxiliary entities are also required to
+         --  handle derivations of interfaces in formals of generics (see
+         --  Derive_Subprograms).
 
-         if not Is_Ancestor (Iface, Tagged_Type) then
-            Elmt := First_Elmt (Primitive_Operations (Iface));
-            while Present (Elmt) loop
-               Iface_Prim := Node (Elmt);
-
-               if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
-                  Prim :=
-                    Find_Primitive_Covering_Interface
-                      (Tagged_Type => Tagged_Type,
-                       Iface_Prim  => Iface_Prim);
+         Elmt := First_Elmt (Primitive_Operations (Iface));
+         while Present (Elmt) loop
+            Iface_Prim := Node (Elmt);
 
-                  if No (Prim) then
+            if not Is_Predefined_Dispatching_Operation (Iface_Prim) then
+               Prim :=
+                 Find_Primitive_Covering_Interface
+                   (Tagged_Type => Tagged_Type,
+                    Iface_Prim  => Iface_Prim);
+
+               if No (Prim) then
+
+                  --  In some rare cases, a name conflict may have kept the
+                  --  operation completely hidden. Look for it in the list
+                  --  of primitive operations of the type.
 
-                     --  In some rare cases, a name conflict may have kept the
-                     --  operation completely hidden. Look for it in the list
-                     --  of primitive operations of the type.
+                  declare
+                     El : Elmt_Id;
 
-                     declare
-                        El : Elmt_Id;
-                     begin
-                        El := First_Elmt (Primitive_Operations (Tagged_Type));
-                        while Present (El) loop
-                           Prim := Node (El);
-                           exit when Is_Subprogram (Prim)
-                             and then Alias (Prim) = Iface_Prim;
-                           Next_Elmt (El);
-                        end loop;
+                  begin
+                     El := First_Elmt (Primitive_Operations (Tagged_Type));
+                     while Present (El) loop
+                        Prim := Node (El);
+                        exit when Is_Subprogram (Prim)
+                          and then Alias (Prim) = Iface_Prim;
+                        Next_Elmt (El);
+                     end loop;
 
-                        --  If the operation was not explicitly overridden, it
-                        --  should have been inherited as an abstract operation
-                        --  so Prim can not be Empty at this stage.
+                     --  If the operation was not explicitly overridden, it
+                     --  should have been inherited as an abstract operation
+                     --  so Prim can not be Empty at this stage.
 
-                        if No (El) then
-                           raise Program_Error;
-                        end if;
-                     end;
-                  end if;
+                     if No (El) then
+                        raise Program_Error;
+                     end if;
+                  end;
+               end if;
 
-                  Derive_Subprogram
-                    (New_Subp     => New_Subp,
-                     Parent_Subp  => Iface_Prim,
-                     Derived_Type => Tagged_Type,
-                     Parent_Type  => Iface);
-
-                  --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
-                  --  associated with interface types. These entities are
-                  --  only registered in the list of primitives of its
-                  --  corresponding tagged type because they are only used
-                  --  to fill the contents of the secondary dispatch tables.
-                  --  Therefore they are removed from the homonym chains.
-
-                  Set_Is_Hidden (New_Subp);
-                  Set_Is_Internal (New_Subp);
-                  Set_Alias (New_Subp, Prim);
-                  Set_Is_Abstract_Subprogram (New_Subp,
-                    Is_Abstract_Subprogram (Prim));
-                  Set_Interface_Alias (New_Subp, Iface_Prim);
-
-                  --  Internal entities associated with interface types are
-                  --  only registered in the list of primitives of the tagged
-                  --  type. They are only used to fill the contents of the
-                  --  secondary dispatch tables. Therefore they are not needed
-                  --  in the homonym chains.
-
-                  Remove_Homonym (New_Subp);
-
-                  --  Hidden entities associated with interfaces must have set
-                  --  the Has_Delay_Freeze attribute to ensure that, in case of
-                  --  locally defined tagged types (or compiling with static
-                  --  dispatch tables generation disabled) the corresponding
-                  --  entry of the secondary dispatch table is filled when
-                  --  such an entity is frozen.
+               Derive_Subprogram
+                 (New_Subp     => New_Subp,
+                  Parent_Subp  => Iface_Prim,
+                  Derived_Type => Tagged_Type,
+                  Parent_Type  => Iface);
+
+               --  Ada 2005 (AI-251): Decorate internal entity Iface_Subp
+               --  associated with interface types. These entities are
+               --  only registered in the list of primitives of its
+               --  corresponding tagged type because they are only used
+               --  to fill the contents of the secondary dispatch tables.
+               --  Therefore they are removed from the homonym chains.
+
+               Set_Is_Hidden (New_Subp);
+               Set_Is_Internal (New_Subp);
+               Set_Alias (New_Subp, Prim);
+               Set_Is_Abstract_Subprogram
+                 (New_Subp, Is_Abstract_Subprogram (Prim));
+               Set_Interface_Alias (New_Subp, Iface_Prim);
+
+               --  Internal entities associated with interface types are
+               --  only registered in the list of primitives of the tagged
+               --  type. They are only used to fill the contents of the
+               --  secondary dispatch tables. Therefore they are not needed
+               --  in the homonym chains.
+
+               Remove_Homonym (New_Subp);
+
+               --  Hidden entities associated with interfaces must have set
+               --  the Has_Delay_Freeze attribute to ensure that, in case of
+               --  locally defined tagged types (or compiling with static
+               --  dispatch tables generation disabled) the corresponding
+               --  entry of the secondary dispatch table is filled when
+               --  such an entity is frozen.
 
-                  Set_Has_Delayed_Freeze (New_Subp);
-               end if;
+               Set_Has_Delayed_Freeze (New_Subp);
+            end if;
 
-               Next_Elmt (Elmt);
-            end loop;
-         end if;
+            Next_Elmt (Elmt);
+         end loop;
 
          Next_Elmt (Iface_Elmt);
       end loop;
@@ -11955,7 +11958,7 @@  package body Sem_Ch3 is
       --  non-abstract tagged types that can reference abstract primitives
       --  through its Alias attribute are the internal entities that have
       --  attribute Interface_Alias, and these entities are generated later
-      --  by Freeze_Record_Type).
+      --  by Add_Internal_Interface_Entities).
 
       if In_Private_Part (Current_Scope)
         and then Is_Abstract_Type (Parent_Type)
@@ -12734,6 +12737,12 @@  package body Sem_Ch3 is
             --  corresponding operations of the actual.
 
             else
+               pragma Assert (No (Node (Act_Elmt))
+                 or else (Primitive_Names_Match (Subp, Node (Act_Elmt))
+                            and then
+                          Type_Conformant (Subp, Node (Act_Elmt),
+                                           Skip_Controlling_Formals => True)));
+
                Derive_Subprogram
                  (New_Subp, Subp, Derived_Type, Parent_Base, Node (Act_Elmt));
 
@@ -12839,7 +12848,11 @@  package body Sem_Ch3 is
               or else
                 (Present (Generic_Actual)
                   and then Present (Act_Subp)
-                  and then not Primitive_Names_Match (Subp, Act_Subp))
+                  and then not
+                    (Primitive_Names_Match (Subp, Act_Subp)
+                       and then
+                     Type_Conformant (Subp, Act_Subp,
+                                      Skip_Controlling_Formals => True)))
             then
                pragma Assert (not Is_Ancestor (Parent_Base, Generic_Actual));
 
@@ -12849,14 +12862,73 @@  package body Sem_Ch3 is
 
                --  Handle entities associated with interface primitives
 
-               if Present (Alias (Subp))
-                 and then Is_Interface (Find_Dispatching_Type (Alias (Subp)))
+               if Present (Alias_Subp)
+                 and then Is_Interface (Find_Dispatching_Type (Alias_Subp))
                  and then not Is_Predefined_Dispatching_Operation (Subp)
                then
+                  --  Search for the primitive in the homonym chain
+
                   Act_Subp :=
                     Find_Primitive_Covering_Interface
                       (Tagged_Type => Generic_Actual,
-                       Iface_Prim  => Subp);
+                       Iface_Prim  => Alias_Subp);
+
+                  --  Previous search may not locate primitives covering
+                  --  interfaces defined in generics units or instantiations.
+                  --  (it fails if the covering primitive has formals whose
+                  --  type is also defined in generics or instantiations).
+                  --  In such case we search in the list of primitives of the
+                  --  generic actual for the internal entity that links the
+                  --  interface primitive and the covering primitive.
+
+                  if No (Act_Subp)
+                    and then Is_Generic_Type (Parent_Type)
+                  then
+                     --  This code has been designed to handle only generic
+                     --  formals that implement interfaces that are defined
+                     --  in a generic unit or instantiation. If this code is
+                     --  needed for other cases we must review it because
+                     --  (given that it relies on Original_Location to locate
+                     --  the primitive of Generic_Actual that covers the
+                     --  interface) it could leave linked through attribute
+                     --  Alias entities of unrelated instantiations).
+
+                     pragma Assert
+                       (Is_Generic_Unit
+                          (Scope (Find_Dispatching_Type (Alias_Subp)))
+                       or else
+                        Instantiation_Depth
+                          (Sloc (Find_Dispatching_Type (Alias_Subp))) > 0);
+
+                     declare
+                        Iface_Prim_Loc : constant Source_Ptr :=
+                                         Original_Location (Sloc (Alias_Subp));
+                        Elmt      : Elmt_Id;
+                        Prim      : Entity_Id;
+                     begin
+                        Elmt :=
+                          First_Elmt (Primitive_Operations (Generic_Actual));
+
+                        Search : while Present (Elmt) loop
+                           Prim := Node (Elmt);
+
+                           if Present (Interface_Alias (Prim))
+                             and then Original_Location
+                                        (Sloc (Interface_Alias (Prim)))
+                                       = Iface_Prim_Loc
+                           then
+                              Act_Subp := Alias (Prim);
+                              exit Search;
+                           end if;
+
+                           Next_Elmt (Elmt);
+                        end loop Search;
+                     end;
+                  end if;
+
+                  pragma Assert (Present (Act_Subp)
+                    or else Is_Abstract_Type (Generic_Actual)
+                    or else Serious_Errors_Detected > 0);
 
                --  Handle predefined primitives plus the rest of user-defined
                --  primitives
@@ -12874,6 +12946,10 @@  package body Sem_Ch3 is
 
                      Next_Elmt (Act_Elmt);
                   end loop;
+
+                  if No (Act_Elmt) then
+                     Act_Subp := Empty;
+                  end if;
                end if;
             end if;
 
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 161244)
+++ sem_util.adb	(working copy)
@@ -4497,15 +4497,13 @@  package body Sem_Util is
      (T             : Entity_Id;
       Use_Full_View : Boolean := True) return Boolean
    is
-      Typ : Entity_Id;
+      Typ : Entity_Id := Base_Type (T);
 
    begin
       --  Handle concurrent types
 
-      if Is_Concurrent_Type (T) then
-         Typ := Corresponding_Record_Type (T);
-      else
-         Typ := T;
+      if Is_Concurrent_Type (Typ) then
+         Typ := Corresponding_Record_Type (Typ);
       end if;
 
       if not Present (Typ)
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 161244)
+++ sem_ch6.adb	(working copy)
@@ -4568,7 +4568,7 @@  package body Sem_Ch6 is
 
             elsif Must_Override (Spec) then
                if Is_Overriding_Operation (Subp) then
-                  Set_Is_Overriding_Operation (Subp);
+                  null;
 
                elsif not Can_Override then
                   Error_Msg_NE ("subprogram & is not overriding", Spec, Subp);
@@ -6477,8 +6477,8 @@  package body Sem_Ch6 is
         or else Etype (Prim) = Etype (Iface_Prim)
         or else not Has_Controlling_Result (Prim)
       then
-         return Type_Conformant (Prim, Iface_Prim,
-                  Skip_Controlling_Formals => True);
+         return Type_Conformant
+                  (Iface_Prim, Prim, Skip_Controlling_Formals => True);
 
       --  Case of a function returning an interface, or an access to one.
       --  Check that the return types correspond.
Index: exp_disp.adb
===================================================================
--- exp_disp.adb	(revision 161244)
+++ exp_disp.adb	(working copy)
@@ -6014,6 +6014,9 @@  package body Exp_Disp is
             --  Look for primitive overriding an abstract interface subprogram
 
             if Present (Interface_Alias (Prim))
+              and then not
+                Is_Ancestor
+                  (Find_Dispatching_Type (Interface_Alias (Prim)), Typ)
               and then not Examined (UI_To_Int (DT_Position (Alias (Prim))))
             then
                Prim_Pos := DT_Position (Alias (Prim));
@@ -6721,6 +6724,13 @@  package body Exp_Disp is
 
          pragma Assert (Is_Interface (Iface_Typ));
 
+         --  No action needed for interfaces that are ancestors of Typ because
+         --  their primitives are located in the primary dispatch table.
+
+         if Is_Ancestor (Iface_Typ, Tag_Typ) then
+            return L;
+         end if;
+
          Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
          if not Is_Ancestor (Iface_Typ, Tag_Typ)
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 161073)
+++ sem_ch13.adb	(working copy)
@@ -2366,7 +2366,9 @@  package body Sem_Ch13 is
       --  code because their main purpose was to provide support to initialize
       --  the secondary dispatch tables. They are now generated also when
       --  compiling with no code generation to provide ASIS the relationship
-      --  between interface primitives and tagged type primitives.
+      --  between interface primitives and tagged type primitives. They are
+      --  also used to locate primitives covering interfaces when processing
+      --  generics (see Derive_Subprograms).
 
       if Ada_Version >= Ada_05
         and then Ekind (E) = E_Record_Type
@@ -2374,6 +2376,12 @@  package body Sem_Ch13 is
         and then not Is_Interface (E)
         and then Has_Interfaces (E)
       then
+         --  This would be a good common place to call the routine that checks
+         --  overriding of interface primitives (and thus factorize calls to
+         --  Check_Abstract_Overriding located at different contexts in the
+         --  compiler). However, this is not possible because it causes
+         --  spurious errors in case of late overriding.
+
          Add_Internal_Interface_Entities (E);
       end if;
    end Analyze_Freeze_Entity;
Index: exp_cg.adb
===================================================================
--- exp_cg.adb	(revision 161205)
+++ exp_cg.adb	(working copy)
@@ -572,7 +572,11 @@  package body Exp_CG is
                   Prim_Op := Node (Prim_Elmt);
                   Int_Alias := Interface_Alias (Prim_Op);
 
-                  if Present (Int_Alias) and then (Alias (Prim_Op)) = Prim then
+                  if Present (Int_Alias)
+                    and then not Is_Ancestor
+                                   (Find_Dispatching_Type (Int_Alias), Typ)
+                    and then (Alias (Prim_Op)) = Prim
+                  then
                      Write_Char (',');
                      Write_Int (UI_To_Int (Slot_Number (Int_Alias)));
                      Write_Char (':');