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