From: charlet Date: Tue, 26 Oct 2010 10:57:52 +0000 (+0000) Subject: 2010-10-26 Ed Schonberg X-Git-Url: http://git.sourceforge.jp/view?a=commitdiff_plain;h=2072eaa92671082da90c9deeceaf342506206201;p=pf3gnuchains%2Fgcc-fork.git 2010-10-26 Ed Schonberg * sem_ch5.adb: Adjust format of error message. 2010-10-26 Robert Dewar * einfo.ads, einfo.adb (OK_To_Reference): Removed, no longer used. * exp_util.adb (Side_Effect_Free): Put in safety barrier in code to detect renamings to avoid problems with invariants. * sem_ch13.adb (Replace_Type_References_Generic): New procedure (Build_Invariant_Procedure): Use Replace_Type_Reference_Generic (Build_Predicate_Function): Use Replace_Type_Reference_Generic * sem_res.adb, sem_ch8.adb, sem_ch4.adb (OK_To_Reference): Remove references, flag is no longer set. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165944 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cdc66e4aa3c..c4ab24377e4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,18 @@ +2010-10-26 Ed Schonberg + + * sem_ch5.adb: Adjust format of error message. + +2010-10-26 Robert Dewar + + * einfo.ads, einfo.adb (OK_To_Reference): Removed, no longer used. + * exp_util.adb (Side_Effect_Free): Put in safety barrier in code to + detect renamings to avoid problems with invariants. + * sem_ch13.adb (Replace_Type_References_Generic): New procedure + (Build_Invariant_Procedure): Use Replace_Type_Reference_Generic + (Build_Predicate_Function): Use Replace_Type_Reference_Generic + * sem_res.adb, sem_ch8.adb, sem_ch4.adb (OK_To_Reference): Remove + references, flag is no longer set. + 2010-10-26 Vincent Celier * prj.ads (Source_Data): New Boolean component Initialized, defaulted diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 50463979ca3..4c2530aed82 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -513,10 +513,10 @@ package body Einfo is -- Is_Underlying_Record_View Flag246 -- OK_To_Rename Flag247 -- Has_Inheritable_Invariants Flag248 - -- OK_To_Reference Flag249 -- Has_Predicates Flag250 -- (unused) Flag151 + -- (unused) Flag249 -- (unused) Flag251 -- (unused) Flag252 -- (unused) Flag253 @@ -2314,11 +2314,6 @@ package body Einfo is return Uint10 (Id); end Normalized_Position_Max; - function OK_To_Reference (Id : E) return B is - begin - return Flag249 (Id); - end OK_To_Reference; - function OK_To_Rename (Id : E) return B is begin pragma Assert (Ekind (Id) = E_Variable); @@ -4808,11 +4803,6 @@ package body Einfo is Set_Uint10 (Id, V); end Set_Normalized_Position_Max; - procedure Set_OK_To_Reference (Id : E; V : B := True) is - begin - Set_Flag249 (Id, V); - end Set_OK_To_Reference; - procedure Set_OK_To_Rename (Id : E; V : B := True) is begin pragma Assert (Ekind (Id) = E_Variable); @@ -7517,7 +7507,6 @@ package body Einfo is W ("No_Strict_Aliasing", Flag136 (Id)); W ("Non_Binary_Modulus", Flag58 (Id)); W ("Nonzero_Is_True", Flag162 (Id)); - W ("OK_To_Reference", Flag249 (Id)); W ("OK_To_Rename", Flag247 (Id)); W ("OK_To_Reorder_Components", Flag239 (Id)); W ("Optimize_Alignment_Space", Flag241 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 851333db34a..3a0b36a636f 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3151,12 +3151,6 @@ package Einfo is -- Applies to subprograms and subprogram types. Yields the number of -- formals as a value of type Pos. --- OK_To_Reference (Flag249) --- Present in all entities. If set it indicates that a naked reference to --- the entity is permitted within an expression that is being preanalyzed --- (for example, a type name may be referenced within the Invariant --- or Predicate aspect expression for a type). - -- OK_To_Rename (Flag247) -- Present only in entities for variables. If this flag is set, it -- means that if the entity is used as the initial value of an object @@ -4739,7 +4733,6 @@ package Einfo is -- Needs_Debug_Info (Flag147) -- Never_Set_In_Source (Flag115) -- No_Return (Flag113) - -- OK_To_Reference (Flag249) -- Overlays_Constant (Flag243) -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) @@ -6191,7 +6184,6 @@ package Einfo is function Normalized_First_Bit (Id : E) return U; function Normalized_Position (Id : E) return U; function Normalized_Position_Max (Id : E) return U; - function OK_To_Reference (Id : E) return B; function OK_To_Rename (Id : E) return B; function OK_To_Reorder_Components (Id : E) return B; function Optimize_Alignment_Space (Id : E) return B; @@ -6779,7 +6771,6 @@ package Einfo is procedure Set_Normalized_First_Bit (Id : E; V : U); procedure Set_Normalized_Position (Id : E; V : U); procedure Set_Normalized_Position_Max (Id : E; V : U); - procedure Set_OK_To_Reference (Id : E; V : B := True); procedure Set_OK_To_Rename (Id : E; V : B := True); procedure Set_OK_To_Reorder_Components (Id : E; V : B := True); procedure Set_Optimize_Alignment_Space (Id : E; V : B := True); @@ -7512,7 +7503,6 @@ package Einfo is pragma Inline (Normalized_First_Bit); pragma Inline (Normalized_Position); pragma Inline (Normalized_Position_Max); - pragma Inline (OK_To_Reference); pragma Inline (OK_To_Rename); pragma Inline (OK_To_Reorder_Components); pragma Inline (Optimize_Alignment_Space); @@ -7909,7 +7899,6 @@ package Einfo is pragma Inline (Set_Normalized_Position); pragma Inline (Set_Normalized_Position_Max); pragma Inline (Set_OK_To_Reorder_Components); - pragma Inline (Set_OK_To_Reference); pragma Inline (Set_OK_To_Rename); pragma Inline (Set_Optimize_Alignment_Space); pragma Inline (Set_Optimize_Alignment_Time); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 3a94befeffb..5fc7d4db48b 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4716,7 +4716,14 @@ package body Exp_Util is -- some cases, and an assignment can modify the component -- designated by N, so we need to create a temporary for it. + -- The guard testing for Entity being present is needed at least + -- in the case of rewritten predicate expressions, and may be + -- appropriate elsewhere. Obviously we can't go testing the entity + -- field if it does not exist, so it's reasonable to say that this + -- is not the renaming case if it does not exist. + elsif Is_Entity_Name (Original_Node (N)) + and then Present (Entity (Original_Node (N))) and then Is_Renaming_Of_Object (Entity (Original_Node (N))) and then Ekind (Entity (Original_Node (N))) /= E_Constant then diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 594cbce75a1..a46ba87f488 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -134,6 +134,17 @@ package body Sem_Ch13 is -- renaming_as_body. For tagged types, the specification is one of the -- primitive specs. + generic + with procedure Replace_Type_Reference (N : Node_Id); + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id); + -- This is used to scan an expression for a predicate or invariant aspect + -- replacing occurrences of the name TName (the name of the subtype to + -- which the aspect applies) with appropriate references to the parameter + -- of the predicate function or invariant procedure. The procedure passed + -- as a generic parameter does the actual replacement of node N, which is + -- either a simple direct reference to TName, or a selected component that + -- represents an appropriately qualified occurrence of TName. + procedure Set_Biased (E : Entity_Id; N : Node_Id; @@ -3552,56 +3563,46 @@ package body Sem_Ch13 is Assoc : List_Id; Str : String_Id; - function Replace_Node (N : Node_Id) return Traverse_Result; - -- Process single node for traversal to replace type references + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. - procedure Replace_Type is new Traverse_Proc (Replace_Node); - -- Traverse an expression changing every occurrence of an entity - -- reference to type T with a reference to the object argument. + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); + -- Traverse an expression replacing all occurrences of the subtype + -- name with appropriate references to the object that is the formal + -- parameter of the predicate function. - ------------------ - -- Replace_Node -- - ------------------ + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- - function Replace_Node (N : Node_Id) return Traverse_Result is + procedure Replace_Type_Reference (N : Node_Id) is begin - -- Case of entity name referencing the type - - if Is_Entity_Name (N) - and then Entity (N) = T - then - -- Invariant'Class, replace with T'Class (obj) - - if Class_Present (Ritem) then - Rewrite (N, - Make_Type_Conversion (Loc, - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (T, Loc), - Attribute_Name => Name_Class), - Expression => - Make_Identifier (Loc, - Chars => Object_Name))); - - -- Invariant, replace with obj - - else - Rewrite (N, - Make_Identifier (Loc, - Chars => Object_Name)); - end if; - - -- All done with this node - - return Skip; + -- Invariant'Class, replace with T'Class (obj) + + if Class_Present (Ritem) then + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (T, Loc), + Attribute_Name => Name_Class), + Expression => + Make_Identifier (Loc, + Chars => Object_Name))); - -- Not an instance of the type entity, keep going + -- Invariant, replace with obj else - return OK; + Rewrite (N, + Make_Identifier (Loc, + Chars => Object_Name)); end if; - end Replace_Node; + end Replace_Type_Reference; -- Start of processing for Add_Invariants @@ -3642,21 +3643,9 @@ package body Sem_Ch13 is -- We need to replace any occurrences of the name of the type -- with references to the object, converted to type'Class in - -- the case of Invariant'Class aspects. We do this by first - -- doing a preanalysis, to identify all the entities, then - -- we traverse looking for the type entity, and doing the - -- necessary substitution. The preanalysis is done with the - -- special OK_To_Reference flag set on the type, so that if - -- we get an occurrence of this type, it will be reognized - -- as legitimate. - - Set_OK_To_Reference (T, True); - Preanalyze_Spec_Expression (Exp, Standard_Boolean); - Set_OK_To_Reference (T, False); + -- the case of Invariant'Class aspects. - -- Do the traversal - - Replace_Type (Exp); + Replace_Type_References (Exp, Chars (T)); -- Build first two arguments for Check pragma @@ -3833,9 +3822,6 @@ package body Sem_Ch13 is FDecl : Node_Id; FBody : Node_Id; - TName : constant Name_Id := Chars (Typ); - -- Name of the type, used for replacement in predicate expression - Expr : Node_Id; -- This is the expression for the return statement in the function. It -- is build by connecting the component predicates with AND THEN. @@ -3911,107 +3897,26 @@ package body Sem_Ch13 is Arg1 : Node_Id; Arg2 : Node_Id; - function Replace_Node (N : Node_Id) return Traverse_Result; - -- Process single node for traversal to replace type references + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single occurrence N of the subtype name with a reference + -- to the formal of the predicate function. N can be an identifier + -- referencing the subtype, or a selected component, representing an + -- appropriately qualified occurrence of the subtype name. - procedure Replace_Type is new Traverse_Proc (Replace_Node); + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); -- Traverse an expression changing every occurrence of an identifier - -- whose name is TName with a reference to the object argument. + -- whose name mathches the name of the subtype with a reference to + -- the formal parameter of the predicate function. - ------------------ - -- Replace_Node -- - ------------------ - - function Replace_Node (N : Node_Id) return Traverse_Result is - S : Entity_Id; - P : Node_Id; + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- + procedure Replace_Type_Reference (N : Node_Id) is begin - -- Case of identifier - - if Nkind (N) = N_Identifier then - - -- If not the type name, all done with this node - - if Chars (N) /= TName then - return Skip; - - -- Otherwise do the replacement - - else - goto Do_Replace; - end if; - - -- Case of selected component (which is what a qualification - -- looks like in the unanalyzed tree, which is what we have. - - elsif Nkind (N) = N_Selected_Component then - - -- If selector name is not our type, keeping going (we might - -- still have an occurrence of the type in the prefix). - - if Nkind (Selector_Name (N)) /= N_Identifier - or else Chars (Selector_Name (N)) /= TName - then - return OK; - - -- Selector name is our type, check qualification - - else - -- Loop through scopes and prefixes, doing comparison - - S := Current_Scope; - P := Prefix (N); - loop - -- Continue if no more scopes or scope with no name - - if No (S) or else Nkind (S) not in N_Has_Chars then - return OK; - end if; - - -- Do replace if prefix is an identifier matching the - -- scope that we are currently looking at. - - if Nkind (P) = N_Identifier - and then Chars (P) = Chars (S) - then - goto Do_Replace; - end if; - - -- Go check scope above us if prefix is itself of the - -- form of a selected component, whose selector matches - -- the scope we are currently looking at. - - if Nkind (P) = N_Selected_Component - and then Nkind (Selector_Name (P)) = N_Identifier - and then Chars (Selector_Name (P)) = Chars (S) - then - S := Scope (S); - P := Prefix (P); - - -- For anything else, we don't have a match, so keep on - -- going, there are still some weird cases where we may - -- still have a replacement within the prefix. - - else - return OK; - end if; - end loop; - end if; - - -- Continue for any other node kind - - else - return OK; - end if; - - <> - - -- Replace with object - Rewrite (N, Make_Identifier (Loc, Chars => Object_Name)); - return Skip; - end Replace_Node; + end Replace_Type_Reference; -- Start of processing for Add_Predicates @@ -4036,7 +3941,7 @@ package body Sem_Ch13 is -- First We need to replace any occurrences of the name of -- the type with references to the object. - Replace_Type (Arg2); + Replace_Type_References (Arg2, Chars (Typ)); -- OK, replacement complete, now we can add the expression @@ -6751,6 +6656,113 @@ package body Sem_Ch13 is return False; end Rep_Item_Too_Late; + ------------------------------------- + -- Replace_Type_References_Generic -- + ------------------------------------- + + procedure Replace_Type_References_Generic (N : Node_Id; TName : Name_Id) is + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Processes a single node in the traversal procedure below, checking + -- if node N should be replaced, and if so, doing the replacement. + + procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node); + -- This instantiation provides the body of Replace_Type_References + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + S : Entity_Id; + P : Node_Id; + + begin + -- Case of identifier + + if Nkind (N) = N_Identifier then + + -- If not the type name, all done with this node + + if Chars (N) /= TName then + return Skip; + + -- Otherwise do the replacement and we are done with this node + + else + Replace_Type_Reference (N); + return Skip; + end if; + + -- Case of selected component (which is what a qualification + -- looks like in the unanalyzed tree, which is what we have. + + elsif Nkind (N) = N_Selected_Component then + + -- If selector name is not our type, keeping going (we might + -- still have an occurrence of the type in the prefix). + + if Nkind (Selector_Name (N)) /= N_Identifier + or else Chars (Selector_Name (N)) /= TName + then + return OK; + + -- Selector name is our type, check qualification + + else + -- Loop through scopes and prefixes, doing comparison + + S := Current_Scope; + P := Prefix (N); + loop + -- Continue if no more scopes or scope with no name + + if No (S) or else Nkind (S) not in N_Has_Chars then + return OK; + end if; + + -- Do replace if prefix is an identifier matching the + -- scope that we are currently looking at. + + if Nkind (P) = N_Identifier + and then Chars (P) = Chars (S) + then + Replace_Type_Reference (N); + return Skip; + end if; + + -- Go check scope above us if prefix is itself of the + -- form of a selected component, whose selector matches + -- the scope we are currently looking at. + + if Nkind (P) = N_Selected_Component + and then Nkind (Selector_Name (P)) = N_Identifier + and then Chars (Selector_Name (P)) = Chars (S) + then + S := Scope (S); + P := Prefix (P); + + -- For anything else, we don't have a match, so keep on + -- going, there are still some weird cases where we may + -- still have a replacement within the prefix. + + else + return OK; + end if; + end loop; + end if; + + -- Continue for any other node kind + + else + return OK; + end if; + end Replace_Node; + + begin + Replace_Type_Refs (N); + end Replace_Type_References_Generic; + ------------------------- -- Same_Representation -- ------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 604a9b16b14..8d743f21cc9 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -5584,13 +5584,6 @@ package body Sem_Ch4 is return False; end if; - -- If OK_To_Reference is set for the entity, then don't complain, it - -- means we are doing a preanalysis in which such complaints are wrong. - - if OK_To_Reference (Entity (Enode)) then - return False; - end if; - -- Now test the entity we got to see if it is a bad case case Ekind (Entity (Enode)) is diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index e7091cd2092..5edc3425a0e 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2011,7 +2011,7 @@ package body Sem_Ch5 is Set_Etype (Def_Id, Component_Type (Typ)); else Error_Msg_N - ("to iterate over the elements of an array, use 'O'F", N); + ("to iterate over the elements of an array, use OF", N); Set_Etype (Def_Id, Etype (First_Index (Typ))); end if; diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0aaa426ece6..9785348dc3e 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5481,9 +5481,6 @@ package body Sem_Ch8 is -- Reference to type name in predicate/invariant expression - elsif OK_To_Reference (Etype (P)) then - Analyze_Selected_Component (N); - elsif Is_Appropriate_For_Entry_Prefix (P_Type) and then not In_Open_Scopes (P_Name) and then (not Is_Concurrent_Type (Etype (P_Name)) diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index e92477ea30b..cf710469c83 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5971,12 +5971,6 @@ package body Sem_Res is then null; - -- Allow reference to type specifically marked as being OK in this - -- context (this is used for example for type names in invariants). - - elsif OK_To_Reference (E) then - null; - -- Any other use is an eror else