OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2011-08-02  Jerome Guitton  <guitton@adacore.com>

	* a-except-2005.adb (Raise_From_Signal_Handler): Call
	Debug_Raise_Exception before propagation starts.

2011-08-02  Eric Botcazou  <ebotcazou@adacore.com>

	* 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  <duff@adacore.com>

	* 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  <miranda@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2011-08-02 12:31:12 +02:00
parent 6320f5e18e
commit 273adcdf9f
13 changed files with 330 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/ada/ChangeLog
View File

@ -1,3 +1,34 @@
2011-08-02 Jerome Guitton <guitton@adacore.com>
* a-except-2005.adb (Raise_From_Signal_Handler): Call
Debug_Raise_Exception before propagation starts.
2011-08-02 Eric Botcazou <ebotcazou@adacore.com>
* 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 <duff@adacore.com>
* 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 <miranda@adacore.com>
* 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 <dewar@adacore.com>
* sem_ch5.adb, sem_ch7.adb, einfo.ads, sem_util.adb, sem_util.ads,

1
gcc/ada/a-except-2005.adb
View File

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

14
gcc/ada/einfo.adb
View File

@ -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));

13
gcc/ada/einfo.ads
View File

@ -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);

3
gcc/ada/errout.ads
View File

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

7
gcc/ada/exp_ch6.adb
View File

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

457
gcc/ada/exp_util.adb
View File

@ -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.
-- 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.
-- 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))

7
gcc/ada/sem_attr.adb
View File

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

3
gcc/ada/sem_ch3.adb
View File

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

18
gcc/ada/sem_ch5.adb
View File

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

10
gcc/ada/sem_res.adb
View File

@ -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);

14
gcc/ada/style.adb
View File

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

4
gcc/ada/stylesw.ads
View File

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