checks.adb (Apply_Predicate_Check): Remove attempt at optimization when subtype is the same...

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Apply_Predicate_Check): Remove attempt at optimization
	when subtype is the same, caused legitimate checks to be missed.
	* exp_ch13.adb (Build_Predicate_Function): Use Nearest_Ancestor to get
	inheritance from right entity.
	* freeze.adb (Freeze_Entity): Use Nearest_Ancestor to freeze in the
	derived type case if the ancestor type has predicates.
	* sem_aux.ads, sem_aux.adb (Nearest_Ancestor): New function.
	* sem_prag.adb (Check_Enabled): Minor code reorganization.

From-SVN: r165807

1 files changed, 40 insertions, 0 deletions

diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index 656692f..ee23d17 100755
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -749,6 +749,46 @@ package body Sem_Aux is
       end if;
    end Is_Limited_Type;
 
+   ----------------------
+   -- Nearest_Ancestor --
+   ----------------------
+
+   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
+         D : constant Node_Id := Declaration_Node (Typ);
+
+   begin
+      --  If we have a subtype declaration, get the ancestor subtype
+
+      if Nkind (D) = N_Subtype_Declaration then
+         if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
+            return Entity (Subtype_Mark (Subtype_Indication (D)));
+         else
+            return Entity (Subtype_Indication (D));
+         end if;
+
+      --  If derived type declaration, find who we are derived from
+
+      elsif Nkind (D) = N_Full_Type_Declaration
+        and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
+      then
+         declare
+            DTD : constant Entity_Id := Type_Definition (D);
+            SI  : constant Entity_Id := Subtype_Indication (DTD);
+         begin
+            if Is_Entity_Name (SI) then
+               return Entity (SI);
+            else
+               return Entity (Subtype_Mark (SI));
+            end if;
+         end;
+
+      --  Otherwise, nothing useful to return, return Empty
+
+      else
+         return Empty;
+      end if;
+   end Nearest_Ancestor;
+
    ---------------------------
    -- Nearest_Dynamic_Scope --
    ---------------------------