diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 11 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 14 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 23 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.adb | 40 | ||||
| -rwxr-xr-x | gcc/ada/sem_aux.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 40 |
7 files changed, 117 insertions, 33 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 81e0e099c04..ff1fba1b558 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +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. diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 0b783fa6b82..17b9fcb9eb3 100644 --- a/gcc/ada/checks.adb +++ b/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; diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index 8e9d2ca3188..4580ec2d0df 100644 --- a/gcc/ada/exp_ch13.adb +++ b/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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 236ee271894..e9c715ef2b1 100644 --- a/gcc/ada/freeze.adb +++ b/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)) diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 656692fe4fb..ee23d17c529 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 -- --------------------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 133788ea07d..8ef11ec8a7a 100755 --- a/gcc/ada/sem_aux.ads +++ b/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 diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 36038df6c65..78bebfc7e92 100644 --- a/gcc/ada/sem_prag.adb +++ b/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; |