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, 33 insertions, 14 deletions

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;