Commit 273adcdf by Arnaud Charlet

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