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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@221113 138bc75d-0d04-0410-961f-82ee72b054a4

11 files changed, 223 insertions, 42 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1c8ef6a8f46..d05d5c41a9a 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,31 @@
+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.
+
 2015-03-02  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_attr.adb (Analyze_Attribute): Factor out heavily indented
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 370f3e20d44..4210968c0ce 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -671,7 +671,7 @@ package body Exp_Ch6 is
               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);
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 6c1858bd595..9fa05009dbd 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -1240,6 +1240,12 @@ package body Exp_Ch9 is
       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;
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index c0613bb80ce..e8fb0897fa6 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -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 Stringt;  use Stringt;
 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 @@ package body Exp_Disp is
          --  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,8 +8103,9 @@ package body Exp_Disp is
                      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)));
 
@@ -8163,10 +8163,11 @@ package body Exp_Disp is
 
             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 @@ package body Exp_Disp is
                  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 @@ package body Exp_Disp is
               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 @@ package body Exp_Disp is
                   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 @@ package body Exp_Disp is
                   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 @@ package body Exp_Disp is
       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 @@ package body Exp_Disp is
          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;
 
    -----------------
diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads
index 67b8be0d4b5..9a364660b33 100644
--- a/gcc/ada/exp_disp.ads
+++ b/gcc/ada/exp_disp.ads
@@ -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 @@ package Exp_Disp is
    --  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);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 629b9ea5f7a..5883e4c5e92 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -7966,6 +7966,30 @@ package body Sem_Ch13 is
          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
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 537be5ea6f3..681e47cfd89 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -8640,6 +8640,36 @@ package body Sem_Ch3 is
                   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 @@ package body Sem_Ch3 is
 
          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 @@ package body Sem_Ch3 is
                         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 @@ package body Sem_Ch3 is
          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
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index 4d0bf159b3e..8af1f346ebc 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -1482,7 +1482,7 @@ package body Sem_Ch7 is
             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 @@ package body Sem_Ch7 is
          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;
+
+                  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;
+                        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 @@ package body Sem_Ch7 is
                        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;
 
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index 5695033171d..b86e1514efc 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -28,6 +28,7 @@ with Debug;    use Debug;
 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 @@ package body Sem_Ch8 is
 
                      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;
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index b49913dd57a..bc36c27cb4b 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -1122,7 +1122,7 @@ package body Sem_Disp is
 
                      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 @@ package body Sem_Disp is
       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 @@ package body Sem_Disp is
 
                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
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 9e216c642fe..602c411e056 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -15277,6 +15277,11 @@ package body Sem_Prag is
             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,8 +15323,14 @@ package body Sem_Prag is
             --  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);