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

gcc/ada/ChangeLog

+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.
+
 2010-10-22  Arnaud Charlet  <charlet@adacore.com>
 
 	* gcc-interface/utils.c, gcc-interface/gigi.h: Minor reformatting.

gcc/ada/checks.adb

@@ -1759,9 +1759,7 @@ package body Checks is
 
    procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
    begin
-      if Etype (N) /= Typ
-        and then Present (Predicate_Function (Typ))
-      then
+      if Present (Predicate_Function (Typ)) then
          Insert_Action (N,
            Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
       end if;

gcc/ada/exp_ch13.adb

@@ -152,7 +152,7 @@ package body Exp_Ch13 is
             if Opt.List_Inherited_Aspects then
                Error_Msg_Sloc := Sloc (Predicate_Function (T));
                Error_Msg_Node_2 := T;
-               Error_Msg_N ("?info: & inherits predicate from & at #", Typ);
+               Error_Msg_N ("?info: & inherits predicate from & #", Typ);
             end if;
          end if;
       end Add_Call;
@@ -272,21 +272,13 @@ package body Exp_Ch13 is
 
       Add_Predicates;
 
-      --  Deal with ancestor subtype and parent type
+      --  Add predicates for ancestor if present
 
       declare
-         Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
-
+         Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
       begin
-         --  If ancestor subtype present, add its predicates
-
          if Present (Atyp) then
             Add_Call (Atyp);
-
-         --  Else if this is derived, add predicates of parent type
-
-         elsif Is_Derived_Type (Typ) then
-            Add_Call (Etype (Base_Type (Typ)));
          end if;
       end;
 

gcc/ada/freeze.adb

@@ -3096,18 +3096,31 @@ package body Freeze is
             end if;
 
             --  If ancestor subtype present, freeze that first. Note that this
-            --  will also get the base type frozen.
+            --  will also get the base type frozen. Need RM reference ???
 
             Atype := Ancestor_Subtype (E);
 
             if Present (Atype) then
                Freeze_And_Append (Atype, N, Result);
 
-            --  Otherwise freeze the base type of the entity before freezing
-            --  the entity itself (RM 13.14(15)).
+            --  No ancestor subtype present
 
-            elsif E /= Base_Type (E) then
-               Freeze_And_Append (Base_Type (E), N, Result);
+            else
+               --  See if we have a nearest ancestor that has a predicate.
+               --  That catches the case of derived type with a predicate.
+               --  Need RM reference here ???
+
+               Atype := Nearest_Ancestor (E);
+
+               if Present (Atype) and then Has_Predicates (Atype) then
+                  Freeze_And_Append (Atype, N, Result);
+               end if;
+
+               --  Freeze base type before freezing the entity (RM 13.14(15))
+
+               if E /= Base_Type (E) then
+                  Freeze_And_Append (Base_Type (E), N, Result);
+               end if;
             end if;
 
          --  For a derived type, freeze its parent type first (RM 13.14(15))

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

gcc/ada/sem_aux.ads

@@ -181,6 +181,24 @@ package Sem_Aux is
    --  composite containing a limited component, or a subtype of any of
    --  these types).
 
+   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
+   --  Given a subtype Typ, this function finds out the nearest ancestor from
+   --  which constraints and predicates are inherited. There is no simple link
+   --  for doing this, consider:
+   --
+   --     subtype R is Integer range 1 .. 10;
+   --     type T is new R;
+   --
+   --  In this case the nearest ancestor is R, but the Etype of T'Base will
+   --  point to R'Base, so we have to go rummaging in the declarations to get
+   --  this information. It is used for making sure we freeze this before we
+   --  freeze Typ, and also for retrieving inherited predicate information.
+   --  For the case of base types or first subtypes, there is no useful entity
+   --  to return, so Empty is returned.
+   --
+   --  Note: this is similar to Ancestor_Subtype except that it also deals
+   --  with the case of derived types.
+
    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
    --  This is similar to Enclosing_Dynamic_Scope except that if Ent is itself
    --  a dynamic scope, then it is returned. Otherwise the result is the same

gcc/ada/sem_prag.adb

@@ -13696,27 +13696,39 @@ package body Sem_Prag is
       PP : Node_Id;
 
    begin
+      --  Loop through entries in check policy list
+
       PP := Opt.Check_Policy_List;
       loop
+         --  If there are no specific entries that matched, then we let the
+         --  setting of assertions govern. Note that this provides the needed
+         --  compatibility with the RM for the cases of assertion, invariant,
+         --  precondition, predicate, and postcondition.
+
          if No (PP) then
             return Assertions_Enabled;
 
-         elsif
-           Nam = Chars (Expression (First (Pragma_Argument_Associations (PP))))
-         then
-            case
-              Chars (Expression (Last (Pragma_Argument_Associations (PP))))
-            is
-            when Name_On | Name_Check =>
-               return True;
-            when Name_Off | Name_Ignore =>
-               return False;
-            when others =>
-               raise Program_Error;
-            end case;
+         --  Here we have an entry see if it matches
 
          else
-            PP := Next_Pragma (PP);
+            declare
+               PPA : constant List_Id := Pragma_Argument_Associations (PP);
+
+            begin
+               if Nam = Chars (Get_Pragma_Arg (First (PPA))) then
+                  case (Chars (Get_Pragma_Arg (Last (PPA)))) is
+                     when Name_On | Name_Check =>
+                        return True;
+                     when Name_Off | Name_Ignore =>
+                        return False;
+                     when others =>
+                        raise Program_Error;
+                  end case;
+
+               else
+                  PP := Next_Pragma (PP);
+               end if;
+            end;
          end if;
       end loop;
    end Check_Enabled;