[Ada] Type_Invariant'Class on interface types
Arnaud Charlet
charlet@adacore.com
Mon Mar 2 11:11:00 GMT 2015
This new language feature allows Type_Invariant'class on interface
types. When a type implements one or several interfaces, its inherited
type invariant is the conjunction of all ancestor Type_Invariant'Class.
The following package now compiles without errors:
package AI12_0041 is
type VIntf is interface
with Type_Invariant'Class => Is_Foo (VIntf);
function Is_Foo (Obj : VIntf) return Boolean is abstract;
type Test is private;
private
type Test is new VIntf with null record;
function Is_Foo (Obj : Test) return Boolean;
end;
Tested on x86_64-pc-linux-gnu, committed on trunk
2015-03-02 Javier Miranda <miranda@adacore.com>
* exp_ch9.adb (Build_Corresponding_Record): Propagate type
invariants to the corresponding record type.
* exp_disp.ad[sb] (Set_DT_Position_Value): New subprogram
which sets the value of the DTC_Entity associated with a given
primitive of a tagged type and propagates the value to the
wrapped subprogram.
(Set_DTC_Entity_Value): Propagate the DTC
value to the wrapped entity.
* sem_ch13.adb (Build_Invariant_Procedure): Append the code
associated with invariants of progenitors.
* sem_ch3.adb (Build_Derived_Record_Type): Inherit type invariants
of parents and progenitors.
(Process_Full_View): Check hidden inheritance of class-wide type
invariants.
* sem_ch7.adb (Analyze_Package_Specification): Do not generate
the invariant procedure for interface types; build the invariant
procedure for tagged types inheriting invariants from their
progenitors.
* sem_prag.adb (Pragma_Invariant) Allow invariants in interface
types but do not build their invariant procedure since their
invariants will be propagated to the invariant procedure of
types covering the interface.
* exp_ch6.adb, exp_disp.adb, sem_ch3.adb, sem_ch7.adb,
sem_ch8.adb, sem_disp.adb: Replace all calls to Set_DT_Position
by calls to Set_DT_Position_Value.
-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 221103)
+++ sem_ch3.adb (working copy)
@@ -8640,6 +8640,36 @@
end;
end if;
+ -- Propagate inherited invariant information of parents
+ -- and progenitors
+
+ if Ada_Version >= Ada_2012
+ and then not Is_Interface (Derived_Type)
+ then
+ if Has_Inheritable_Invariants (Parent_Type) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ elsif not Is_Empty_Elmt_List (Ifaces_List) then
+ declare
+ AI : Elmt_Id;
+
+ begin
+ AI := First_Elmt (Ifaces_List);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Set_Has_Invariants (Derived_Type);
+ Set_Has_Inheritable_Invariants (Derived_Type);
+
+ exit;
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+ end if;
+
-- A type extension is automatically Ghost when one of its
-- progenitors is Ghost (SPARK RM 6.9(9)). This property is
-- also inherited when the parent type is Ghost, but this is
@@ -14811,7 +14841,7 @@
if Present (DTC_Entity (Actual_Subp)) then
Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp));
- Set_DT_Position (New_Subp, DT_Position (Actual_Subp));
+ Set_DT_Position_Value (New_Subp, DT_Position (Actual_Subp));
end if;
end if;
@@ -19681,7 +19711,7 @@
if not Is_Dispatching_Operation (Prim) then
Append_Elmt (Prim, Full_List);
Set_Is_Dispatching_Operation (Prim, True);
- Set_DT_Position (Prim, No_Uint);
+ Set_DT_Position_Value (Prim, No_Uint);
end if;
elsif Is_Dispatching_Operation (Prim)
@@ -19837,6 +19867,34 @@
Set_Has_Inheritable_Invariants (Full_T);
end if;
+ -- Check hidden inheritance of class-wide type invariants
+
+ if Ada_Version >= Ada_2012
+ and then not Has_Inheritable_Invariants (Full_T)
+ and then In_Private_Part (Current_Scope)
+ and then Has_Interfaces (Full_T)
+ then
+ declare
+ Ifaces : Elist_Id;
+ AI : Elmt_Id;
+
+ begin
+ Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
+
+ AI := First_Elmt (Ifaces);
+ while Present (AI) loop
+ if Has_Inheritable_Invariants (Node (AI)) then
+ Error_Msg_N
+ ("hidden inheritance of class-wide type invariants " &
+ "not allowed", N);
+ exit;
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+
-- Propagate predicates to full type, and predicate function if already
-- defined. It is not clear that this can actually happen? the partial
-- view cannot be frozen yet, and the predicate function has not been
Index: exp_ch9.adb
===================================================================
--- exp_ch9.adb (revision 221101)
+++ exp_ch9.adb (working copy)
@@ -1240,6 +1240,12 @@
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
+ -- Propagate type invariants to the corresponding record type
+
+ Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp));
+ Set_Has_Inheritable_Invariants (Rec_Ent,
+ Has_Inheritable_Invariants (Ctyp));
+
-- Use discriminals to create list of discriminants for record, and
-- create new discriminals for use in default expressions, etc. It is
-- worth noting that a task discriminant gives rise to 5 entities;
Index: sem_ch7.adb
===================================================================
--- sem_ch7.adb (revision 221101)
+++ sem_ch7.adb (working copy)
@@ -1482,7 +1482,7 @@
end if;
-- If invariants are present, build the invariant procedure for a
- -- private type, but not any of its subtypes.
+ -- private type, but not any of its subtypes or interface types.
if Has_Invariants (E) then
if Ekind (E) = E_Private_Subtype then
@@ -1665,23 +1665,42 @@
if Is_Type (E)
and then Has_Private_Declaration (E)
and then Nkind (Parent (E)) = N_Full_Type_Declaration
- and then Has_Aspects (Parent (E))
then
declare
- ASN : Node_Id;
+ IP_Built : Boolean := False;
begin
- ASN := First (Aspect_Specifications (Parent (E)));
- while Present (ASN) loop
- if Nam_In (Chars (Identifier (ASN)), Name_Invariant,
- Name_Type_Invariant)
- then
- Build_Invariant_Procedure (E, N);
- exit;
- end if;
+ if Has_Aspects (Parent (E)) then
+ declare
+ ASN : Node_Id;
- Next (ASN);
- end loop;
+ begin
+ ASN := First (Aspect_Specifications (Parent (E)));
+ while Present (ASN) loop
+ if Nam_In (Chars (Identifier (ASN)),
+ Name_Invariant,
+ Name_Type_Invariant)
+ then
+ Build_Invariant_Procedure (E, N);
+ IP_Built := True;
+ exit;
+ end if;
+
+ Next (ASN);
+ end loop;
+ end;
+ end if;
+
+ -- Invariants may have been inherited from progenitors
+
+ if not IP_Built
+ and then Has_Interfaces (E)
+ and then Has_Inheritable_Invariants (E)
+ and then not Is_Interface (E)
+ and then not Is_Class_Wide_Type (E)
+ then
+ Build_Invariant_Procedure (E, N);
+ end if;
end;
end if;
@@ -1987,7 +2006,7 @@
and then Present (DTC_Entity (Alias (Prim_Op)))
then
Set_DTC_Entity_Value (E, New_Op);
- Set_DT_Position (New_Op,
+ Set_DT_Position_Value (New_Op,
DT_Position (Alias (Prim_Op)));
end if;
Index: sem_prag.adb
===================================================================
--- sem_prag.adb (revision 221112)
+++ sem_prag.adb (working copy)
@@ -15277,6 +15277,11 @@
if Typ = Any_Type then
return;
+ -- Invariants allowed in interface types (RM 7.3.2(3/3))
+
+ elsif Is_Interface (Typ) then
+ null;
+
-- An invariant must apply to a private type, or appear in the
-- private part of a package spec and apply to a completion.
-- a class-wide invariant can only appear on a private declaration
@@ -15318,9 +15323,15 @@
-- procedure declaration, so that calls to it can be generated
-- before the body is built (e.g. within an expression function).
- Insert_After_And_Analyze
- (N, Build_Invariant_Procedure_Declaration (Typ));
+ -- Interface types have no invariant procedure; their invariants
+ -- are propagated to the build invariant procedure of all the
+ -- types covering the interface type.
+ if not Is_Interface (Typ) then
+ Insert_After_And_Analyze
+ (N, Build_Invariant_Procedure_Declaration (Typ));
+ end if;
+
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
end if;
Index: exp_ch6.adb
===================================================================
--- exp_ch6.adb (revision 221109)
+++ exp_ch6.adb (working copy)
@@ -671,7 +671,7 @@
and then Is_Hidden (Par_Op)
and then Type_Conformant (Prim_Op, Subp)
then
- Set_DT_Position (Subp, DT_Position (Prim_Op));
+ Set_DT_Position_Value (Subp, DT_Position (Prim_Op));
end if;
Next_Elmt (Op_Elmt);
Index: exp_disp.adb
===================================================================
--- exp_disp.adb (revision 221098)
+++ exp_disp.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -64,7 +64,6 @@
with SCIL_LL; use SCIL_LL;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
-with Uintp; use Uintp;
package body Exp_Disp is
@@ -8046,7 +8045,7 @@
-- way we ensure that the final position of all the primitives is
-- established by the following stages of this algorithm.
- Set_DT_Position (Prim, No_Uint);
+ Set_DT_Position_Value (Prim, No_Uint);
Next_Elmt (Prim_Elmt);
end loop;
@@ -8104,9 +8103,10 @@
if Chars (Node (Op_Elmt_2)) = Chars (Parent_Subp)
and then Type_Conformant (Prim_Op, Node (Op_Elmt_2))
then
- Set_DT_Position (Prim_Op, DT_Position (Parent_Subp));
- Set_DT_Position (Node (Op_Elmt_2),
+ Set_DT_Position_Value (Prim_Op,
DT_Position (Parent_Subp));
+ Set_DT_Position_Value (Node (Op_Elmt_2),
+ DT_Position (Parent_Subp));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim_Op)));
goto Next_Primitive;
@@ -8163,10 +8163,11 @@
if In_Predef_Prims_DT (Prim) then
if Is_Predefined_Dispatching_Operation (Prim) then
- Set_DT_Position (Prim, Default_Prim_Op_Position (Prim));
+ Set_DT_Position_Value (Prim,
+ Default_Prim_Op_Position (Prim));
else pragma Assert (Present (Alias (Prim)));
- Set_DT_Position (Prim,
+ Set_DT_Position_Value (Prim,
Default_Prim_Op_Position (Ultimate_Alias (Prim)));
end if;
@@ -8181,12 +8182,12 @@
and then Present (DTC_Entity (Interface_Alias (Prim))));
E := Interface_Alias (Prim);
- Set_DT_Position (Prim, DT_Position (E));
+ Set_DT_Position_Value (Prim, DT_Position (E));
pragma Assert
(DT_Position (Alias (Prim)) = No_Uint
or else DT_Position (Alias (Prim)) = DT_Position (E));
- Set_DT_Position (Alias (Prim), DT_Position (E));
+ Set_DT_Position_Value (Alias (Prim), DT_Position (E));
Set_Fixed_Prim (UI_To_Int (DT_Position (Prim)));
-- Overriding primitives must use the same entry as the
@@ -8202,7 +8203,7 @@
and then Present (DTC_Entity (Alias (Prim)))
then
E := Alias (Prim);
- Set_DT_Position (Prim, DT_Position (E));
+ Set_DT_Position_Value (Prim, DT_Position (E));
if not Is_Predefined_Dispatching_Alias (E) then
Set_Fixed_Prim (UI_To_Int (DT_Position (E)));
@@ -8239,7 +8240,7 @@
exit when not Fixed_Prim (Nb_Prim);
end loop;
- Set_DT_Position (Prim, UI_From_Int (Nb_Prim));
+ Set_DT_Position_Value (Prim, UI_From_Int (Nb_Prim));
Set_Fixed_Prim (Nb_Prim);
end if;
@@ -8268,14 +8269,14 @@
Use_Full_View => True)
then
pragma Assert (DT_Position (Alias (Prim)) /= No_Uint);
- Set_DT_Position (Prim, DT_Position (Alias (Prim)));
+ Set_DT_Position_Value (Prim, DT_Position (Alias (Prim)));
-- Otherwise it will be placed in the secondary DT
else
pragma Assert
(DT_Position (Interface_Alias (Prim)) /= No_Uint);
- Set_DT_Position (Prim,
+ Set_DT_Position_Value (Prim,
DT_Position (Interface_Alias (Prim)));
end if;
end if;
@@ -8713,6 +8714,25 @@
end if;
end Set_CPP_Constructors;
+ ---------------------------
+ -- Set_DT_Position_Value --
+ ---------------------------
+
+ procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint) is
+ begin
+ Set_DT_Position (Prim, Value);
+
+ -- Propagate the value to the wrapped subprogram (if one is present)
+
+ if Ekind_In (Prim, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Prim)
+ and then Present (Wrapped_Entity (Prim))
+ and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
+ then
+ Set_DT_Position (Wrapped_Entity (Prim), Value);
+ end if;
+ end Set_DT_Position_Value;
+
--------------------------
-- Set_DTC_Entity_Value --
--------------------------
@@ -8734,6 +8754,16 @@
Set_DTC_Entity (Prim,
First_Tag_Component (Tagged_Type));
end if;
+
+ -- Propagate the value to the wrapped subprogram (if one is present)
+
+ if Ekind_In (Prim, E_Function, E_Procedure)
+ and then Is_Primitive_Wrapper (Prim)
+ and then Present (Wrapped_Entity (Prim))
+ and then Is_Dispatching_Operation (Wrapped_Entity (Prim))
+ then
+ Set_DTC_Entity (Wrapped_Entity (Prim), DTC_Entity (Prim));
+ end if;
end Set_DTC_Entity_Value;
-----------------
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb (revision 221109)
+++ sem_ch8.adb (working copy)
@@ -28,6 +28,7 @@
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
@@ -3261,7 +3262,7 @@
if Present (DTC_Entity (Old_S)) then
Set_DTC_Entity (New_S, DTC_Entity (Old_S));
- Set_DT_Position (New_S, DT_Position (Old_S));
+ Set_DT_Position_Value (New_S, DT_Position (Old_S));
end if;
end if;
end;
Index: exp_disp.ads
===================================================================
--- exp_disp.ads (revision 221098)
+++ exp_disp.ads (working copy)
@@ -4,9 +4,9 @@
-- --
-- E X P _ D I S P --
-- --
--- S p e c --
+-- GS p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,6 +27,7 @@
-- dispatching expansion.
with Types; use Types;
+with Uintp; use Uintp;
package Exp_Disp is
@@ -379,11 +380,14 @@
-- target object in its first argument; such implicit argument is explicit
-- in the IP procedures built here.
- procedure Set_DTC_Entity_Value
- (Tagged_Type : Entity_Id;
- Prim : Entity_Id);
+ procedure Set_DT_Position_Value (Prim : Entity_Id; Value : Uint);
+ -- Set the position of a dispatching primitive its dispatch table. For
+ -- subprogram wrappers propagate the value to the wrapped subprogram.
+
+ procedure Set_DTC_Entity_Value (Tagged_Type : Entity_Id; Prim : Entity_Id);
-- Set the definite value of the DTC_Entity value associated with a given
- -- primitive of a tagged type.
+ -- primitive of a tagged type. For subprogram wrappers propagat the value
+ -- to the wrapped subprogram.
procedure Write_DT (Typ : Entity_Id);
pragma Export (Ada, Write_DT);
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb (revision 221101)
+++ sem_ch13.adb (working copy)
@@ -7966,6 +7966,30 @@
end loop;
end;
+ -- Add invariants of progenitors
+
+ if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
+ declare
+ Ifaces_List : Elist_Id;
+ AI : Elmt_Id;
+ Iface : Entity_Id;
+
+ begin
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ AI := First_Elmt (Ifaces_List);
+ while Present (AI) loop
+ Iface := Node (AI);
+
+ if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
+ Add_Invariants (Iface, Inherit => True);
+ end if;
+
+ Next_Elmt (AI);
+ end loop;
+ end;
+ end if;
+
-- Build the procedure if we generated at least one Check pragma
if Stmts /= No_List then
Index: sem_disp.adb
===================================================================
--- sem_disp.adb (revision 221098)
+++ sem_disp.adb (working copy)
@@ -1122,7 +1122,7 @@
if Present (DTC_Entity (Old_Subp)) then
Set_DTC_Entity (Subp, DTC_Entity (Old_Subp));
- Set_DT_Position (Subp, DT_Position (Old_Subp));
+ Set_DT_Position_Value (Subp, DT_Position (Old_Subp));
if not Restriction_Active (No_Dispatching_Calls) then
if Building_Static_DT (Tagged_Type) then
@@ -1419,7 +1419,7 @@
end if;
if not Body_Is_Last_Primitive then
- Set_DT_Position (Subp, No_Uint);
+ Set_DT_Position_Value (Subp, No_Uint);
elsif Has_Controlled_Component (Tagged_Type)
and then Nam_In (Chars (Subp), Name_Initialize,
@@ -1678,7 +1678,7 @@
Check_Controlling_Formals (Tagged_Type, Old_Subp);
Set_Is_Dispatching_Operation (Old_Subp, True);
- Set_DT_Position (Old_Subp, No_Uint);
+ Set_DT_Position_Value (Old_Subp, No_Uint);
end if;
-- If the old subprogram is an explicit renaming of some other
More information about the Gcc-patches
mailing list