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

1 files changed, 43 insertions, 13 deletions

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;
 
    -----------------