From 273adcdf9fbd8521e9f0d39e8a9f22d0c53b482d Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 2 Aug 2011 12:31:12 +0200 Subject: [PATCH] [multiple changes] 2011-08-02 Jerome Guitton * a-except-2005.adb (Raise_From_Signal_Handler): Call Debug_Raise_Exception before propagation starts. 2011-08-02 Eric Botcazou * exp_ch6.adb (Expand_Call): Guard restriction checks with a call to Restriction_Check_Required. * sem_ch3.adb (Analyze_Object_Declaration): Likewise. * sem_res.adb (Resolve_Call): Likewise. * sem_attr.adb (Check_Stream_Attribute): Likewise. 2011-08-02 Bob Duff * stylesw.ads: Update comment. * style.adb: Minor: Use Error_Msg_NE instead of Error_Msg_N. * errout.ads: Remove obsolete comment. 2011-08-02 Javier Miranda * einfo.ads, einfo.adb (Is_Safe_To_Reevaluate): new function. (Set_Is_Safe_To_Reevaluate): new procedure. * sem_ch5.adb (Analyze_Assignment): Add one assertion to ensure that no assignment is allowed on safe-to-reevaluate variables. (Analyze_Iteration_Schine.Process_Bounds.One_Bound): Decorate the temporary created to remove side effects in expressions that use the secondary stack as safe-to-reevaluate. * exp_util.adb (Side_Effect_Free): Add missing code to handle well variables that are not true constants. From-SVN: r177129 --- gcc/ada/ChangeLog | 31 +++ gcc/ada/a-except-2005.adb | 1 + gcc/ada/einfo.adb | 14 +- gcc/ada/einfo.ads | 13 +- gcc/ada/errout.ads | 3 +- gcc/ada/exp_ch6.adb | 7 +- gcc/ada/exp_util.adb | 459 +++++++++++++++++++------------------- gcc/ada/sem_attr.adb | 7 +- gcc/ada/sem_ch3.adb | 3 +- gcc/ada/sem_ch5.adb | 18 +- gcc/ada/sem_res.adb | 10 +- gcc/ada/style.adb | 14 +- gcc/ada/stylesw.ads | 4 +- 13 files changed, 331 insertions(+), 253 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2a62cee0070..693d8654302 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2011-08-02 Jerome Guitton + + * a-except-2005.adb (Raise_From_Signal_Handler): Call + Debug_Raise_Exception before propagation starts. + +2011-08-02 Eric Botcazou + + * exp_ch6.adb (Expand_Call): Guard restriction checks with a call + to Restriction_Check_Required. + * sem_ch3.adb (Analyze_Object_Declaration): Likewise. + * sem_res.adb (Resolve_Call): Likewise. + * sem_attr.adb (Check_Stream_Attribute): Likewise. + +2011-08-02 Bob Duff + + * stylesw.ads: Update comment. + * style.adb: Minor: Use Error_Msg_NE instead of Error_Msg_N. + * errout.ads: Remove obsolete comment. + +2011-08-02 Javier Miranda + + * einfo.ads, einfo.adb (Is_Safe_To_Reevaluate): new function. + (Set_Is_Safe_To_Reevaluate): new procedure. + * sem_ch5.adb (Analyze_Assignment): Add one assertion to ensure that no + assignment is allowed on safe-to-reevaluate variables. + (Analyze_Iteration_Schine.Process_Bounds.One_Bound): Decorate the + temporary created to remove side effects in expressions that use + the secondary stack as safe-to-reevaluate. + * exp_util.adb (Side_Effect_Free): Add missing code to handle well + variables that are not true constants. + 2011-08-02 Robert Dewar * sem_ch5.adb, sem_ch7.adb, einfo.ads, sem_util.adb, sem_util.ads, diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 6441fd6d164..d7763db6b8c 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -924,6 +924,7 @@ package body Ada.Exceptions is begin Exception_Data.Set_Exception_C_Msg (E, M); Abort_Defer.all; + Debug_Raise_Exception (E => SSL.Exception_Data_Ptr (E)); Exception_Propagation.Propagate_Exception (E => E, From_Signal_Handler => True); end Raise_From_Signal_Handler; diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index c66b35a5764..eb217d49d59 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -514,9 +514,9 @@ package body Einfo is -- Is_Underlying_Record_View Flag246 -- OK_To_Rename Flag247 -- Has_Inheritable_Invariants Flag248 + -- Is_Safe_To_Reevaluate Flag249 -- Has_Predicates Flag250 - -- (unused) Flag249 -- (unused) Flag251 -- (unused) Flag252 -- (unused) Flag253 @@ -2058,6 +2058,11 @@ package body Einfo is return Flag209 (Id); end Is_Return_Object; + function Is_Safe_To_Reevaluate (Id : E) return B is + begin + return Flag249 (Id); + end Is_Safe_To_Reevaluate; + function Is_Shared_Passive (Id : E) return B is begin return Flag60 (Id); @@ -4542,6 +4547,12 @@ package body Einfo is Set_Flag209 (Id, V); end Set_Is_Return_Object; + procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True) is + begin + pragma Assert (Ekind (Id) = E_Variable); + Set_Flag249 (Id, V); + end Set_Is_Safe_To_Reevaluate; + procedure Set_Is_Shared_Passive (Id : E; V : B := True) is begin Set_Flag60 (Id, V); @@ -7501,6 +7512,7 @@ package body Einfo is W ("Is_Remote_Types", Flag61 (Id)); W ("Is_Renaming_Of_Object", Flag112 (Id)); W ("Is_Return_Object", Flag209 (Id)); + W ("Is_Safe_To_Reevaluate", Flag249 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 7368fdf64c7..e69704d86ab 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2683,6 +2683,12 @@ package Einfo is -- Present in all object entities. True if the object is the return -- object of an extended_return_statement; False otherwise. +-- Is_Safe_To_Reevaluate (Flag249) +-- Present in all entities. Set in variables that are initialized by +-- means of an assignment statement. When initialized their contents +-- never change and hence they can be seen by the backend as constants. +-- See also Is_True_Constant. + -- Is_Scalar_Type (synthesized) -- Applies to all entities, true for scalar types and subtypes @@ -2771,7 +2777,7 @@ package Einfo is -- treated as a constant by the code generator. For a constant, it means -- that the constant was not modified by generated code (e.g. to set a -- discriminant in an init proc). Assignments by user or generated code --- will reset this flag. +-- will reset this flag. See also Is_Safe_To_Reevaluate. -- Is_Type (synthesized) -- Applies to all entities, true for a type entity @@ -5659,6 +5665,7 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) + -- Is_Safe_To_Reevaluate (Flag249) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) @@ -6165,6 +6172,7 @@ package Einfo is function Is_Remote_Types (Id : E) return B; function Is_Renaming_Of_Object (Id : E) return B; function Is_Return_Object (Id : E) return B; + function Is_Safe_To_Reevaluate (Id : E) return B; function Is_Shared_Passive (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; function Is_Tag (Id : E) return B; @@ -6753,6 +6761,7 @@ package Einfo is procedure Set_Is_Remote_Types (Id : E; V : B := True); procedure Set_Is_Renaming_Of_Object (Id : E; V : B := True); procedure Set_Is_Return_Object (Id : E; V : B := True); + procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); @@ -7480,6 +7489,7 @@ package Einfo is pragma Inline (Is_Remote_Types); pragma Inline (Is_Renaming_Of_Object); pragma Inline (Is_Return_Object); + pragma Inline (Is_Safe_To_Reevaluate); pragma Inline (Is_Scalar_Type); pragma Inline (Is_Shared_Passive); pragma Inline (Is_Signed_Integer_Type); @@ -7882,6 +7892,7 @@ package Einfo is pragma Inline (Set_Is_Remote_Types); pragma Inline (Set_Is_Renaming_Of_Object); pragma Inline (Set_Is_Return_Object); + pragma Inline (Set_Is_Safe_To_Reevaluate); pragma Inline (Set_Is_Shared_Passive); pragma Inline (Set_Is_Statically_Allocated); pragma Inline (Set_Is_Tag); diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 57b8efe0abb..fc2cf49158f 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -624,8 +624,7 @@ package Errout is -- (parameters ....) -- Any message marked with this -- CODEFIX comment should not be modified - -- without appropriate coordination. If new messages are added which may - -- be susceptible to automatic codefix action, they are marked using: + -- without appropriate coordination. ------------------------------ -- Error Output Subprograms -- diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index e61de38dedf..0d2c12c147a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2936,12 +2936,15 @@ package body Exp_Ch6 is -- Check for violation of No_Abort_Statements - if Is_RTE (Subp, RE_Abort_Task) then + if Restriction_Check_Required (No_Abort_Statements) + and then Is_RTE (Subp, RE_Abort_Task) + then Check_Restriction (No_Abort_Statements, Call_Node); -- Check for violation of No_Dynamic_Attachment - elsif RTU_Loaded (Ada_Interrupts) + elsif Restriction_Check_Required (No_Dynamic_Attachment) + and then RTU_Loaded (Ada_Interrupts) and then (Is_RTE (Subp, RE_Is_Reserved) or else Is_RTE (Subp, RE_Is_Attached) or else Is_RTE (Subp, RE_Current_Handler) or else diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 8923702bc3c..80c806c7ae4 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -69,20 +69,20 @@ package body Exp_Util is Id_Ref : Node_Id; A_Type : Entity_Id; Dyn : Boolean := False) return Node_Id; - -- Build function to generate the image string for a task that is an - -- array component, concatenating the images of each index. To avoid - -- storage leaks, the string is built with successive slice assignments. - -- The flag Dyn indicates whether this is called for the initialization - -- procedure of an array of tasks, or for the name of a dynamically - -- created task that is assigned to an indexed component. + -- Build function to generate the image string for a task that is an array + -- component, concatenating the images of each index. To avoid storage + -- leaks, the string is built with successive slice assignments. The flag + -- Dyn indicates whether this is called for the initialization procedure of + -- an array of tasks, or for the name of a dynamically created task that is + -- assigned to an indexed component. function Build_Task_Image_Function (Loc : Source_Ptr; Decls : List_Id; Stats : List_Id; Res : Entity_Id) return Node_Id; - -- Common processing for Task_Array_Image and Task_Record_Image. - -- Build function body that computes image. + -- Common processing for Task_Array_Image and Task_Record_Image. Build + -- function body that computes image. procedure Build_Task_Image_Prefix (Loc : Source_Ptr; @@ -93,34 +93,34 @@ package body Exp_Util is Sum : Node_Id; Decls : List_Id; Stats : List_Id); - -- Common processing for Task_Array_Image and Task_Record_Image. - -- Create local variables and assign prefix of name to result string. + -- Common processing for Task_Array_Image and Task_Record_Image. Create + -- local variables and assign prefix of name to result string. function Build_Task_Record_Image (Loc : Source_Ptr; Id_Ref : Node_Id; Dyn : Boolean := False) return Node_Id; - -- Build function to generate the image string for a task that is a - -- record component. Concatenate name of variable with that of selector. - -- The flag Dyn indicates whether this is called for the initialization - -- procedure of record with task components, or for a dynamically - -- created task that is assigned to a selected component. + -- Build function to generate the image string for a task that is a record + -- component. Concatenate name of variable with that of selector. The flag + -- Dyn indicates whether this is called for the initialization procedure of + -- record with task components, or for a dynamically created task that is + -- assigned to a selected component. function Make_CW_Equivalent_Type (T : Entity_Id; E : Node_Id) return Entity_Id; -- T is a class-wide type entity, E is the initial expression node that - -- constrains T in case such as: " X: T := E" or "new T'(E)" - -- This function returns the entity of the Equivalent type and inserts - -- on the fly the necessary declaration such as: + -- constrains T in case such as: " X: T := E" or "new T'(E)". This function + -- returns the entity of the Equivalent type and inserts on the fly the + -- necessary declaration such as: -- -- type anon is record -- _parent : Root_Type (T); constrained with E discriminants (if any) -- Extension : String (1 .. expr to match size of E); -- end record; -- - -- This record is compatible with any object of the class of T thanks - -- to the first field and has the same size as E thanks to the second. + -- This record is compatible with any object of the class of T thanks to + -- the first field and has the same size as E thanks to the second. function Make_Literal_Range (Loc : Source_Ptr; @@ -163,14 +163,14 @@ package body Exp_Util is Ti : Entity_Id; begin - -- For now, we simply ignore a call where the argument has no - -- type (probably case of unanalyzed condition), or has a type - -- that is not Boolean. This is because this is a pretty marginal - -- piece of functionality, and violations of these rules are - -- likely to be truly marginal (how much code uses Fortran Logical - -- as the barrier to a protected entry?) and we do not want to - -- blow up existing programs. We can change this to an assertion - -- after 3.12a is released ??? + -- For now, we simply ignore a call where the argument has no type + -- (probably case of unanalyzed condition), or has a type that is not + -- Boolean. This is because this is a pretty marginal piece of + -- functionality, and violations of these rules are likely to be + -- truly marginal (how much code uses Fortran Logical as the barrier + -- to a protected entry?) and we do not want to blow up existing + -- programs. We can change this to an assertion after 3.12a is + -- released ??? if No (T) or else not Is_Boolean_Type (T) then return; @@ -194,8 +194,8 @@ package body Exp_Util is -- ityp!(N) /= False'Enum_Rep - -- where ityp is an integer type with large enough size to hold - -- any value of type T. + -- where ityp is an integer type with large enough size to hold any + -- value of type T. if Nonzero_Is_True (T) or else Has_Non_Standard_Rep (T) then if Esize (T) <= Esize (Standard_Integer) then @@ -262,8 +262,8 @@ package body Exp_Util is then return; - -- Otherwise we perform a conversion from the current type, - -- which must be Standard.Boolean, to the desired type. + -- Otherwise we perform a conversion from the current type, which + -- must be Standard.Boolean, to the desired type. else Set_Analyzed (N); @@ -340,6 +340,7 @@ package body Exp_Util is -- of the components. The constructed image has the form of an indexed -- component, whose prefix is the outer variable of the array type. -- The n-dimensional array type has known indexes Index, Index2... + -- Id_Ref is an indexed component form created by the enclosing init proc. -- Its successive indexes are Val1, Val2, ... which are the loop variables -- in the loops that call the individual task init proc on each component. @@ -372,8 +373,8 @@ package body Exp_Util is -- return Res; -- end F; -- - -- Needless to say, multidimensional arrays of tasks are rare enough - -- that the bulkiness of this code is not really a concern. + -- Needless to say, multidimensional arrays of tasks are rare enough that + -- the bulkiness of this code is not really a concern. function Build_Task_Array_Image (Loc : Source_Ptr; @@ -415,8 +416,8 @@ package body Exp_Util is Stats : constant List_Id := New_List; begin - -- For a dynamic task, the name comes from the target variable. - -- For a static one it is a formal of the enclosing init proc. + -- For a dynamic task, the name comes from the target variable. For a + -- static one it is a formal of the enclosing init proc. if Dyn then Get_Name_String (Chars (Entity (Prefix (Id_Ref)))); @@ -624,9 +625,9 @@ package body Exp_Util is or else Nkind (Id_Ref) = N_Defining_Identifier then -- For a simple variable, the image of the task is built from - -- the name of the variable. To avoid possible conflict with - -- the anonymous type created for a single protected object, - -- add a numeric suffix. + -- the name of the variable. To avoid possible conflict with the + -- anonymous type created for a single protected object, add a + -- numeric suffix. T_Id := Make_Defining_Identifier (Loc, @@ -694,8 +695,8 @@ package body Exp_Util is Defining_Unit_Name => Make_Temporary (Loc, 'F'), Result_Definition => New_Occurrence_Of (Standard_String, Loc)); - -- Calls to 'Image use the secondary stack, which must be cleaned - -- up after the task name is built. + -- Calls to 'Image use the secondary stack, which must be cleaned up + -- after the task name is built. return Make_Subprogram_Body (Loc, Specification => Spec, @@ -1170,6 +1171,7 @@ package body Exp_Util is -- This function is applicable for both static and dynamic allocation of -- objects which are constrained by an initial expression. Basically it -- transforms an unconstrained subtype indication into a constrained one. + -- The expression may also be transformed in certain cases in order to -- avoid multiple evaluation. In the static allocation case, the general -- scheme is: @@ -1267,9 +1269,9 @@ package body Exp_Util is if Is_Itype (Exp_Typ) then -- Within an initialization procedure, a selected component - -- denotes a component of the enclosing record, and it appears - -- as an actual in a call to its own initialization procedure. - -- If this component depends on the outer discriminant, we must + -- denotes a component of the enclosing record, and it appears as + -- an actual in a call to its own initialization procedure. If + -- this component depends on the outer discriminant, we must -- generate the proper actual subtype for it. if Nkind (Exp) = N_Selected_Component @@ -1301,10 +1303,10 @@ package body Exp_Util is Defining_Identifier => T, Subtype_Indication => New_Reference_To (Exp_Typ, Loc))); - -- This type is marked as an itype even though it has an - -- explicit declaration because otherwise it can be marked - -- with Is_Generic_Actual_Type and generate spurious errors. - -- (see sem_ch8.Analyze_Package_Renaming and sem_type.covers) + -- This type is marked as an itype even though it has an explicit + -- declaration since otherwise Is_Generic_Actual_Type can get + -- set, resulting in the generation of spurious errors. (See + -- sem_ch8.Analyze_Package_Renaming and sem_type.covers) Set_Is_Itype (T); Set_Associated_Node_For_Itype (T, Exp); @@ -2353,9 +2355,9 @@ package body Exp_Util is -- If the action derives from stuff inside a record, then the actions -- are attached to the current scope, to be inserted and analyzed on - -- exit from the scope. The reason for this is that we may also - -- be generating freeze actions at the same time, and they must - -- eventually be elaborated in the correct order. + -- exit from the scope. The reason for this is that we may also be + -- generating freeze actions at the same time, and they must eventually + -- be elaborated in the correct order. if Is_Record_Type (Current_Scope) and then not Is_Frozen (Current_Scope) @@ -2375,18 +2377,18 @@ package body Exp_Util is end if; -- We now intend to climb up the tree to find the right point to - -- insert the actions. We start at Assoc_Node, unless this node is - -- a subexpression in which case we start with its parent. We do this - -- for two reasons. First it speeds things up. Second, if Assoc_Node - -- is itself one of the special nodes like N_And_Then, then we assume - -- that an initial request to insert actions for such a node does not - -- expect the actions to get deposited in the node for later handling - -- when the node is expanded, since clearly the node is being dealt - -- with by the caller. Note that in the subexpression case, N is - -- always the child we came from. - - -- N_Raise_xxx_Error is an annoying special case, it is a statement - -- if it has type Standard_Void_Type, and a subexpression otherwise. + -- insert the actions. We start at Assoc_Node, unless this node is a + -- subexpression in which case we start with its parent. We do this for + -- two reasons. First it speeds things up. Second, if Assoc_Node is + -- itself one of the special nodes like N_And_Then, then we assume that + -- an initial request to insert actions for such a node does not expect + -- the actions to get deposited in the node for later handling when the + -- node is expanded, since clearly the node is being dealt with by the + -- caller. Note that in the subexpression case, N is always the child we + -- came from. + + -- N_Raise_xxx_Error is an annoying special case, it is a statement if + -- it has type Standard_Void_Type, and a subexpression otherwise. -- otherwise. Procedure attribute references are also statements. if Nkind (Assoc_Node) in N_Subexpr @@ -2400,8 +2402,8 @@ package body Exp_Util is P := Assoc_Node; -- ??? does not agree with above! N := Parent (Assoc_Node); - -- Non-subexpression case. Note that N is initially Empty in this - -- case (N is only guaranteed Non-Empty in the subexpr case). + -- Non-subexpression case. Note that N is initially Empty in this case + -- (N is only guaranteed Non-Empty in the subexpr case). else P := Assoc_Node; @@ -2649,11 +2651,11 @@ package body Exp_Util is elsif Nkind (Parent (P)) = N_Component_Association then null; - -- Do not insert if the parent of P is either an N_Variant - -- node or an N_Record_Definition node, meaning in either - -- case that P is a member of a component list, and that - -- therefore the actions should be inserted outside the - -- complete record declaration. + -- Do not insert if the parent of P is either an N_Variant node + -- or an N_Record_Definition node, meaning in either case that + -- P is a member of a component list, and that therefore the + -- actions should be inserted outside the complete record + -- declaration. elsif Nkind (Parent (P)) = N_Variant or else Nkind (Parent (P)) = N_Record_Definition @@ -2666,8 +2668,8 @@ package body Exp_Util is -- loop is part of the elaboration procedure and is only -- elaborated during the second pass. - -- If the loop comes from source, or the entity is local to - -- the loop itself it must remain within. + -- If the loop comes from source, or the entity is local to the + -- loop itself it must remain within. elsif Nkind (Parent (P)) = N_Loop_Statement and then not Comes_From_Source (Parent (P)) @@ -3157,8 +3159,8 @@ package body Exp_Util is return Is_Possibly_Unaligned_Object (Renamed_Object (Entity (N))); end if; - -- Tagged and controlled types and aliased types are always aligned, - -- as are concurrent types. + -- Tagged and controlled types and aliased types are always aligned, as + -- are concurrent types. if Is_Aliased (T) or else Has_Controlled_Component (T) @@ -3186,9 +3188,9 @@ package body Exp_Util is begin -- If component reference is for an array with non-static bounds, - -- then it is always aligned: we can only process unaligned - -- arrays with static bounds (more accurately bounds known at - -- compile time). + -- then it is always aligned: we can only process unaligned arrays + -- with static bounds (more accurately bounds known at compile + -- time). if Is_Array_Type (T) and then not Compile_Time_Known_Bounds (T) @@ -3355,9 +3357,9 @@ package body Exp_Util is if Nkind (Pref) = N_Indexed_Component then Ptyp := Etype (Prefix (Pref)); - -- The only problematic case is when the array is packed, - -- in which case we really know nothing about the alignment - -- of individual components. + -- The only problematic case is when the array is packed, in + -- which case we really know nothing about the alignment of + -- individual components. if Is_Bit_Packed_Array (Ptyp) then return True; @@ -3370,8 +3372,8 @@ package body Exp_Util is -- We are definitely in trouble if the record in question -- has an alignment, and either we know this alignment is - -- inconsistent with the alignment of the slice, or we - -- don't know what the alignment of the slice should be. + -- inconsistent with the alignment of the slice, or we don't + -- know what the alignment of the slice should be. if Known_Alignment (Ptyp) and then (Unknown_Alignment (Styp) @@ -3407,8 +3409,8 @@ package body Exp_Util is end if; end; - -- For cases other than selected or indexed components we - -- know we are OK, since no issues arise over alignment. + -- For cases other than selected or indexed components we know we + -- are OK, since no issues arise over alignment. else return False; @@ -3624,8 +3626,8 @@ package body Exp_Util is Kill_Dead_Code (Private_Declarations (Specification (N))); -- ??? After this point, Delete_Tree has been called on all - -- declarations in Specification (N), so references to - -- entities therein look suspicious. + -- declarations in Specification (N), so references to entities + -- therein look suspicious. declare E : Entity_Id := First_Entity (Defining_Entity (N)); @@ -3639,8 +3641,8 @@ package body Exp_Util is end loop; end; - -- Recurse into composite statement to kill individual statements, - -- in particular instantiations. + -- Recurse into composite statement to kill individual statements in + -- particular instantiations. elsif Nkind (N) = N_If_Statement then Kill_Dead_Code (Then_Statements (N)); @@ -4003,8 +4005,8 @@ package body Exp_Util is Component_Items => Comp_List, Variant_Part => Empty)))); - -- Suppress all checks during the analysis of the expanded code - -- to avoid the generation of spurious warnings under ZFP run-time. + -- Suppress all checks during the analysis of the expanded code to avoid + -- the generation of spurious warnings under ZFP run-time. Insert_Actions (E, List_Def, Suppress => All_Checks); return Equiv_Type; @@ -4247,11 +4249,11 @@ package body Exp_Util is if Expander_Active and then Tagged_Type_Expansion then - -- If this is the class_wide type of a completion that is - -- a record subtype, set the type of the class_wide type - -- to be the full base type, for use in the expanded code - -- for the equivalent type. Should this be done earlier when - -- the completion is analyzed ??? + -- If this is the class_wide type of a completion that is a + -- record subtype, set the type of the class_wide type to be + -- the full base type, for use in the expanded code for the + -- equivalent type. Should this be done earlier when the + -- completion is analyzed ??? if Is_Private_Type (Etype (Unc_Typ)) and then @@ -4296,10 +4298,10 @@ package body Exp_Util is -- May_Generate_Large_Temp -- ----------------------------- - -- At the current time, the only types that we return False for (i.e. - -- where we decide we know they cannot generate large temps) are ones - -- where we know the size is 256 bits or less at compile time, and we - -- are still not doing a thorough job on arrays and records ??? + -- At the current time, the only types that we return False for (i.e. where + -- we decide we know they cannot generate large temps) are ones where we + -- know the size is 256 bits or less at compile time, and we are still not + -- doing a thorough job on arrays and records ??? function May_Generate_Large_Temp (Typ : Entity_Id) return Boolean is begin @@ -4331,21 +4333,21 @@ package body Exp_Util is is begin - -- If we have no initialization of any kind, then we don't need to - -- place any restrictions on the address clause, because the object - -- will be elaborated after the address clause is evaluated. This - -- happens if the declaration has no initial expression, or the type - -- has no implicit initialization, or the object is imported. + -- If we have no initialization of any kind, then we don't need to place + -- any restrictions on the address clause, because the object will be + -- elaborated after the address clause is evaluated. This happens if the + -- declaration has no initial expression, or the type has no implicit + -- initialization, or the object is imported. - -- The same holds for all initialized scalar types and all access - -- types. Packed bit arrays of size up to 64 are represented using a - -- modular type with an initialization (to zero) and can be processed - -- like other initialized scalar types. + -- The same holds for all initialized scalar types and all access types. + -- Packed bit arrays of size up to 64 are represented using a modular + -- type with an initialization (to zero) and can be processed like other + -- initialized scalar types. -- If the type is controlled, code to attach the object to a - -- finalization chain is generated at the point of declaration, - -- and therefore the elaboration of the object cannot be delayed: - -- the address expression must be a constant. + -- finalization chain is generated at the point of declaration, and + -- therefore the elaboration of the object cannot be delayed: the + -- address expression must be a constant. if No (Expression (Decl)) and then not Needs_Finalization (Typ) @@ -4369,8 +4371,8 @@ package body Exp_Util is -- the call to the initialization procedure (or the attach code) has -- to happen at the point of the declaration. - -- Actually the IP call has been moved to the freeze actions - -- anyway, so maybe we can relax this restriction??? + -- Actually the IP call has been moved to the freeze actions anyway, + -- so maybe we can relax this restriction??? return True; end if; @@ -4653,6 +4655,7 @@ package body Exp_Util is -- The following test is the simplest way of solving a complex -- problem uncovered by BB08-010: Side effect on loop bound that -- is a subcomponent of a global variable: + -- If a loop bound is a subcomponent of a global variable, a -- modification of that variable within the loop may incorrectly -- affect the execution of the loop. @@ -4689,12 +4692,12 @@ package body Exp_Util is if Is_Entity_Name (N) then - -- If the entity is a constant, it is definitely side effect - -- free. Note that the test of Is_Variable (N) below might - -- be expected to catch this case, but it does not, because - -- this test goes to the original tree, and we may have - -- already rewritten a variable node with a constant as - -- a result of an earlier Force_Evaluation call. + -- If the entity is a constant, it is definitely side effect free. + -- Note that the test of Is_Variable (N) below might be expected + -- to catch this case, but it does not, because this test goes to + -- the original tree, and we may have already rewritten a variable + -- node with a constant as a result of an earlier Force_Evaluation + -- call. if Ekind_In (Entity (N), E_Constant, E_In_Parameter) then return True; @@ -4709,7 +4712,12 @@ package body Exp_Util is -- If Name_Req is True then we can't help returning a name which -- effectively allows multiple references in any case. - elsif Is_Variable (N) then + -- Need comment for Is_True_Constant test below ??? + + elsif Is_Variable (N) + or else (Ekind (Entity (N)) = E_Variable + and then not Is_True_Constant (Entity (N))) + then return not Variable_Ref and then (not Is_Volatile_Reference (N) or else Name_Req); @@ -4725,16 +4733,16 @@ package body Exp_Util is elsif Compile_Time_Known_Value (N) then return True; - -- A variable renaming is not side-effect free, because the - -- renaming will function like a macro in the front-end in - -- some cases, and an assignment can modify the component - -- designated by N, so we need to create a temporary for it. + -- A variable renaming is not side-effect free, because the renaming + -- will function like a macro in the front-end in 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 + -- The guard testing for Entity being present is needed at least in + -- the case of rewritten predicate expressions, and may well also 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. + -- 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))) @@ -4746,7 +4754,7 @@ package body Exp_Util is -- Remove_Side_Effects generates an object renaming declaration to -- capture the expression of a class-wide expression. In VM targets -- the frontend performs no expansion for dispatching calls to - -- class-wide types since they are handled by the VM. Hence, we must + -- class- wide types since they are handled by the VM. Hence, we must -- locate here if this node corresponds to a previous invocation of -- Remove_Side_Effects to avoid a never ending loop in the frontend. @@ -4775,9 +4783,9 @@ package body Exp_Util is and then (Is_Entity_Name (Prefix (N)) or else Side_Effect_Free (Prefix (N))); - -- A binary operator is side effect free if and both operands - -- are side effect free. For this purpose binary operators - -- include membership tests and short circuit forms + -- A binary operator is side effect free if and both operands are + -- side effect free. For this purpose binary operators include + -- membership tests and short circuit forms when N_Binary_Op | N_Membership_Test | N_Short_Circuit => return Side_Effect_Free (Left_Opnd (N)) @@ -4792,10 +4800,10 @@ package body Exp_Util is -- A call to _rep_to_pos is side effect free, since we generate -- this pure function call ourselves. Moreover it is critically - -- important to make this exception, since otherwise we can - -- have discriminants in array components which don't look - -- side effect free in the case of an array whose index type - -- is an enumeration type with an enumeration rep clause. + -- important to make this exception, since otherwise we can have + -- discriminants in array components which don't look side effect + -- free in the case of an array whose index type is an enumeration + -- type with an enumeration rep clause. -- All other function calls are not side effect free @@ -4819,15 +4827,15 @@ package body Exp_Util is when N_Qualified_Expression => return Side_Effect_Free (Expression (N)); - -- A selected component is side effect free only if it is a - -- side effect free prefixed reference. If it designates a - -- component with a rep. clause it must be treated has having - -- a potential side effect, because it may be modified through - -- a renaming, and a subsequent use of the renaming as a macro - -- will yield the wrong value. This complex interaction between - -- renaming and removing side effects is a reminder that the - -- latter has become a headache to maintain, and that it should - -- be removed in favor of the gcc mechanism to capture values ??? + -- A selected component is side effect free only if it is a side + -- effect free prefixed reference. If it designates a component + -- with a rep. clause it must be treated has having a potential + -- side effect, because it may be modified through a renaming, and + -- a subsequent use of the renaming as a macro will yield the + -- wrong value. This complex interaction between renaming and + -- removing side effects is a reminder that the latter has become + -- a headache to maintain, and that it should be removed in favor + -- of the gcc mechanism to capture values ??? when N_Selected_Component => if Nkind (Parent (N)) = N_Explicit_Dereference @@ -4894,8 +4902,8 @@ package body Exp_Util is end case; end Side_Effect_Free; - -- A list is side effect free if all elements of the list are - -- side effect free. + -- A list is side effect free if all elements of the list are side + -- effect free. function Side_Effect_Free (L : List_Id) return Boolean is N : Node_Id; @@ -4985,10 +4993,10 @@ package body Exp_Util is Set_Etype (Def_Id, Exp_Type); Res := New_Reference_To (Def_Id, Loc); - -- If the expression is a packed reference, it must be reanalyzed - -- and expanded, depending on context. This is the case for actuals - -- where a constraint check may capture the actual before expansion - -- of the call is complete. + -- If the expression is a packed reference, it must be reanalyzed and + -- expanded, depending on context. This is the case for actuals where + -- a constraint check may capture the actual before expansion of the + -- call is complete. if Nkind (Exp) = N_Indexed_Component and then Is_Packed (Etype (Prefix (Exp))) @@ -5007,8 +5015,8 @@ package body Exp_Util is Set_Assignment_OK (E); Insert_Action (Exp, E); - -- If the expression has the form v.all then we can just capture - -- the pointer, and then do an explicit dereference on the result. + -- If the expression has the form v.all then we can just capture the + -- pointer, and then do an explicit dereference on the result. elsif Nkind (Exp) = N_Explicit_Dereference then Def_Id := Make_Temporary (Loc, 'R', Exp); @@ -5023,8 +5031,8 @@ package body Exp_Util is Constant_Present => True, Expression => Relocate_Node (Prefix (Exp)))); - -- Similar processing for an unchecked conversion of an expression - -- of the form v.all, where we want the same kind of treatment. + -- Similar processing for an unchecked conversion of an expression of + -- the form v.all, where we want the same kind of treatment. elsif Nkind (Exp) = N_Unchecked_Type_Conversion and then Nkind (Expression (Exp)) = N_Explicit_Dereference @@ -5035,8 +5043,8 @@ package body Exp_Util is -- If this is a type conversion, leave the type conversion and remove -- the side effects in the expression. This is important in several - -- circumstances: for change of representations, and also when this is - -- a view conversion to a smaller object, where gigi can end up creating + -- circumstances: for change of representations, and also when this is a + -- view conversion to a smaller object, where gigi can end up creating -- its own temporary of the wrong size. elsif Nkind (Exp) = N_Type_Conversion then @@ -5081,13 +5089,12 @@ package body Exp_Util is end if; -- For expressions that denote objects, we can use a renaming scheme. - -- This is needed for correctness in the case of a volatile object - -- of a non-volatile type because the Make_Reference call of the - -- "default" approach would generate an illegal access value (an access - -- value cannot designate such an object - see Analyze_Reference). - -- We skip using this scheme if we have an object of a volatile type - -- and we do not have Name_Req set true (see comments above for - -- Side_Effect_Free). + -- This is needed for correctness in the case of a volatile object of a + -- non-volatile type because the Make_Reference call of the "default" + -- approach would generate an illegal access value (an access value + -- cannot designate such an object - see Analyze_Reference). We skip + -- using this scheme if we have an object of a volatile type and we do + -- not have Name_Req set true (see comments above for Side_Effect_Free). elsif Is_Object_Reference (Exp) and then Nkind (Exp) /= N_Function_Call @@ -5126,9 +5133,9 @@ package body Exp_Util is Name => Relocate_Node (Exp))); end if; - -- If this is a packed reference, or a selected component with a - -- non-standard representation, a reference to the temporary will - -- be replaced by a copy of the original expression (see + -- If this is a packed reference, or a selected component with + -- a non-standard representation, a reference to the temporary + -- will be replaced by a copy of the original expression (see -- Exp_Ch2.Expand_Renaming). Otherwise the temporary must be -- elaborated by gigi, and is of course not to be replaced in-line -- by the expression it renames, which would defeat the purpose of @@ -5209,10 +5216,10 @@ package body Exp_Util is -- The expansion of nested aggregates is delayed until the -- enclosing aggregate is expanded. As aggregates are often - -- qualified, the predicate applies to qualified expressions - -- as well, indicating that the enclosing aggregate has not - -- been expanded yet. At this point the aggregate is part of - -- a stand-alone declaration, and must be fully expanded. + -- qualified, the predicate applies to qualified expressions as + -- well, indicating that the enclosing aggregate has not been + -- expanded yet. At this point the aggregate is part of a + -- stand-alone declaration, and must be fully expanded. if Nkind (E) = N_Qualified_Expression then Set_Expansion_Delayed (Expression (E), False); @@ -5232,9 +5239,9 @@ package body Exp_Util is Expression => New_Exp)); end if; - -- Preserve the Assignment_OK flag in all copies, since at least - -- one copy may be used in a context where this flag must be set - -- (otherwise why would the flag be set in the first place). + -- Preserve the Assignment_OK flag in all copies, since at least one + -- copy may be used in a context where this flag must be set (otherwise + -- why would the flag be set in the first place). Set_Assignment_OK (Res, Assignment_OK (Exp)); @@ -5261,9 +5268,9 @@ package body Exp_Util is -- Safe_Unchecked_Type_Conversion -- ------------------------------------ - -- Note: this function knows quite a bit about the exact requirements - -- of Gigi with respect to unchecked type conversions, and its code - -- must be coordinated with any changes in Gigi in this area. + -- Note: this function knows quite a bit about the exact requirements of + -- Gigi with respect to unchecked type conversions, and its code must be + -- coordinated with any changes in Gigi in this area. -- The above requirements should be documented in Sinfo ??? @@ -5289,12 +5296,11 @@ package body Exp_Util is then return True; - -- If the expression is the prefix of an N_Selected_Component - -- we should also be OK because GCC knows to look inside the - -- conversion except if the type is discriminated. We assume - -- that we are OK anyway if the type is not set yet or if it is - -- controlled since we can't afford to introduce a temporary in - -- this case. + -- If the expression is the prefix of an N_Selected_Component we should + -- also be OK because GCC knows to look inside the conversion except if + -- the type is discriminated. We assume that we are OK anyway if the + -- type is not set yet or if it is controlled since we can't afford to + -- introduce a temporary in this case. elsif Nkind (Pexp) = N_Selected_Component and then Prefix (Pexp) = Exp @@ -5308,9 +5314,9 @@ package body Exp_Util is end if; end if; - -- Set the output type, this comes from Etype if it is set, otherwise - -- we take it from the subtype mark, which we assume was already - -- fully analyzed. + -- Set the output type, this comes from Etype if it is set, otherwise we + -- take it from the subtype mark, which we assume was already fully + -- analyzed. if Present (Etype (Exp)) then Otyp := Etype (Exp); @@ -5328,10 +5334,10 @@ package body Exp_Util is Oalign := No_Uint; Ialign := No_Uint; - -- Replace a concurrent type by its corresponding record type - -- and each type by its underlying type and do the tests on those. - -- The original type may be a private type whose completion is a - -- concurrent type, so find the underlying type first. + -- Replace a concurrent type by its corresponding record type and each + -- type by its underlying type and do the tests on those. The original + -- type may be a private type whose completion is a concurrent type, so + -- find the underlying type first. if Present (Underlying_Type (Otyp)) then Otyp := Underlying_Type (Otyp); @@ -5365,22 +5371,22 @@ package body Exp_Util is then return True; - -- If the expression has an access type (object or subprogram) we - -- assume that the conversion is safe, because the size of the target - -- is safe, even if it is a record (which might be treated as having - -- unknown size at this point). + -- If the expression has an access type (object or subprogram) we assume + -- that the conversion is safe, because the size of the target is safe, + -- even if it is a record (which might be treated as having unknown size + -- at this point). elsif Is_Access_Type (Ityp) then return True; - -- If the size of output type is known at compile time, there is - -- never a problem. Note that unconstrained records are considered - -- to be of known size, but we can't consider them that way here, - -- because we are talking about the actual size of the object. + -- If the size of output type is known at compile time, there is never + -- a problem. Note that unconstrained records are considered to be of + -- known size, but we can't consider them that way here, because we are + -- talking about the actual size of the object. - -- We also make sure that in addition to the size being known, we do - -- not have a case which might generate an embarrassingly large temp - -- in stack checking mode. + -- We also make sure that in addition to the size being known, we do not + -- have a case which might generate an embarrassingly large temp in + -- stack checking mode. elsif Size_Known_At_Compile_Time (Otyp) and then @@ -5396,8 +5402,8 @@ package body Exp_Util is elsif Is_Tagged_Type (Otyp) or else Is_Tagged_Type (Ityp) then return True; - -- If either type is a limited record type, we cannot do a copy, so - -- say safe since there's nothing else we can do. + -- If either type is a limited record type, we cannot do a copy, so say + -- safe since there's nothing else we can do. elsif Is_Limited_Record (Otyp) or else Is_Limited_Record (Ityp) then return True; @@ -5414,9 +5420,8 @@ package body Exp_Util is -- The only other cases known to be safe is if the input type's -- alignment is known to be at least the maximum alignment for the -- target or if both alignments are known and the output type's - -- alignment is no stricter than the input's. We can use the alignment - -- of the component type of an array if a type is an unpacked - -- array type. + -- alignment is no stricter than the input's. We can use the component + -- type alignement for an array if a type is an unpacked array type. if Present (Alignment_Clause (Otyp)) then Oalign := Expr_Value (Expression (Alignment_Clause (Otyp))); @@ -5491,17 +5496,17 @@ package body Exp_Util is return; end if; - -- Here we have a case where the Current_Value field may - -- need to be set. We set it if it is not already set to a - -- compile time expression value. + -- Here we have a case where the Current_Value field may need + -- to be set. We set it if it is not already set to a compile + -- time expression value. -- Note that this represents a decision that one condition - -- blots out another previous one. That's certainly right - -- if they occur at the same level. If the second one is - -- nested, then the decision is neither right nor wrong (it - -- would be equally OK to leave the outer one in place, or - -- take the new inner one. Really we should record both, but - -- our data structures are not that elaborate. + -- blots out another previous one. That's certainly right if + -- they occur at the same level. If the second one is nested, + -- then the decision is neither right nor wrong (it would be + -- equally OK to leave the outer one in place, or take the new + -- inner one. Really we should record both, but our data + -- structures are not that elaborate. if Nkind (Current_Value (Ent)) not in N_Subexpr then Set_Current_Value (Ent, Cnode); @@ -5642,9 +5647,9 @@ package body Exp_Util is -- False op False = False, and True op True = True. For the XOR case, -- see Silly_Boolean_Array_Xor_Test. - -- Believe it or not, this was reported as a bug. Note that nearly - -- always, the test will evaluate statically to False, so the code will - -- be statically removed, and no extra overhead caused. + -- Believe it or not, this was reported as a bug. Note that nearly always, + -- the test will evaluate statically to False, so the code will be + -- statically removed, and no extra overhead caused. procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -5740,12 +5745,12 @@ package body Exp_Util is -------------------------- Integer_Sized_Small : Ureal; - -- Set to 2.0 ** -(Integer'Size - 1) the first time that this - -- function is called (we don't want to compute it more than once!) + -- Set to 2.0 ** -(Integer'Size - 1) the first time that this function is + -- called (we don't want to compute it more than once!) Long_Integer_Sized_Small : Ureal; - -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this - -- function is called (we don't want to compute it more than once) + -- Set to 2.0 ** -(Long_Integer'Size - 1) the first time that this function + -- is called (we don't want to compute it more than once) First_Time_For_THFO : Boolean := True; -- Set to False after first call (if Fractional_Fixed_Ops_On_Target) @@ -5758,8 +5763,8 @@ package body Exp_Util is function Is_Fractional_Type (Typ : Entity_Id) return Boolean; -- Return True if the given type is a fixed-point type with a small -- value equal to 2 ** (-(T'Object_Size - 1)) and whose values have - -- an absolute value less than 1.0. This is currently limited - -- to fixed-point types that map to Integer or Long_Integer. + -- an absolute value less than 1.0. This is currently limited to + -- fixed-point types that map to Integer or Long_Integer. ------------------------ -- Is_Fractional_Type -- @@ -5806,9 +5811,9 @@ package body Exp_Util is Rbase => 2); end if; - -- Return True if target supports fixed-by-fixed multiply/divide - -- for fractional fixed-point types (see Is_Fractional_Type) and - -- the operand and result types are equivalent fractional types. + -- Return True if target supports fixed-by-fixed multiply/divide for + -- fractional fixed-point types (see Is_Fractional_Type) and the operand + -- and result types are equivalent fractional types. return Is_Fractional_Type (Base_Type (Left_Typ)) and then Is_Fractional_Type (Base_Type (Right_Typ)) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index a767a25dbe5..35f27bafcdc 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1646,9 +1646,10 @@ package body Sem_Attr is -- Check special case of Exception_Id and Exception_Occurrence which -- are not allowed for restriction No_Exception_Registration. - if Is_RTE (P_Type, RE_Exception_Id) - or else - Is_RTE (P_Type, RE_Exception_Occurrence) + if Restriction_Check_Required (No_Exception_Registration) + and then (Is_RTE (P_Type, RE_Exception_Id) + or else + Is_RTE (P_Type, RE_Exception_Occurrence)) then Check_Restriction (No_Exception_Registration, P); end if; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index d17d9151560..627e993f4f8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3671,8 +3671,9 @@ package body Sem_Ch3 is -- Check for violation of No_Local_Timing_Events - if Is_RTE (Etype (Id), RE_Timing_Event) + if Restriction_Check_Required (No_Local_Timing_Events) and then not Is_Library_Level_Entity (Id) + and then Is_RTE (Etype (Id), RE_Timing_Event) then Check_Restriction (No_Local_Timing_Events, N); end if; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fda070c4633..c665c2d04c3 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -257,6 +257,13 @@ package body Sem_Ch5 is Analyze (Rhs); Analyze (Lhs); + -- Ensure that we never do an assignment on a variable marked as + -- as Safe_To_Reevaluate. + + pragma Assert (not Is_Entity_Name (Lhs) + or else Ekind (Entity (Lhs)) /= E_Variable + or else not Is_Safe_To_Reevaluate (Entity (Lhs))); + -- Start type analysis for assignment T1 := Etype (Lhs); @@ -1603,7 +1610,7 @@ package body Sem_Ch5 is Id := Make_Temporary (Loc, 'R', Original_Bound); -- Here we make a declaration with a separate assignment - -- statement, and insert before loop header. + -- statement, and insert before loop header. Decl := Make_Object_Declaration (Loc, @@ -1625,6 +1632,15 @@ package body Sem_Ch5 is Insert_Actions (Parent (N), New_List (Decl, Assign)); + -- Now that this temporary variable is initialized we decorate it + -- as safe-to-reevaluate to inform to the backend that no further + -- asignment will be issued and hence it can be handled as side + -- effect free. Note that this decoration must be done when the + -- assignment has been analyzed because otherwise it will be + -- rejected (see Analyze_Assignment). + + Set_Is_Safe_To_Reevaluate (Id); + Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc)); if Nkind (Assign) = N_Assignment_Statement then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 072baf48362..22234c807b5 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -5702,9 +5702,10 @@ package body Sem_Res is -- Check for violation of restriction No_Specific_Termination_Handlers -- and warn on a potentially blocking call to Abort_Task. - if Is_RTE (Nam, RE_Set_Specific_Handler) - or else - Is_RTE (Nam, RE_Specific_Handler) + if Restriction_Check_Required (No_Specific_Termination_Handlers) + and then (Is_RTE (Nam, RE_Set_Specific_Handler) + or else + Is_RTE (Nam, RE_Specific_Handler)) then Check_Restriction (No_Specific_Termination_Handlers, N); @@ -5717,7 +5718,8 @@ package body Sem_Res is -- need to check the second argument to determine whether it is an -- absolute or relative timing event. - if Is_RTE (Nam, RE_Set_Handler) + if Restriction_Check_Required (No_Relative_Delay) + and then Is_RTE (Nam, RE_Set_Handler) and then Is_RTE (Etype (Next_Actual (First_Actual (N))), RE_Time_Span) then Check_Restriction (No_Relative_Delay, N); diff --git a/gcc/ada/style.adb b/gcc/ada/style.adb index 0f0ab300cba..727a0cdf452 100644 --- a/gcc/ada/style.adb +++ b/gcc/ada/style.adb @@ -236,18 +236,14 @@ package body Style is procedure Missing_Overriding (N : Node_Id; E : Entity_Id) is begin - -- Note that Error_Msg_NE, which would be more natural to use here, - -- is not visible from this generic unit ??? - - Error_Msg_Name_1 := Chars (E); - if Style_Check_Missing_Overriding and then Comes_From_Source (N) then if Nkind (N) = N_Subprogram_Body then - Error_Msg_N -- CODEFIX - ("(style) missing OVERRIDING indicator in body of%", N); + Error_Msg_NE -- CODEFIX + ("(style) missing OVERRIDING indicator in body of&", N, E); else - Error_Msg_N -- CODEFIX - ("(style) missing OVERRIDING indicator in declaration of%", N); + Error_Msg_NE -- CODEFIX + ("(style) missing OVERRIDING indicator in declaration of&", + N, E); end if; end if; end Missing_Overriding; diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads index f7d45b6d60c..401373474ad 100644 --- a/gcc/ada/stylesw.ads +++ b/gcc/ada/stylesw.ads @@ -174,8 +174,8 @@ package Stylesw is Style_Check_Missing_Overriding : Boolean := False; -- This can be set True by using the -gnatyO switch. If it is True, then - -- "[not] overriding" is required in subprogram declarations and bodies - -- where appropriate. + -- "overriding" is required in subprogram declarations and bodies where + -- appropriate. Note that "not overriding" is never required. Style_Check_Mode_In : Boolean := False; -- This can be set True by using -gnatyI. If True, it activates checking -- 2.30.2