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 <mira...@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.
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
