Patchwork [Ada] Inheriting non-conformant homographs

login
register
mail settings
Submitter Arnaud Charlet
Date Aug. 29, 2011, 12:53 p.m.
Message ID <20110829125358.GA28418@adacore.com>
Download mbox | patch
Permalink /patch/112040/
State New
Headers show

Comments

Arnaud Charlet - Aug. 29, 2011, 12:53 p.m.
In Ada 2012 it is possible to inherit non-conformant homographs, but they
can't be called or overridden. The following test now compiles silently.

package Pack1 is
    type Int1 is interface;
    procedure Op (X : in Int1) is null;
end Pack1;

package Pack2 is
    type Int2 is interface;
    procedure Op (Y : in out Int2) is null;
end Pack2;

with Pack1;
with Pack2;
package Pack3 is
    type Typ3 is new Pack1.Int1 and Pack2.Int2 with record
        F1 : Integer;
    end record;
end Pack3;

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

2011-08-29  Javier Miranda  <miranda@adacore.com>

	* exp_ch6.ads, exp_ch6.adb (Is_Null_Procedure): Move the spec of this
	function to the package spec.
	* sem_ch6.adb (Find_Corresponding_Spec, New_Overloaded_Entity): For
	internally generated bodies of null procedures locate the internally
	generated spec enforcing mode conformance.
	(Is_Interface_Conformant): Ensure that the controlling formal of the
	primitives match.

Patch

Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb	(revision 178183)
+++ exp_ch6.adb	(working copy)
@@ -223,10 +223,6 @@ 
    --  reference to the object itself, and the call becomes a call to the
    --  corresponding protected subprogram.
 
-   function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
-   --  Predicate to recognize stubbed procedures and null procedures, which
-   --  can be inlined unconditionally in all cases.
-
    procedure Expand_Simple_Function_Return (N : Node_Id);
    --  Expand simple return from function. In the case where we are returning
    --  from a function body this is called by Expand_N_Simple_Return_Statement.
Index: exp_ch6.ads
===================================================================
--- exp_ch6.ads	(revision 178183)
+++ exp_ch6.ads	(working copy)
@@ -119,6 +119,10 @@ 
    --  that requires handling as a build-in-place call or is a qualified
    --  expression applied to such a call; otherwise returns False.
 
+   function Is_Null_Procedure (Subp : Entity_Id) return Boolean;
+   --  Predicate to recognize stubbed procedures and null procedures, which
+   --  can be inlined unconditionally in all cases.
+
    procedure Make_Build_In_Place_Call_In_Allocator
      (Allocator     : Node_Id;
       Function_Call : Node_Id);
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 178211)
+++ sem_ch6.adb	(working copy)
@@ -6362,7 +6362,19 @@ 
                   end if;
                end if;
 
-               if not Has_Completion (E) then
+               --  Ada 2012 (AI05-0165): For internally generated bodies of
+               --  null procedures locate the internally generated spec. We
+               --  enforce mode conformance since a tagged type may inherit
+               --  from interfaces several null primitives which differ only
+               --  in the mode of the formals.
+
+               if not (Comes_From_Source (E))
+                 and then Is_Null_Procedure (E)
+                 and then not Mode_Conformant (Designator, E)
+               then
+                  null;
+
+               elsif not Has_Completion (E) then
                   if Nkind (N) /= N_Subprogram_Body_Stub then
                      Set_Corresponding_Spec (N, E);
                   end if;
@@ -7037,6 +7049,30 @@ 
       Iface : constant Entity_Id := Find_Dispatching_Type (Iface_Prim);
       Typ   : constant Entity_Id := Find_Dispatching_Type (Prim);
 
+      function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
+      --  Return the controlling formal of Prim
+
+      function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
+         E : Entity_Id := First_Entity (Prim);
+      begin
+         while Present (E) loop
+            if Is_Formal (E) and then Is_Controlling_Formal (E) then
+               return E;
+            end if;
+
+            Next_Entity (E);
+         end loop;
+
+         return Empty;
+      end Controlling_Formal;
+
+      --  Local variables
+
+      Iface_Ctrl_F : constant Entity_Id := Controlling_Formal (Iface_Prim);
+      Prim_Ctrl_F  : constant Entity_Id := Controlling_Formal (Prim);
+
+   --  Start of processing for Is_Interface_Conformant
+
    begin
       pragma Assert (Is_Subprogram (Iface_Prim)
         and then Is_Subprogram (Prim)
@@ -7060,9 +7096,18 @@ 
       then
          return False;
 
-      --  Case of a procedure, or a function that does not have a controlling
-      --  result (I or access I).
+      --  The mode of the controlling formals must match
 
+      elsif Present (Iface_Ctrl_F)
+         and then Present (Prim_Ctrl_F)
+         and then Ekind (Iface_Ctrl_F) /= Ekind (Prim_Ctrl_F)
+      then
+         return False;
+
+      --  Case of a procedure, or a function whose result type matches the
+      --  result type of the interface primitive, or a function that has no
+      --  controlling result (I or access I).
+
       elsif Ekind (Iface_Prim) = E_Procedure
         or else Etype (Prim) = Etype (Iface_Prim)
         or else not Has_Controlling_Result (Prim)
@@ -8254,6 +8299,18 @@ 
             if Scope (E) /= Current_Scope then
                null;
 
+            --  Ada 2012 (AI05-0165): For internally generated bodies of
+            --  null procedures locate the internally generated spec. We
+            --  enforce mode conformance since a tagged type may inherit
+            --  from interfaces several null primitives which differ only
+            --  in the mode of the formals.
+
+            elsif not Comes_From_Source (S)
+              and then Is_Null_Procedure (S)
+              and then not Mode_Conformant (E, S)
+            then
+               null;
+
             --  Check if we have type conformance
 
             elsif Type_Conformant (E, S) then