[Ada] Avoid bad optimization of a*(2**b) for non-binary modular type (PR 30470)
Arnaud Charlet
charlet@adacore.com
Tue May 20 13:23:00 GMT 2008
Tested on i686-linux, committed on trunk
PR ada/30740
The expression a*(2**b) can be transformed to a shift, but this is not
valid for the case of modular types with a non-binary modulus, since
the shift my lose bits which are not properly reduced in the modular
operation following the shift.
See gnat.dg/modular1.adb
2008-05-20 Robert Dewar <dewar@adacore.com>
PR ada/30740
* einfo.ads, einfo.adb (Non_Binary_Modulus): Applies to all types and
subtypes, always False for non-modular types.
Shared_Var_Assign_Proc (node22) and Shared_Var_Read_Proc (node 15)
entry nodes have been replaced by Shared_Var_Procs_Instance (node22)
for Shared_Storage package.
(Is_RACW_Stub_Type): New entity flag.
* exp_ch4.adb
(Expand_N_Op_Expon): Avoid incorrect optimization of a*(2**b) in the
case where we have a modular type with a non-binary modules.
Comments reformattings.
* sem_intr.adb: Simplify code not that Non_Binary_Modulus applies to
all types.
-------------- next part --------------
Index: einfo.ads
===================================================================
--- einfo.ads (revision 134945)
+++ einfo.ads (working copy)
@@ -2581,6 +2581,10 @@ package Einfo is
-- subtype appears in a pure unit. Used to give an error message at
-- freeze time if the access type has a storage pool.
+-- Is_RACW_Stub_Type (Flag244)
+-- Present in all types, true for the stub types generated for remote
+-- access-to-class-wide types.
+
-- Is_Raised (Flag224)
-- Present in exception entities. Set if the entity is referenced by a
-- a raise statement.
@@ -2595,12 +2599,12 @@ package Einfo is
-- Is_Remote_Call_Interface (Flag62)
-- Present in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Call_Interace is applied, and
--- also in all entities within such packages.
+-- also on entities declared in the visible part of such a package.
-- Is_Remote_Types (Flag61)
-- Present in all entities. Set in E_Package and E_Generic_Package
--- entities to which a pragma Remote_Types is applied, and also in
--- all entities within such packages.
+-- entities to which a pragma Remote_Types is applied, and also on
+-- entities declared in the visible part of the spec of such a package.
-- Is_Renaming_Of_Object (Flag112)
-- Present in all entities, set only for a variable or constant for
@@ -3044,8 +3048,8 @@ package Einfo is
-- of a record, returns the next _Tag field in this record.
-- Non_Binary_Modulus (Flag58) [base type only]
--- Present in modular integer types. Set if the modulus for the type
--- is other than a power of 2.
+-- Present in all subtype and type entities. Set for modular integer
+-- types if the modulus value is other than a power of 2.
-- Non_Limited_View (Node17)
-- Present in incomplete types that are the shadow entities created
@@ -3479,15 +3483,10 @@ package Einfo is
-- standard format list (i.e. First (Shadow_Entities) is the first
-- entry and subsequent entries are obtained using Next.
--- Shared_Var_Assign_Proc (Node22)
--- Present in variables. Set non-Empty only if Is_Shared_Passive is
--- set, in which case this is the entity for the shared memory assign
--- routine. See Exp_Smem for full details.
-
--- Shared_Var_Read_Proc (Node15)
+-- Shared_Var_Procs_Instance (Node22)
-- Present in variables. Set non-Empty only if Is_Shared_Passive is
--- set, in which case this is the entity for the shared memory read
--- routine. See Exp_Smem for full details.
+-- set, in which case this is the entity for the associated instance of
+-- System.Shared_Storage.Shared_Var_Procs. See Exp_Smem for full details.
-- Size_Check_Code (Node19)
-- Present in constants and variables. Normally Empty. Set if code is
@@ -4698,6 +4697,7 @@ package Einfo is
-- Is_Generic_Actual_Type (Flag94)
-- Is_Generic_Type (Flag13)
-- Is_Protected_Interface (Flag198)
+ -- Is_RACW_Stub_Type (Flag244)
-- Is_Synchronized_Interface (Flag199)
-- Is_Task_Interface (Flag200)
-- Is_Non_Static_Subtype (Flag109)
@@ -5490,14 +5490,13 @@ package Einfo is
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
- -- Shared_Var_Read_Proc (Node15)
-- Unset_Reference (Node16)
-- Actual_Subtype (Node17)
-- Renamed_Object (Node18)
-- Size_Check_Code (Node19)
-- Prival_Link (Node20)
-- Interface_Name (Node21)
- -- Shared_Var_Assign_Proc (Node22)
+ -- Shared_Var_Procs_Instance (Node22)
-- Extra_Constrained (Node23)
-- Debug_Renaming_Link (Node25)
-- Last_Assignment (Node26)
@@ -5990,6 +5989,7 @@ package Einfo is
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
+ function Is_RACW_Stub_Type (Id : E) return B;
function Is_Raised (Id : E) return B;
function Is_Remote_Call_Interface (Id : E) return B;
function Is_Remote_Types (Id : E) return B;
@@ -6085,8 +6085,7 @@ package Einfo is
function Scope_Depth_Value (Id : E) return U;
function Sec_Stack_Needed_For_Return (Id : E) return B;
function Shadow_Entities (Id : E) return S;
- function Shared_Var_Assign_Proc (Id : E) return E;
- function Shared_Var_Read_Proc (Id : E) return E;
+ function Shared_Var_Procs_Instance (Id : E) return E;
function Size_Check_Code (Id : E) return N;
function Size_Known_At_Compile_Time (Id : E) return B;
function Size_Depends_On_Discriminant (Id : E) return B;
@@ -6555,6 +6554,7 @@ package Einfo is
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
+ procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True);
procedure Set_Is_Raised (Id : E; V : B := True);
procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True);
procedure Set_Is_Remote_Types (Id : E; V : B := True);
@@ -6650,8 +6650,7 @@ package Einfo is
procedure Set_Scope_Depth_Value (Id : E; V : U);
procedure Set_Sec_Stack_Needed_For_Return (Id : E; V : B := True);
procedure Set_Shadow_Entities (Id : E; V : S);
- procedure Set_Shared_Var_Assign_Proc (Id : E; V : E);
- procedure Set_Shared_Var_Read_Proc (Id : E; V : E);
+ procedure Set_Shared_Var_Procs_Instance (Id : E; V : E);
procedure Set_Size_Check_Code (Id : E; V : N);
procedure Set_Size_Depends_On_Discriminant (Id : E; V : B := True);
procedure Set_Size_Known_At_Compile_Time (Id : E; V : B := True);
@@ -7236,6 +7235,7 @@ package Einfo is
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
pragma Inline (Is_Pure_Unit_Access_Type);
+ pragma Inline (Is_RACW_Stub_Type);
pragma Inline (Is_Raised);
pragma Inline (Is_Real_Type);
pragma Inline (Is_Record_Type);
@@ -7340,8 +7340,7 @@ package Einfo is
pragma Inline (Scope_Depth_Value);
pragma Inline (Sec_Stack_Needed_For_Return);
pragma Inline (Shadow_Entities);
- pragma Inline (Shared_Var_Assign_Proc);
- pragma Inline (Shared_Var_Read_Proc);
+ pragma Inline (Shared_Var_Procs_Instance);
pragma Inline (Size_Check_Code);
pragma Inline (Size_Depends_On_Discriminant);
pragma Inline (Size_Known_At_Compile_Time);
@@ -7628,6 +7627,7 @@ package Einfo is
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
+ pragma Inline (Set_Is_RACW_Stub_Type);
pragma Inline (Set_Is_Raised);
pragma Inline (Set_Is_Remote_Call_Interface);
pragma Inline (Set_Is_Remote_Types);
@@ -7722,8 +7722,7 @@ package Einfo is
pragma Inline (Set_Scope_Depth_Value);
pragma Inline (Set_Sec_Stack_Needed_For_Return);
pragma Inline (Set_Shadow_Entities);
- pragma Inline (Set_Shared_Var_Assign_Proc);
- pragma Inline (Set_Shared_Var_Read_Proc);
+ pragma Inline (Set_Shared_Var_Procs_Instance);
pragma Inline (Set_Size_Check_Code);
pragma Inline (Set_Size_Depends_On_Discriminant);
pragma Inline (Set_Size_Known_At_Compile_Time);
Index: einfo.adb
===================================================================
--- einfo.adb (revision 134945)
+++ einfo.adb (working copy)
@@ -126,7 +126,6 @@ package body Einfo is
-- Scale_Value Uint15
-- Storage_Size_Variable Node15
-- String_Literal_Low_Bound Node15
- -- Shared_Var_Read_Proc Node15
-- Access_Disp_Table Elist16
-- Cloned_Subtype Node16
@@ -193,7 +192,7 @@ package body Einfo is
-- Private_View Node22
-- Protected_Formal Node22
-- Scope_Depth_Value Uint22
- -- Shared_Var_Assign_Proc Node22
+ -- Shared_Var_Procs_Instance Node22
-- Associated_Final_Chain Node23
-- CR_Discriminant Node23
@@ -505,8 +504,8 @@ package body Einfo is
-- Optimize_Alignment_Space Flag241
-- Optimize_Alignment_Time Flag242
-- Overlays_Constant Flag243
+ -- Is_RACW_Stub_Type Flag244
- -- (unused) Flag244
-- (unused) Flag245
-- (unused) Flag246
-- (unused) Flag247
@@ -1975,6 +1974,12 @@ package body Einfo is
return Flag189 (Id);
end Is_Pure_Unit_Access_Type;
+ function Is_RACW_Stub_Type (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag244 (Id);
+ end Is_RACW_Stub_Type;
+
function Is_Raised (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Exception);
@@ -2239,7 +2244,7 @@ package body Einfo is
function Non_Binary_Modulus (Id : E) return B is
begin
- pragma Assert (Is_Modular_Integer_Type (Id));
+ pragma Assert (Is_Type (Id));
return Flag58 (Base_Type (Id));
end Non_Binary_Modulus;
@@ -2537,17 +2542,11 @@ package body Einfo is
return List14 (Id);
end Shadow_Entities;
- function Shared_Var_Assign_Proc (Id : E) return E is
+ function Shared_Var_Procs_Instance (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Variable);
return Node22 (Id);
- end Shared_Var_Assign_Proc;
-
- function Shared_Var_Read_Proc (Id : E) return E is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- return Node15 (Id);
- end Shared_Var_Read_Proc;
+ end Shared_Var_Procs_Instance;
function Size_Check_Code (Id : E) return N is
begin
@@ -4424,6 +4423,12 @@ package body Einfo is
Set_Flag189 (Id, V);
end Set_Is_Pure_Unit_Access_Type;
+ procedure Set_Is_RACW_Stub_Type (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag244 (Id, V);
+ end Set_Is_RACW_Stub_Type;
+
procedure Set_Is_Raised (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Exception);
@@ -4697,7 +4702,7 @@ package body Einfo is
procedure Set_Non_Binary_Modulus (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Modular_Integer_Type);
+ pragma Assert (Is_Type (Id) and then Id = Base_Type (Id));
Set_Flag58 (Id, V);
end Set_Non_Binary_Modulus;
@@ -5000,17 +5005,11 @@ package body Einfo is
Set_List14 (Id, V);
end Set_Shadow_Entities;
- procedure Set_Shared_Var_Assign_Proc (Id : E; V : E) is
+ procedure Set_Shared_Var_Procs_Instance (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Variable);
Set_Node22 (Id, V);
- end Set_Shared_Var_Assign_Proc;
-
- procedure Set_Shared_Var_Read_Proc (Id : E; V : E) is
- begin
- pragma Assert (Ekind (Id) = E_Variable);
- Set_Node15 (Id, V);
- end Set_Shared_Var_Read_Proc;
+ end Set_Shared_Var_Procs_Instance;
procedure Set_Size_Check_Code (Id : E; V : N) is
begin
@@ -7621,6 +7620,7 @@ package body Einfo is
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
+ W ("Is_RACW_Stub_Type", Flag244 (Id));
W ("Is_Raised", Flag224 (Id));
W ("Is_Remote_Call_Interface", Flag62 (Id));
W ("Is_Remote_Types", Flag61 (Id));
@@ -8131,9 +8131,6 @@ package body Einfo is
when E_String_Literal_Subtype =>
Write_Str ("String_Literal_Low_Bound");
- when E_Variable =>
- Write_Str ("Shared_Var_Read_Proc");
-
when others =>
Write_Str ("Field15??");
end case;
@@ -8506,7 +8503,7 @@ package body Einfo is
Write_Str ("Private_View");
when E_Variable =>
- Write_Str ("Shared_Var_Assign_Proc");
+ Write_Str ("Shared_Var_Procs_Instance");
when others =>
Write_Str ("Field22??");
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb (revision 134945)
+++ exp_ch4.adb (working copy)
@@ -110,20 +110,19 @@ package body Exp_Ch4 is
Bodies : List_Id;
Typ : Entity_Id) return Node_Id;
-- Expand an array equality into a call to a function implementing this
- -- equality, and a call to it. Loc is the location for the generated
- -- nodes. Lhs and Rhs are the array expressions to be compared.
- -- Bodies is a list on which to attach bodies of local functions that
- -- are created in the process. It is the responsibility of the
- -- caller to insert those bodies at the right place. Nod provides
- -- the Sloc value for the generated code. Normally the types used
- -- for the generated equality routine are taken from Lhs and Rhs.
- -- However, in some situations of generated code, the Etype fields
- -- of Lhs and Rhs are not set yet. In such cases, Typ supplies the
- -- type to be used for the formal parameters.
+ -- equality, and a call to it. Loc is the location for the generated nodes.
+ -- Lhs and Rhs are the array expressions to be compared. Bodies is a list
+ -- on which to attach bodies of local functions that are created in the
+ -- process. It is the responsibility of the caller to insert those bodies
+ -- at the right place. Nod provides the Sloc value for the generated code.
+ -- Normally the types used for the generated equality routine are taken
+ -- from Lhs and Rhs. However, in some situations of generated code, the
+ -- Etype fields of Lhs and Rhs are not set yet. In such cases, Typ supplies
+ -- the type to be used for the formal parameters.
procedure Expand_Boolean_Operator (N : Node_Id);
- -- Common expansion processing for Boolean operators (And, Or, Xor)
- -- for the case of array type arguments.
+ -- Common expansion processing for Boolean operators (And, Or, Xor) for the
+ -- case of array type arguments.
function Expand_Composite_Equality
(Nod : Node_Id;
@@ -131,19 +130,19 @@ package body Exp_Ch4 is
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id) return Node_Id;
- -- Local recursive function used to expand equality for nested
- -- composite types. Used by Expand_Record/Array_Equality, Bodies
- -- is a list on which to attach bodies of local functions that are
- -- created in the process. This is the responsibility of the caller
- -- to insert those bodies at the right place. Nod provides the Sloc
- -- value for generated code. Lhs and Rhs are the left and right sides
- -- for the comparison, and Typ is the type of the arrays to compare.
+ -- Local recursive function used to expand equality for nested composite
+ -- types. Used by Expand_Record/Array_Equality, Bodies is a list on which
+ -- to attach bodies of local functions that are created in the process.
+ -- This is the responsibility of the caller to insert those bodies at the
+ -- right place. Nod provides the Sloc value for generated code. Lhs and Rhs
+ -- are the left and right sides for the comparison, and Typ is the type of
+ -- the arrays to compare.
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id);
- -- This routine handles expansion of concatenation operations, where
- -- N is the N_Op_Concat node being expanded and Operands is the list
- -- of operands (at least two are present). The caller has dealt with
- -- converting any singleton operands into singleton aggregates.
+ -- This routine handles expansion of concatenation operations, where N is
+ -- the N_Op_Concat node being expanded and Operands is the list of operands
+ -- (at least two are present). The caller has dealt with converting any
+ -- singleton operands into singleton aggregates.
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
-- Routine to expand concatenation of 2-5 operands (in the list Operands)
@@ -153,18 +152,18 @@ package body Exp_Ch4 is
-- already converted character operands to strings in this case).
procedure Fixup_Universal_Fixed_Operation (N : Node_Id);
- -- N is either an N_Op_Divide or N_Op_Multiply node whose result is
- -- universal fixed. We do not have such a type at runtime, so the
- -- purpose of this routine is to find the real type by looking up
- -- the tree. We also determine if the operation must be rounded.
+ -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal
+ -- fixed. We do not have such a type at runtime, so the purpose of this
+ -- routine is to find the real type by looking up the tree. We also
+ -- determine if the operation must be rounded.
function Get_Allocator_Final_List
(N : Node_Id;
T : Entity_Id;
PtrT : Entity_Id) return Entity_Id;
- -- If the designated type is controlled, build final_list expression
- -- for created object. If context is an access parameter, create a
- -- local access type to have a usable finalization list.
+ -- If the designated type is controlled, build final_list expression for
+ -- created object. If context is an access parameter, create a local access
+ -- type to have a usable finalization list.
function Has_Inferable_Discriminants (N : Node_Id) return Boolean;
-- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable
@@ -185,22 +184,22 @@ package body Exp_Ch4 is
function Make_Array_Comparison_Op
(Typ : Entity_Id;
Nod : Node_Id) return Node_Id;
- -- Comparisons between arrays are expanded in line. This function
- -- produces the body of the implementation of (a > b), where a and b
- -- are one-dimensional arrays of some discrete type. The original
- -- node is then expanded into the appropriate call to this function.
- -- Nod provides the Sloc value for the generated code.
+ -- Comparisons between arrays are expanded in line. This function produces
+ -- the body of the implementation of (a > b), where a and b are one-
+ -- dimensional arrays of some discrete type. The original node is then
+ -- expanded into the appropriate call to this function. Nod provides the
+ -- Sloc value for the generated code.
function Make_Boolean_Array_Op
(Typ : Entity_Id;
N : Node_Id) return Node_Id;
- -- Boolean operations on boolean arrays are expanded in line. This
- -- function produce the body for the node N, which is (a and b),
- -- (a or b), or (a xor b). It is used only the normal case and not
- -- the packed case. The type involved, Typ, is the Boolean array type,
- -- and the logical operations in the body are simple boolean operations.
- -- Note that Typ is always a constrained type (the caller has ensured
- -- this by using Convert_To_Actual_Subtype if necessary).
+ -- Boolean operations on boolean arrays are expanded in line. This function
+ -- produce the body for the node N, which is (a and b), (a or b), or (a xor
+ -- b). It is used only the normal case and not the packed case. The type
+ -- involved, Typ, is the Boolean array type, and the logical operations in
+ -- the body are simple boolean operations. Note that Typ is always a
+ -- constrained type (the caller has ensured this by using
+ -- Convert_To_Actual_Subtype if necessary).
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
@@ -218,9 +217,8 @@ package body Exp_Ch4 is
(Lhs : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id) return Boolean;
- -- In the context of an assignment, where the right-hand side is a
- -- boolean operation on arrays, check whether operation can be performed
- -- in place.
+ -- In the context of an assignment, where the right-hand side is a boolean
+ -- operation on arrays, check whether operation can be performed in place.
procedure Unary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Unary_Op_Validity_Checks);
@@ -478,28 +476,30 @@ package body Exp_Ch4 is
(Ref : Node_Id;
Built_In_Place : Boolean := False);
-- Ada 2005 (AI-344): For an allocator with a class-wide designated
- -- type, generate an accessibility check to verify that the level of
- -- the type of the created object is not deeper than the level of the
- -- access type. If the type of the qualified expression is class-
- -- wide, then always generate the check (except in the case where it
- -- is known to be unnecessary, see comment below). Otherwise, only
- -- generate the check if the level of the qualified expression type
- -- is statically deeper than the access type. Although the static
- -- accessibility will generally have been performed as a legality
- -- check, it won't have been done in cases where the allocator
- -- appears in generic body, so a run-time check is needed in general.
- -- One special case is when the access type is declared in the same
- -- scope as the class-wide allocator, in which case the check can
- -- never fail, so it need not be generated. As an open issue, there
- -- seem to be cases where the static level associated with the
- -- class-wide object's underlying type is not sufficient to perform
- -- the proper accessibility check, such as for allocators in nested
- -- subprograms or accept statements initialized by class-wide formals
- -- when the actual originates outside at a deeper static level. The
- -- nested subprogram case might require passing accessibility levels
- -- along with class-wide parameters, and the task case seems to be
- -- an actual gap in the language rules that needs to be fixed by the
- -- ARG. ???
+ -- type, generate an accessibility check to verify that the level of the
+ -- type of the created object is not deeper than the level of the access
+ -- type. If the type of the qualified expression is class- wide, then
+ -- always generate the check (except in the case where it is known to be
+ -- unnecessary, see comment below). Otherwise, only generate the check
+ -- if the level of the qualified expression type is statically deeper
+ -- than the access type.
+ --
+ -- Although the static accessibility will generally have been performed
+ -- as a legality check, it won't have been done in cases where the
+ -- allocator appears in generic body, so a run-time check is needed in
+ -- general. One special case is when the access type is declared in the
+ -- same scope as the class-wide allocator, in which case the check can
+ -- never fail, so it need not be generated.
+ --
+ -- As an open issue, there seem to be cases where the static level
+ -- associated with the class-wide object's underlying type is not
+ -- sufficient to perform the proper accessibility check, such as for
+ -- allocators in nested subprograms or accept statements initialized by
+ -- class-wide formals when the actual originates outside at a deeper
+ -- static level. The nested subprogram case might require passing
+ -- accessibility levels along with class-wide parameters, and the task
+ -- case seems to be an actual gap in the language rules that needs to
+ -- be fixed by the ARG. ???
-------------------------------
-- Apply_Accessibility_Check --
@@ -577,12 +577,12 @@ package body Exp_Ch4 is
begin
if Is_Tagged_Type (T) or else Controlled_Type (T) then
- -- Ada 2005 (AI-318-02): If the initialization expression is a
- -- call to a build-in-place function, then access to the allocated
- -- object must be passed to the function. Currently we limit such
- -- functions to those with constrained limited result subtypes,
- -- but eventually we plan to expand the allowed forms of functions
- -- that are treated as build-in-place.
+ -- Ada 2005 (AI-318-02): If the initialization expression is a call
+ -- to a build-in-place function, then access to the allocated object
+ -- must be passed to the function. Currently we limit such functions
+ -- to those with constrained limited result subtypes, but eventually
+ -- we plan to expand the allowed forms of functions that are treated
+ -- as build-in-place.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Exp)
@@ -762,11 +762,10 @@ package body Exp_Ch4 is
-- Generate an additional object containing the address of the
-- returned object. The type of this second object declaration
- -- is the correct type required for the common processing
- -- that is still performed by this subprogram. The displacement
- -- of this pointer to reference the component associated with
- -- the interface type will be done at the end of the common
- -- processing.
+ -- is the correct type required for the common processing that
+ -- is still performed by this subprogram. The displacement of
+ -- this pointer to reference the component associated with the
+ -- interface type will be done at the end of common processing.
New_Decl :=
Make_Object_Declaration (Loc,
@@ -845,10 +844,10 @@ package body Exp_Ch4 is
Associated_Storage_Pool (PtrT);
begin
- -- If it is an allocation on the secondary stack
- -- (i.e. a value returned from a function), the object
- -- is attached on the caller side as soon as the call
- -- is completed (see Expand_Ctrl_Function_Call)
+ -- If it is an allocation on the secondary stack (i.e. a value
+ -- returned from a function), the object is attached on the
+ -- caller side as soon as the call is completed (see
+ -- Expand_Ctrl_Function_Call)
if Is_RTE (Apool, RE_SS_Pool) then
declare
@@ -899,10 +898,9 @@ package body Exp_Ch4 is
Make_Adjust_Call (
Ref =>
- -- An unchecked conversion is needed in the
- -- classwide case because the designated type
- -- can be an ancestor of the subtype mark of
- -- the allocator.
+ -- An unchecked conversion is needed in the classwide
+ -- case because the designated type can be an ancestor of
+ -- the subtype mark of the allocator.
Unchecked_Convert_To (T,
Make_Explicit_Dereference (Loc,
@@ -919,9 +917,9 @@ package body Exp_Ch4 is
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
- -- Ada 2005 (AI-251): Displace the pointer to reference the
- -- record component containing the secondary dispatch table
- -- of the interface type.
+ -- Ada 2005 (AI-251): Displace the pointer to reference the record
+ -- component containing the secondary dispatch table of the interface
+ -- type.
if Is_Interface (Directly_Designated_Type (PtrT)) then
Displace_Allocator_Pointer (N);
@@ -965,20 +963,18 @@ package body Exp_Ch4 is
else
-- First check against the type of the qualified expression
--
- -- NOTE: The commented call should be correct, but for
- -- some reason causes the compiler to bomb (sigsegv) on
- -- ACVC test c34007g, so for now we just perform the old
- -- (incorrect) test against the designated subtype with
- -- no sliding in the else part of the if statement below.
- -- ???
+ -- NOTE: The commented call should be correct, but for some reason
+ -- causes the compiler to bomb (sigsegv) on ACVC test c34007g, so for
+ -- now we just perform the old (incorrect) test against the
+ -- designated subtype with no sliding in the else part of the if
+ -- statement below. ???
--
-- Apply_Constraint_Check (Exp, T, No_Sliding => True);
- -- A check is also needed in cases where the designated
- -- subtype is constrained and differs from the subtype
- -- given in the qualified expression. Note that the check
- -- on the qualified expression does not allow sliding,
- -- but this check does (a relaxation from Ada 83).
+ -- A check is also needed in cases where the designated subtype is
+ -- constrained and differs from the subtype given in the qualified
+ -- expression. Note that the check on the qualified expression does
+ -- not allow sliding, but this check does (a relaxation from Ada 83).
if Is_Constrained (DesigT)
and then not Subtypes_Statically_Match
@@ -987,19 +983,18 @@ package body Exp_Ch4 is
Apply_Constraint_Check
(Exp, DesigT, No_Sliding => False);
- -- The nonsliding check should really be performed
- -- (unconditionally) against the subtype of the
- -- qualified expression, but that causes a problem
- -- with c34007g (see above), so for now we retain this.
+ -- The nonsliding check should really be performed (unconditionally)
+ -- against the subtype of the qualified expression, but that causes a
+ -- problem with c34007g (see above), so for now we retain this.
else
Apply_Constraint_Check
(Exp, DesigT, No_Sliding => True);
end if;
- -- For an access to unconstrained packed array, GIGI needs
- -- to see an expression with a constrained subtype in order
- -- to compute the proper size for the allocator.
+ -- For an access to unconstrained packed array, GIGI needs to see an
+ -- expression with a constrained subtype in order to compute the
+ -- proper size for the allocator.
if Is_Array_Type (T)
and then not Is_Constrained (T)
@@ -1021,12 +1016,12 @@ package body Exp_Ch4 is
end;
end if;
- -- Ada 2005 (AI-318-02): If the initialization expression is a
- -- call to a build-in-place function, then access to the allocated
- -- object must be passed to the function. Currently we limit such
- -- functions to those with constrained limited result subtypes,
- -- but eventually we plan to expand the allowed forms of functions
- -- that are treated as build-in-place.
+ -- Ada 2005 (AI-318-02): If the initialization expression is a call
+ -- to a build-in-place function, then access to the allocated object
+ -- must be passed to the function. Currently we limit such functions
+ -- to those with constrained limited result subtypes, but eventually
+ -- we plan to expand the allowed forms of functions that are treated
+ -- as build-in-place.
if Ada_Version >= Ada_05
and then Is_Build_In_Place_Function_Call (Exp)
@@ -1044,10 +1039,10 @@ package body Exp_Ch4 is
-- Expand_Array_Comparison --
-----------------------------
- -- Expansion is only required in the case of array types. For the
- -- unpacked case, an appropriate runtime routine is called. For
- -- packed cases, and also in some other cases where a runtime
- -- routine cannot be called, the form of the expansion is:
+ -- Expansion is only required in the case of array types. For the unpacked
+ -- case, an appropriate runtime routine is called. For packed cases, and
+ -- also in some other cases where a runtime routine cannot be called, the
+ -- form of the expansion is:
-- [body for greater_nn; boolean_expression]
@@ -1071,9 +1066,9 @@ package body Exp_Ch4 is
-- True for byte addressable target
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean;
- -- Returns True if the length of the given operand is known to be
- -- less than 4. Returns False if this length is known to be four
- -- or greater or is not known at compile time.
+ -- Returns True if the length of the given operand is known to be less
+ -- than 4. Returns False if this length is known to be four or greater
+ -- or is not known at compile time.
------------------------
-- Length_Less_Than_4 --
@@ -1272,8 +1267,8 @@ package body Exp_Ch4 is
-- Expand_Array_Equality --
---------------------------
- -- Expand an equality function for multi-dimensional arrays. Here is
- -- an example of such a function for Nb_Dimension = 2
+ -- Expand an equality function for multi-dimensional arrays. Here is an
+ -- example of such a function for Nb_Dimension = 2
-- function Enn (A : atyp; B : btyp) return boolean is
-- begin
@@ -1320,15 +1315,15 @@ package body Exp_Ch4 is
-- return true;
-- end Enn;
- -- Note on the formal types used (atyp and btyp). If either of the
- -- arrays is of a private type, we use the underlying type, and
- -- do an unchecked conversion of the actual. If either of the arrays
- -- has a bound depending on a discriminant, then we use the base type
- -- since otherwise we have an escaped discriminant in the function.
-
- -- If both arrays are constrained and have the same bounds, we can
- -- generate a loop with an explicit iteration scheme using a 'Range
- -- attribute over the first array.
+ -- Note on the formal types used (atyp and btyp). If either of the arrays
+ -- is of a private type, we use the underlying type, and do an unchecked
+ -- conversion of the actual. If either of the arrays has a bound depending
+ -- on a discriminant, then we use the base type since otherwise we have an
+ -- escaped discriminant in the function.
+
+ -- If both arrays are constrained and have the same bounds, we can generate
+ -- a loop with an explicit iteration scheme using a 'Range attribute over
+ -- the first array.
function Expand_Array_Equality
(Nod : Node_Id;
@@ -1361,12 +1356,12 @@ package body Exp_Ch4 is
-- This builds the attribute reference Arr'Nam (Expr)
function Component_Equality (Typ : Entity_Id) return Node_Id;
- -- Create one statement to compare corresponding components,
- -- designated by a full set of indices.
+ -- Create one statement to compare corresponding components, designated
+ -- by a full set of indices.
function Get_Arg_Type (N : Node_Id) return Entity_Id;
- -- Given one of the arguments, computes the appropriate type to
- -- be used for that argument in the corresponding function formal
+ -- Given one of the arguments, computes the appropriate type to be used
+ -- for that argument in the corresponding function formal
function Handle_One_Dimension
(N : Int;
@@ -1392,13 +1387,13 @@ package body Exp_Ch4 is
-- end loop
--
-- N is the dimension for which we are generating a loop. Index is the
- -- N'th index node, whose Etype is Index_Type_n in the above code.
- -- The xxx statement is either the loop or declare for the next
- -- dimension or if this is the last dimension the comparison
- -- of corresponding components of the arrays.
+ -- N'th index node, whose Etype is Index_Type_n in the above code. The
+ -- xxx statement is either the loop or declare for the next dimension
+ -- or if this is the last dimension the comparison of corresponding
+ -- components of the arrays.
--
- -- The actual way the code works is to return the comparison
- -- of corresponding components for the N+1 call. That's neater!
+ -- The actual way the code works is to return the comparison of
+ -- corresponding components for the N+1 call. That's neater!
function Test_Empty_Arrays return Node_Id;
-- This function constructs the test for both arrays being empty
@@ -1407,8 +1402,8 @@ package body Exp_Ch4 is
-- (B'length (1) = 0 or else B'length (2) = 0 or else ...)
function Test_Lengths_Correspond return Node_Id;
- -- This function constructs the test for arrays having different
- -- lengths in at least one index position, in which case resull
+ -- This function constructs the test for arrays having different lengths
+ -- in at least one index position, in which case the resulting code is:
-- A'length (1) /= B'length (1)
-- or else
@@ -1463,8 +1458,8 @@ package body Exp_Ch4 is
if Nkind (Test) = N_Raise_Program_Error then
-- This node is going to be inserted at a location where a
- -- statement is expected: clear its Etype so analysis will
- -- set it to the expected Standard_Void_Type.
+ -- statement is expected: clear its Etype so analysis will set
+ -- it to the expected Standard_Void_Type.
Set_Etype (Test, Empty);
return Test;
@@ -1525,8 +1520,8 @@ package body Exp_Ch4 is
Ltyp /= Rtyp
or else not Is_Constrained (Ltyp);
-- If the index types are identical, and we are working with
- -- constrained types, then we can use the same index for both of
- -- the arrays.
+ -- constrained types, then we can use the same index for both
+ -- of the arrays.
An : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
@@ -1714,9 +1709,9 @@ package body Exp_Ch4 is
Ltyp := Get_Arg_Type (Lhs);
Rtyp := Get_Arg_Type (Rhs);
- -- For now, if the argument types are not the same, go to the
- -- base type, since the code assumes that the formals have the
- -- same type. This is fixable in future ???
+ -- For now, if the argument types are not the same, go to the base type,
+ -- since the code assumes that the formals have the same type. This is
+ -- fixable in future ???
if Ltyp /= Rtyp then
Ltyp := Base_Type (Ltyp);
@@ -1775,9 +1770,9 @@ package body Exp_Ch4 is
Set_Has_Completion (Func_Name, True);
Set_Is_Inlined (Func_Name);
- -- If the array type is distinct from the type of the arguments,
- -- it is the full view of a private type. Apply an unchecked
- -- conversion to insure that analysis of the call succeeds.
+ -- If the array type is distinct from the type of the arguments, it
+ -- is the full view of a private type. Apply an unchecked conversion
+ -- to insure that analysis of the call succeeds.
declare
L, R : Node_Id;
@@ -1813,16 +1808,16 @@ package body Exp_Ch4 is
-- Expand_Boolean_Operator --
-----------------------------
- -- Note that we first get the actual subtypes of the operands,
- -- since we always want to deal with types that have bounds.
+ -- Note that we first get the actual subtypes of the operands, since we
+ -- always want to deal with types that have bounds.
procedure Expand_Boolean_Operator (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
- -- Special case of bit packed array where both operands are known
- -- to be properly aligned. In this case we use an efficient run time
- -- routine to carry out the operation (see System.Bit_Ops).
+ -- Special case of bit packed array where both operands are known to be
+ -- properly aligned. In this case we use an efficient run time routine
+ -- to carry out the operation (see System.Bit_Ops).
if Is_Bit_Packed_Array (Typ)
and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
@@ -1916,8 +1911,8 @@ package body Exp_Ch4 is
Full_Type := Typ;
end if;
- -- Defense against malformed private types with no completion
- -- the error will be diagnosed later by check_completion
+ -- Defense against malformed private types with no completion the error
+ -- will be diagnosed later by check_completion
if No (Full_Type) then
return New_Reference_To (Standard_False, Loc);
@@ -1937,11 +1932,11 @@ package body Exp_Ch4 is
then
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
- -- For composite component types, and floating-point types, use
- -- the expansion. This deals with tagged component types (where
- -- we use the applicable equality routine) and floating-point,
- -- (where we need to worry about negative zeroes), and also the
- -- case of any composite type recursively containing such fields.
+ -- For composite component types, and floating-point types, use the
+ -- expansion. This deals with tagged component types (where we use
+ -- the applicable equality routine) and floating-point, (where we
+ -- need to worry about negative zeroes), and also the case of any
+ -- composite type recursively containing such fields.
else
return Expand_Array_Equality (Nod, Lhs, Rhs, Bodies, Full_Type);
@@ -1955,11 +1950,10 @@ package body Exp_Ch4 is
Full_Type := Root_Type (Full_Type);
end if;
- -- If this is derived from an untagged private type completed
- -- with a tagged type, it does not have a full view, so we
- -- use the primitive operations of the private type.
- -- This check should no longer be necessary when these
- -- types receive their full views ???
+ -- If this is derived from an untagged private type completed with a
+ -- tagged type, it does not have a full view, so we use the primitive
+ -- operations of the private type. This check should no longer be
+ -- necessary when these types receive their full views ???
if Is_Private_Type (Typ)
and then not Is_Tagged_Type (Typ)
@@ -1998,8 +1992,8 @@ package body Exp_Ch4 is
if Present (Eq_Op) then
if Etype (First_Formal (Eq_Op)) /= Full_Type then
- -- Inherited equality from parent type. Convert the actuals
- -- to match signature of operation.
+ -- Inherited equality from parent type. Convert the actuals to
+ -- match signature of operation.
declare
T : constant Entity_Id := Etype (First_Formal (Eq_Op));
@@ -2040,7 +2034,7 @@ package body Exp_Ch4 is
if Is_Constrained (Lhs_Type) then
- -- Since the enclosing record can never be an
+ -- Since the enclosing record type can never be an
-- Unchecked_Union (this code is executed for records
-- that do not have variants), we may reference its
-- discriminant(s).
@@ -2121,8 +2115,8 @@ package body Exp_Ch4 is
end;
end if;
- -- Shouldn't this be an else, we can't fall through
- -- the above IF, right???
+ -- Shouldn't this be an else, we can't fall through the above
+ -- IF, right???
return
Make_Function_Call (Loc,
@@ -2145,10 +2139,10 @@ package body Exp_Ch4 is
-- Expand_Concatenate_Other --
------------------------------
- -- Let n be the number of array operands to be concatenated, Base_Typ
- -- their base type, Ind_Typ their index type, and Arr_Typ the original
- -- array type to which the concatenation operator applies, then the
- -- following subprogram is constructed:
+ -- Let n be the number of array operands to be concatenated, Base_Typ their
+ -- base type, Ind_Typ their index type, and Arr_Typ the original array type
+ -- to which the concatenation operator applies, then the following
+ -- subprogram is constructed:
-- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
-- L : Ind_Typ;
@@ -2425,9 +2419,9 @@ package body Exp_Ch4 is
Target_Type : Entity_Id;
begin
- -- If the index type is an enumeration type, the computation
- -- can be done in standard integer. Otherwise, choose a large
- -- enough integer type.
+ -- If the index type is an enumeration type, the computation can be
+ -- done in standard integer. Otherwise, choose a large enough integer
+ -- type to accomodate the index type computation.
if Is_Enumeration_Type (Ind_Typ)
or else Root_Type (Ind_Typ) = Standard_Integer
@@ -2937,12 +2931,12 @@ package body Exp_Ch4 is
-- typ! (coext.all)
if Nkind (Coext) = N_Identifier then
- Ref := Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark =>
- New_Reference_To (Etype (Coext), Loc),
- Expression =>
- Make_Explicit_Dereference (Loc,
- New_Copy_Tree (Coext)));
+ Ref :=
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Reference_To (Etype (Coext), Loc),
+ Expression =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Copy_Tree (Coext)));
else
Ref := New_Copy_Tree (Coext);
end if;
@@ -3056,9 +3050,9 @@ package body Exp_Ch4 is
end if;
end if;
- -- Under certain circumstances we can replace an allocator by an
- -- access to statically allocated storage. The conditions, as noted
- -- in AARM 3.10 (10c) are as follows:
+ -- Under certain circumstances we can replace an allocator by an access
+ -- to statically allocated storage. The conditions, as noted in AARM
+ -- 3.10 (10c) are as follows:
-- Size and initial value is known at compile time
-- Access type is access-to-constant
@@ -3083,8 +3077,8 @@ package body Exp_Ch4 is
-- Tnn : aliased x := y;
- -- and replace the allocator by Tnn'Unrestricted_Access.
- -- Tnn is marked as requiring static allocation.
+ -- and replace the allocator by Tnn'Unrestricted_Access. Tnn is
+ -- marked as requiring static allocation.
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
@@ -3114,8 +3108,8 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, PtrT);
- -- We set the variable as statically allocated, since we don't
- -- want it going on the stack of the current procedure!
+ -- We set the variable as statically allocated, since we don't want
+ -- it going on the stack of the current procedure!
Set_Is_Statically_Allocated (Temp);
return;
@@ -3147,9 +3141,8 @@ package body Exp_Ch4 is
-- If the allocator is for a type which requires initialization, and
-- there is no initial value (i.e. operand is a subtype indication
- -- rather than a qualified expression), then we must generate a call
- -- to the initialization routine. This is done using an expression
- -- actions node:
+ -- rather than a qualified expression), then we must generate a call to
+ -- the initialization routine using an expressions action node:
-- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
@@ -3364,10 +3357,10 @@ package body Exp_Ch4 is
if Dis then
-- If the allocated object will be constrained by the
- -- default values for discriminants, then build a
- -- subtype with those defaults, and change the allocated
- -- subtype to that. Note that this happens in fewer
- -- cases in Ada 2005 (AI-363).
+ -- default values for discriminants, then build a subtype
+ -- with those defaults, and change the allocated subtype
+ -- to that. Note that this happens in fewer cases in Ada
+ -- 2005 (AI-363).
if not Is_Constrained (Typ)
and then Present (Discriminant_Default_Value
@@ -3600,15 +3593,15 @@ package body Exp_Ch4 is
if Nkind (Right) = N_Identifier then
- -- Change (Left and then True) to Left. Note that we know there
- -- are no actions associated with the True operand, since we
- -- just checked for this case above.
+ -- Change (Left and then True) to Left. Note that we know there are
+ -- no actions associated with the True operand, since we just checked
+ -- for this case above.
if Entity (Right) = Standard_True then
Rewrite (N, Left);
- -- Change (Left and then False) to False, making sure to preserve
- -- any side effects associated with the Left operand.
+ -- Change (Left and then False) to False, making sure to preserve any
+ -- side effects associated with the Left operand.
elsif Entity (Right) = Standard_False then
Remove_Side_Effects (Left);
@@ -3851,8 +3844,8 @@ package body Exp_Ch4 is
return;
- -- If both checks are known to succeed, replace result
- -- by True, since we know we are in range.
+ -- If both checks are known to succeed, replace result by True,
+ -- since we know we are in range.
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
if Warn1 then
@@ -3989,9 +3982,9 @@ package body Exp_Ch4 is
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
- -- For the constrained array case, we have to check the
- -- subscripts for an exact match if the lengths are
- -- non-zero (the lengths must match in any case).
+ -- For the constrained array case, we have to check the subscripts
+ -- for an exact match if the lengths are non-zero (the lengths
+ -- must match in any case).
elsif Is_Array_Type (Typ) then
@@ -4059,13 +4052,13 @@ package body Exp_Ch4 is
Analyze_And_Resolve (N, Rtyp);
end Check_Subscripts;
- -- These are the cases where constraint checks may be
- -- required, e.g. records with possible discriminants
+ -- These are the cases where constraint checks may be required,
+ -- e.g. records with possible discriminants
else
-- Expand the test into a series of discriminant comparisons.
- -- The expression that is built is the negation of the one
- -- that is used for checking discriminant constraints.
+ -- The expression that is built is the negation of the one that
+ -- is used for checking discriminant constraints.
Obj := Relocate_Node (Left_Opnd (N));
@@ -4104,18 +4097,18 @@ package body Exp_Ch4 is
T : constant Entity_Id := Etype (P);
begin
- -- A special optimization, if we have an indexed component that
- -- is selecting from a slice, then we can eliminate the slice,
- -- since, for example, x (i .. j)(k) is identical to x(k). The
- -- only difference is the range check required by the slice. The
- -- range check for the slice itself has already been generated.
- -- The range check for the subscripting operation is ensured
- -- by converting the subject to the subtype of the slice.
-
- -- This optimization not only generates better code, avoiding
- -- slice messing especially in the packed case, but more importantly
- -- bypasses some problems in handling this peculiar case, for
- -- example, the issue of dealing specially with object renamings.
+ -- A special optimization, if we have an indexed component that is
+ -- selecting from a slice, then we can eliminate the slice, since, for
+ -- example, x (i .. j)(k) is identical to x(k). The only difference is
+ -- the range check required by the slice. The range check for the slice
+ -- itself has already been generated. The range check for the
+ -- subscripting operation is ensured by converting the subject to
+ -- the subtype of the slice.
+
+ -- This optimization not only generates better code, avoiding slice
+ -- messing especially in the packed case, but more importantly bypasses
+ -- some problems in handling this peculiar case, for example, the issue
+ -- of dealing specially with object renamings.
if Nkind (P) = N_Slice then
Rewrite (N,
@@ -4138,11 +4131,11 @@ package body Exp_Ch4 is
Make_Build_In_Place_Call_In_Anonymous_Context (P);
end if;
- -- If the prefix is an access type, then we unconditionally rewrite
- -- if as an explicit deference. This simplifies processing for several
- -- cases, including packed array cases and certain cases in which
- -- checks must be generated. We used to try to do this only when it
- -- was necessary, but it cleans up the code to do it all the time.
+ -- If the prefix is an access type, then we unconditionally rewrite if
+ -- as an explicit deference. This simplifies processing for several
+ -- cases, including packed array cases and certain cases in which checks
+ -- must be generated. We used to try to do this only when it was
+ -- necessary, but it cleans up the code to do it all the time.
if Is_Access_Type (T) then
Insert_Explicit_Dereference (P);
@@ -4176,8 +4169,8 @@ package body Exp_Ch4 is
-- convert it to a reference to the corresponding Packed_Array_Type.
-- We only want to do this for simple references, and not for:
- -- Left side of assignment, or prefix of left side of assignment,
- -- or prefix of the prefix, to handle packed arrays of packed arrays,
+ -- Left side of assignment, or prefix of left side of assignment, or
+ -- prefix of the prefix, to handle packed arrays of packed arrays,
-- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
-- Renaming objects in renaming associations
@@ -4222,8 +4215,8 @@ package body Exp_Ch4 is
then
return;
- -- If the expression is an index of an indexed component,
- -- it must be expanded regardless of context.
+ -- If the expression is an index of an indexed component, it must
+ -- be expanded regardless of context.
elsif Nkind (Parnt) = N_Indexed_Component
and then Child /= Prefix (Parnt)
@@ -4252,8 +4245,8 @@ package body Exp_Ch4 is
return;
end if;
- -- Keep looking up tree for unchecked expression, or if we are
- -- the prefix of a possible assignment left side.
+ -- Keep looking up tree for unchecked expression, or if we are the
+ -- prefix of a possible assignment left side.
Child := Parnt;
Parnt := Parent (Child);
@@ -4296,11 +4289,11 @@ package body Exp_Ch4 is
-- Expand_N_Null --
-------------------
- -- The only replacement required is for the case of a null of type
- -- that is an access to protected subprogram. We represent such
- -- access values as a record, and so we must replace the occurrence
- -- of null by the equivalent record (with a null address and a null
- -- pointer in it), so that the backend creates the proper value.
+ -- The only replacement required is for the case of a null of type that is
+ -- an access to protected subprogram. We represent such access values as a
+ -- record, and so we must replace the occurrence of null by the equivalent
+ -- record (with a null address and a null pointer in it), so that the
+ -- backend creates the proper value.
procedure Expand_N_Null (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
@@ -4318,9 +4311,9 @@ package body Exp_Ch4 is
Rewrite (N, Agg);
Analyze_And_Resolve (N, Equivalent_Type (Typ));
- -- For subsequent semantic analysis, the node must retain its
- -- type. Gigi in any case replaces this type by the corresponding
- -- record type before processing the node.
+ -- For subsequent semantic analysis, the node must retain its type.
+ -- Gigi in any case replaces this type by the corresponding record
+ -- type before processing the node.
Set_Etype (N, Typ);
end if;
@@ -4347,9 +4340,8 @@ package body Exp_Ch4 is
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
- -- The only case to worry about is when the argument is
- -- equal to the largest negative number, so what we do is
- -- to insert the check:
+ -- The only case to worry about is when the argument is equal to the
+ -- largest negative number, so what we do is to insert the check:
-- [constraint_error when Expr = typ'Base'First]
@@ -4465,8 +4457,8 @@ package body Exp_Ch4 is
-- Single operand for concatenation
Cnode : Node_Id;
- -- Node which is to be replaced by the result of concatenating
- -- the nodes in the list Opnds.
+ -- Node which is to be replaced by the result of concatenating the nodes
+ -- in the list Opnds.
Atyp : Entity_Id;
-- Array type of concatenation result type
@@ -4510,9 +4502,9 @@ package body Exp_Ch4 is
Binary_Op_Validity_Checks (N);
- -- If we are the left operand of a concatenation higher up the
- -- tree, then do nothing for now, since we want to deal with a
- -- series of concatenations as a unit.
+ -- If we are the left operand of a concatenation higher up the tree,
+ -- then do nothing for now, since we want to deal with a series of
+ -- concatenations as a unit.
if Nkind (Parent (N)) = N_Op_Concat
and then N = Left_Opnd (Parent (N))
@@ -4564,10 +4556,10 @@ package body Exp_Ch4 is
Append (Right_Opnd (Cnode), Opnds);
end loop Inner;
- -- Here we process the collected operands. First we convert
- -- singleton operands to singleton aggregates. This is skipped
- -- however for the case of two operands of type String, since
- -- we have special routines for these cases.
+ -- Here we process the collected operands. First we convert singleton
+ -- operands to singleton aggregates. This is skipped however for the
+ -- case of two operands of type String since we have special routines
+ -- for these cases.
Atyp := Base_Type (Etype (Cnode));
Ctyp := Base_Type (Component_Type (Etype (Cnode)));
@@ -4668,9 +4660,9 @@ package body Exp_Ch4 is
if Is_Fixed_Point_Type (Typ) then
- -- No special processing if Treat_Fixed_As_Integer is set,
- -- since from a semantic point of view such operations are
- -- simply integer operations and will be treated that way.
+ -- No special processing if Treat_Fixed_As_Integer is set, since
+ -- from a semantic point of view such operations are simply integer
+ -- operations and will be treated that way.
if not Treat_Fixed_As_Integer (N) then
if Is_Integer_Type (Rtyp) then
@@ -4680,8 +4672,8 @@ package body Exp_Ch4 is
end if;
end if;
- -- Other cases of division of fixed-point operands. Again we
- -- exclude the case where Treat_Fixed_As_Integer is set.
+ -- Other cases of division of fixed-point operands. Again we exclude the
+ -- case where Treat_Fixed_As_Integer is set.
elsif (Is_Fixed_Point_Type (Ltyp) or else
Is_Fixed_Point_Type (Rtyp))
@@ -4694,9 +4686,8 @@ package body Exp_Ch4 is
Expand_Divide_Fixed_By_Fixed_Giving_Float (N);
end if;
- -- Mixed-mode operations can appear in a non-static universal
- -- context, in which case the integer argument must be converted
- -- explicitly.
+ -- Mixed-mode operations can appear in a non-static universal context,
+ -- in which case the integer argument must be converted explicitly.
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
@@ -5178,9 +5169,9 @@ package body Exp_Ch4 is
then
null;
- -- For composite and floating-point cases, expand equality loop
- -- to make sure of using proper comparisons for tagged types,
- -- and correctly handling the floating-point case.
+ -- For composite and floating-point cases, expand equality loop to
+ -- make sure of using proper comparisons for tagged types, and
+ -- correctly handling the floating-point case.
else
Rewrite (N,
@@ -5210,20 +5201,19 @@ package body Exp_Ch4 is
return;
end if;
- -- If this is derived from an untagged private type completed
- -- with a tagged type, it does not have a full view, so we
- -- use the primitive operations of the private type.
- -- This check should no longer be necessary when these
- -- types receive their full views ???
+ -- If this is derived from an untagged private type completed with
+ -- a tagged type, it does not have a full view, so we use the
+ -- primitive operations of the private type. This check should no
+ -- longer be necessary when these types get their full views???
if Is_Private_Type (A_Typ)
and then not Is_Tagged_Type (A_Typ)
and then Is_Derived_Type (A_Typ)
and then No (Full_View (A_Typ))
then
- -- Search for equality operation, checking that the
- -- operands have the same type. Note that we must find
- -- a matching entry, or something is very wrong!
+ -- Search for equality operation, checking that the operands
+ -- have the same type. Note that we must find a matching entry,
+ -- or something is very wrong!
Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
@@ -5241,11 +5231,11 @@ package body Exp_Ch4 is
Op_Name := Node (Prim);
-- Find the type's predefined equality or an overriding
- -- user-defined equality. The reason for not simply calling
+ -- user- defined equality. The reason for not simply calling
-- Find_Prim_Op here is that there may be a user-defined
- -- overloaded equality op that precedes the equality that
- -- we want, so we have to explicitly search (e.g., there
- -- could be an equality with two different parameter types).
+ -- overloaded equality op that precedes the equality that we want,
+ -- so we have to explicitly search (e.g., there could be an
+ -- equality with two different parameter types).
else
if Is_Class_Wide_Type (Typl) then
@@ -5370,12 +5360,12 @@ package body Exp_Ch4 is
begin
Binary_Op_Validity_Checks (N);
- -- If either operand is of a private type, then we have the use of
- -- an intrinsic operator, and we get rid of the privateness, by using
- -- root types of underlying types for the actual operation. Otherwise
- -- the private types will cause trouble if we expand multiplications
- -- or shifts etc. We also do this transformation if the result type
- -- is different from the base type.
+ -- If either operand is of a private type, then we have the use of an
+ -- intrinsic operator, and we get rid of the privateness, by using root
+ -- types of underlying types for the actual operation. Otherwise the
+ -- private types will cause trouble if we expand multiplications or
+ -- shifts etc. We also do this transformation if the result type is
+ -- different from the base type.
if Is_Private_Type (Etype (Base))
or else
@@ -5483,6 +5473,10 @@ package body Exp_Ch4 is
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
+ -- Note: this transformation is not applicable for a modular type with
+ -- a non-binary modulus in the multiplication case, since we get a wrong
+ -- result if the shift causes an overflow before the modular reduction.
+
if Nkind (Base) = N_Integer_Literal
and then Intval (Base) = 2
and then Is_Integer_Type (Root_Type (Exptyp))
@@ -5498,6 +5492,7 @@ package body Exp_Ch4 is
begin
if (Nkind (P) = N_Op_Multiply
+ and then not Non_Binary_Modulus (Typ)
and then
((Is_Integer_Type (Etype (L)) and then R = N)
or else
@@ -5538,9 +5533,9 @@ package body Exp_Ch4 is
Make_Integer_Literal (Loc, Modulus (Rtyp)),
Exp))));
- -- Binary case, in this case, we call one of two routines, either
- -- the unsigned integer case, or the unsigned long long integer
- -- case, with a final "and" operation to do the required mod.
+ -- Binary case, in this case, we call one of two routines, either the
+ -- unsigned integer case, or the unsigned long long integer case,
+ -- with a final "and" operation to do the required mod.
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
@@ -5859,9 +5854,9 @@ package body Exp_Ch4 is
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N)));
- -- Instead of reanalyzing the node we do the analysis manually.
- -- This avoids anomalies when the replacement is done in an
- -- instance and is epsilon more efficient.
+ -- Instead of reanalyzing the node we do the analysis manually. This
+ -- avoids anomalies when the replacement is done in an instance and
+ -- is epsilon more efficient.
Set_Entity (N, Standard_Entity (S_Op_Rem));
Set_Etype (N, Typ);
@@ -5894,13 +5889,13 @@ package body Exp_Ch4 is
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
- -- In fact the check is quite easy, if the right operand is -1,
- -- then the mod value is always 0, and we can just ignore the
- -- left operand completely in this case.
-
- -- The operand type may be private (e.g. in the expansion of an
- -- an intrinsic operation) so we must use the underlying type to
- -- get the bounds, and convert the literals explicitly.
+ -- In fact the check is quite easy, if the right operand is -1, then
+ -- the mod value is always 0, and we can just ignore the left operand
+ -- completely in this case.
+
+ -- The operand type may be private (e.g. in the expansion of an an
+ -- intrinsic operation) so we must use the underlying type to get the
+ -- bounds, and convert the literals explicitly.
LLB :=
Expr_Value
@@ -6042,9 +6037,9 @@ package body Exp_Ch4 is
if Is_Fixed_Point_Type (Typ) then
- -- No special processing if Treat_Fixed_As_Integer is set,
- -- since from a semantic point of view such operations are
- -- simply integer operations and will be treated that way.
+ -- No special processing if Treat_Fixed_As_Integer is set, since from
+ -- a semantic point of view such operations are simply integer
+ -- operations and will be treated that way.
if not Treat_Fixed_As_Integer (N) then
@@ -6065,8 +6060,8 @@ package body Exp_Ch4 is
end if;
end if;
- -- Other cases of multiplication of fixed-point operands. Again
- -- we exclude the cases where Treat_Fixed_As_Integer flag is set.
+ -- Other cases of multiplication of fixed-point operands. Again we
+ -- exclude the cases where Treat_Fixed_As_Integer flag is set.
elsif (Is_Fixed_Point_Type (Ltyp) or else Is_Fixed_Point_Type (Rtyp))
and then not Treat_Fixed_As_Integer (N)
@@ -6078,9 +6073,8 @@ package body Exp_Ch4 is
Expand_Multiply_Fixed_By_Fixed_Giving_Float (N);
end if;
- -- Mixed-mode operations can appear in a non-static universal
- -- context, in which case the integer argument must be converted
- -- explicitly.
+ -- Mixed-mode operations can appear in a non-static universal context,
+ -- in which case the integer argument must be converted explicitly.
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
@@ -6187,18 +6181,18 @@ package body Exp_Ch4 is
-- Expand_N_Op_Not --
---------------------
- -- If the argument is other than a Boolean array type, there is no
- -- special expansion required.
+ -- If the argument is other than a Boolean array type, there is no special
+ -- expansion required.
-- For the packed case, we call the special routine in Exp_Pakd, except
-- that if the component size is greater than one, we use the standard
-- routine generating a gruesome loop (it is so peculiar to have packed
- -- arrays with non-standard Boolean representations anyway, so it does
- -- not matter that we do not handle this case efficiently).
+ -- arrays with non-standard Boolean representations anyway, so it does not
+ -- matter that we do not handle this case efficiently).
- -- For the unpacked case (and for the special packed case where we have
- -- non standard Booleans, as discussed above), we generate and insert
- -- into the tree the following function definition:
+ -- For the unpacked case (and for the special packed case where we have non
+ -- standard Booleans, as discussed above), we generate and insert into the
+ -- tree the following function definition:
-- function Nnnn (A : arr) is
-- B : arr;
@@ -6435,9 +6429,9 @@ package body Exp_Ch4 is
Apply_Divide_Check (N);
end if;
- -- Apply optimization x rem 1 = 0. We don't really need that with
- -- gcc, but it is useful with other back ends (e.g. AAMP), and is
- -- certainly harmless.
+ -- Apply optimization x rem 1 = 0. We don't really need that with gcc,
+ -- but it is useful with other back ends (e.g. AAMP), and is certainly
+ -- harmless.
if Is_Integer_Type (Etype (N))
and then Compile_Time_Known_Value (Right)
@@ -6448,20 +6442,20 @@ package body Exp_Ch4 is
return;
end if;
- -- Deal with annoying case of largest negative number remainder
- -- minus one. Gigi does not handle this case correctly, because
- -- it generates a divide instruction which may trap in this case.
-
- -- In fact the check is quite easy, if the right operand is -1,
- -- then the remainder is always 0, and we can just ignore the
- -- left operand completely in this case.
+ -- Deal with annoying case of largest negative number remainder minus
+ -- one. Gigi does not handle this case correctly, because it generates
+ -- a divide instruction which may trap in this case.
+
+ -- In fact the check is quite easy, if the right operand is -1, then
+ -- the remainder is always 0, and we can just ignore the left operand
+ -- completely in this case.
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
- -- The operand type may be private (e.g. in the expansion of an
- -- an intrinsic operation) so we must use the underlying type to
- -- get the bounds, and convert the literals explicitly.
+ -- The operand type may be private (e.g. in the expansion of an an
+ -- intrinsic operation) so we must use the underlying type to get the
+ -- bounds, and convert the literals explicitly.
LLB :=
Expr_Value
@@ -6632,9 +6626,9 @@ package body Exp_Ch4 is
Adjust_Result_Type (N, Typ);
return;
- -- If left argument is True, change (True and then Right) to
- -- True. In this case we can forget the actions associated with
- -- Right, since they will never be executed.
+ -- If left argument is True, change (True and then Right) to True. In
+ -- this case we can forget the actions associated with Right, since
+ -- they will never be executed.
elsif Entity (Left) = Standard_True then
Kill_Dead_Code (Right);
@@ -6676,15 +6670,15 @@ package body Exp_Ch4 is
if Nkind (Right) = N_Identifier then
- -- Change (Left or else False) to Left. Note that we know there
- -- are no actions associated with the True operand, since we
- -- just checked for this case above.
+ -- Change (Left or else False) to Left. Note that we know there are
+ -- no actions associated with the True operand, since we just checked
+ -- for this case above.
if Entity (Right) = Standard_False then
Rewrite (N, Left);
- -- Change (Left or else True) to True, making sure to preserve
- -- any side effects associated with the Left operand.
+ -- Change (Left or else True) to True, making sure to preserve any
+ -- side effects associated with the Left operand.
elsif Entity (Right) = Standard_True then
Remove_Side_Effects (Left);
@@ -6774,8 +6768,8 @@ package body Exp_Ch4 is
if Do_Discriminant_Check (N) then
- -- Present the discriminant checking function to the backend,
- -- so that it can inline the call to the function.
+ -- Present the discriminant checking function to the backend, so that
+ -- it can inline the call to the function.
Add_Inlined_Body
(Discriminant_Checking_Func
@@ -6837,9 +6831,9 @@ package body Exp_Ch4 is
then
null;
- -- Don't do this optimization for the prefix of an attribute
- -- or the operand of an object renaming declaration since these
- -- are contexts where we do not want the value anyway.
+ -- Don't do this optimization for the prefix of an attribute or
+ -- the operand of an object renaming declaration since these are
+ -- contexts where we do not want the value anyway.
elsif (Nkind (Par) = N_Attribute_Reference
and then Prefix (Par) = N)
@@ -6855,12 +6849,12 @@ package body Exp_Ch4 is
null;
-- Green light to see if we can do the optimization. There is
- -- still one condition that inhibits the optimization below
- -- but now is the time to check the particular discriminant.
+ -- still one condition that inhibits the optimization below but
+ -- now is the time to check the particular discriminant.
else
- -- Loop through discriminants to find the matching
- -- discriminant constraint to see if we can copy it.
+ -- Loop through discriminants to find the matching discriminant
+ -- constraint to see if we can copy it.
Disc := First_Discriminant (Ptyp);
Dcon := First_Elmt (Discriminant_Constraint (Ptyp));
@@ -6881,10 +6875,10 @@ package body Exp_Ch4 is
then
exit Discr_Loop;
- -- In the context of a case statement, the expression
- -- may have the base type of the discriminant, and we
- -- need to preserve the constraint to avoid spurious
- -- errors on missing cases.
+ -- In the context of a case statement, the expression may
+ -- have the base type of the discriminant, and we need to
+ -- preserve the constraint to avoid spurious errors on
+ -- missing cases.
elsif Nkind (Parent (N)) = N_Case_Statement
and then Etype (Node (Dcon)) /= Etype (Disc)
@@ -6924,8 +6918,8 @@ package body Exp_Ch4 is
-- Note: the above loop should always find a matching
-- discriminant, but if it does not, we just missed an
- -- optimization due to some glitch (perhaps a previous
- -- error), so ignore.
+ -- optimization due to some glitch (perhaps a previous error),
+ -- so ignore.
end if;
end if;
@@ -6971,21 +6965,21 @@ package body Exp_Ch4 is
Ptp : Entity_Id := Etype (Pfx);
function Is_Procedure_Actual (N : Node_Id) return Boolean;
- -- Check whether the argument is an actual for a procedure call,
- -- in which case the expansion of a bit-packed slice is deferred
- -- until the call itself is expanded. The reason this is required
- -- is that we might have an IN OUT or OUT parameter, and the copy out
- -- is essential, and that copy out would be missed if we created a
- -- temporary here in Expand_N_Slice. Note that we don't bother
- -- to test specifically for an IN OUT or OUT mode parameter, since it
- -- is a bit tricky to do, and it is harmless to defer expansion
- -- in the IN case, since the call processing will still generate the
- -- appropriate copy in operation, which will take care of the slice.
+ -- Check whether the argument is an actual for a procedure call, in
+ -- which case the expansion of a bit-packed slice is deferred until the
+ -- call itself is expanded. The reason this is required is that we might
+ -- have an IN OUT or OUT parameter, and the copy out is essential, and
+ -- that copy out would be missed if we created a temporary here in
+ -- Expand_N_Slice. Note that we don't bother to test specifically for an
+ -- IN OUT or OUT mode parameter, since it is a bit tricky to do, and it
+ -- is harmless to defer expansion in the IN case, since the call
+ -- processing will still generate the appropriate copy in operation,
+ -- which will take care of the slice.
procedure Make_Temporary;
- -- Create a named variable for the value of the slice, in
- -- cases where the back-end cannot handle it properly, e.g.
- -- when packed types or unaligned slices are involved.
+ -- Create a named variable for the value of the slice, in cases where
+ -- the back-end cannot handle it properly, e.g. when packed types or
+ -- unaligned slices are involved.
-------------------------
-- Is_Procedure_Actual --
@@ -7001,11 +6995,11 @@ package body Exp_Ch4 is
if Nkind (Par) = N_Procedure_Call_Statement then
return True;
- -- If our parent is a type conversion, keep climbing the
- -- tree, since a type conversion can be a procedure actual.
- -- Also keep climbing if parameter association or a qualified
- -- expression, since these are additional cases that do can
- -- appear on procedure actuals.
+ -- If our parent is a type conversion, keep climbing the tree,
+ -- since a type conversion can be a procedure actual. Also keep
+ -- climbing if parameter association or a qualified expression,
+ -- since these are additional cases that do can appear on
+ -- procedure actuals.
elsif Nkind_In (Par, N_Type_Conversion,
N_Parameter_Association,
@@ -7072,9 +7066,9 @@ package body Exp_Ch4 is
Make_Build_In_Place_Call_In_Anonymous_Context (Pfx);
end if;
- -- Range checks are potentially also needed for cases involving
- -- a slice indexed by a subtype indication, but Do_Range_Check
- -- can currently only be set for expressions ???
+ -- Range checks are potentially also needed for cases involving a slice
+ -- indexed by a subtype indication, but Do_Range_Check can currently
+ -- only be set for expressions ???
if not Index_Checks_Suppressed (Ptp)
and then (not Is_Entity_Name (Pfx)
@@ -7104,24 +7098,24 @@ package body Exp_Ch4 is
-- 1. Right or left side of an assignment (we can handle this
-- situation correctly in the assignment statement expansion).
- -- 2. Prefix of indexed component (the slide is optimized away
- -- in this case, see the start of Expand_N_Slice.)
+ -- 2. Prefix of indexed component (the slide is optimized away in this
+ -- case, see the start of Expand_N_Slice.)
- -- 3. Object renaming declaration, since we want the name of
- -- the slice, not the value.
+ -- 3. Object renaming declaration, since we want the name of the
+ -- slice, not the value.
- -- 4. Argument to procedure call, since copy-in/copy-out handling
- -- may be required, and this is handled in the expansion of
- -- call itself.
-
- -- 5. Prefix of an address attribute (this is an error which
- -- is caught elsewhere, and the expansion would interfere
- -- with generating the error message).
+ -- 4. Argument to procedure call, since copy-in/copy-out handling may
+ -- be required, and this is handled in the expansion of call
+ -- itself.
+
+ -- 5. Prefix of an address attribute (this is an error which is caught
+ -- elsewhere, and the expansion would interfere with generating the
+ -- error message).
if not Is_Packed (Typ) then
- -- Apply transformation for actuals of a function call,
- -- where Expand_Actuals is not used.
+ -- Apply transformation for actuals of a function call, where
+ -- Expand_Actuals is not used.
if Nkind (Parent (N)) = N_Function_Call
and then Is_Possibly_Unaligned_Slice (N)
@@ -7162,12 +7156,12 @@ package body Exp_Ch4 is
Operand_Type : Entity_Id := Etype (Operand);
procedure Handle_Changed_Representation;
- -- This is called in the case of record and array type conversions
- -- to see if there is a change of representation to be handled.
- -- Change of representation is actually handled at the assignment
- -- statement level, and what this procedure does is rewrite node N
- -- conversion as an assignment to temporary. If there is no change
- -- of representation, then the conversion node is unchanged.
+ -- This is called in the case of record and array type conversions to
+ -- see if there is a change of representation to be handled. Change of
+ -- representation is actually handled at the assignment statement level,
+ -- and what this procedure does is rewrite node N conversion as an
+ -- assignment to temporary. If there is no change of representation,
+ -- then the conversion node is unchanged.
procedure Real_Range_Check;
-- Handles generation of range check for real target value
@@ -7205,8 +7199,8 @@ package body Exp_Ch4 is
else
Cons := No_List;
- -- If type is unconstrained we have to add a constraint,
- -- copied from the actual value of the left hand side.
+ -- If type is unconstrained we have to add a constraint, copied
+ -- from the actual value of the left hand side.
if not Is_Constrained (Target_Type) then
if Has_Discriminants (Operand_Type) then
@@ -7302,9 +7296,8 @@ package body Exp_Ch4 is
-- Real_Range_Check --
----------------------
- -- Case of conversions to floating-point or fixed-point. If range
- -- checks are enabled and the target type has a range constraint,
- -- we convert:
+ -- Case of conversions to floating-point or fixed-point. If range checks
+ -- are enabled and the target type has a range constraint, we convert:
-- typ (x)
@@ -7314,10 +7307,10 @@ package body Exp_Ch4 is
-- [constraint_error when Tnn < typ'First or else Tnn > typ'Last]
-- Tnn
- -- This is necessary when there is a conversion of integer to float
- -- or to fixed-point to ensure that the correct checks are made. It
- -- is not necessary for float to float where it is enough to simply
- -- set the Do_Range_Check flag.
+ -- This is necessary when there is a conversion of integer to float or
+ -- to fixed-point to ensure that the correct checks are made. It is not
+ -- necessary for float to float where it is enough to simply set the
+ -- Do_Range_Check flag.
procedure Real_Range_Check is
Btyp : constant Entity_Id := Base_Type (Target_Type);
@@ -7334,8 +7327,8 @@ package body Exp_Ch4 is
return;
end if;
- -- Nothing to do if range checks suppressed, or target has the
- -- same range as the base type (or is the base type).
+ -- Nothing to do if range checks suppressed, or target has the same
+ -- range as the base type (or is the base type).
if Range_Checks_Suppressed (Target_Type)
or else (Lo = Type_Low_Bound (Btyp)
@@ -7345,8 +7338,8 @@ package body Exp_Ch4 is
return;
end if;
- -- Nothing to do if expression is an entity on which checks
- -- have been suppressed.
+ -- Nothing to do if expression is an entity on which checks have been
+ -- suppressed.
if Is_Entity_Name (Operand)
and then Range_Checks_Suppressed (Entity (Operand))
@@ -7354,10 +7347,10 @@ package body Exp_Ch4 is
return;
end if;
- -- Nothing to do if bounds are all static and we can tell that
- -- the expression is within the bounds of the target. Note that
- -- if the operand is of an unconstrained floating-point type,
- -- then we do not trust it to be in range (might be infinite)
+ -- Nothing to do if bounds are all static and we can tell that the
+ -- expression is within the bounds of the target. Note that if the
+ -- operand is of an unconstrained floating-point type, then we do
+ -- not trust it to be in range (might be infinite)
declare
S_Lo : constant Node_Id := Type_Low_Bound (Xtyp);
@@ -7460,17 +7453,17 @@ package body Exp_Ch4 is
-- Start of processing for Expand_N_Type_Conversion
begin
- -- Nothing at all to do if conversion is to the identical type
- -- so remove the conversion completely, it is useless.
+ -- Nothing at all to do if conversion is to the identical type so remove
+ -- the conversion completely, it is useless.
if Operand_Type = Target_Type then
Rewrite (N, Relocate_Node (Operand));
return;
end if;
- -- Nothing to do if this is the second argument of read. This
- -- is a "backwards" conversion that will be handled by the
- -- specialized code in attribute processing.
+ -- Nothing to do if this is the second argument of read. This is a
+ -- "backwards" conversion that will be handled by the specialized code
+ -- in attribute processing.
if Nkind (Parent (N)) = N_Attribute_Reference
and then Attribute_Name (Parent (N)) = Name_Read
@@ -7523,13 +7516,12 @@ package body Exp_Ch4 is
then
Apply_Accessibility_Check (Operand, Target_Type);
- -- If the level of the operand type is statically deeper
- -- then the level of the target type, then force Program_Error.
- -- Note that this can only occur for cases where the attribute
- -- is within the body of an instantiation (otherwise the
- -- conversion will already have been rejected as illegal).
- -- Note: warnings are issued by the analyzer for the instance
- -- cases.
+ -- If the level of the operand type is statically deeper then the
+ -- level of the target type, then force Program_Error. Note that this
+ -- can only occur for cases where the attribute is within the body of
+ -- an instantiation (otherwise the conversion will already have been
+ -- rejected as illegal). Note: warnings are issued by the analyzer
+ -- for the instance cases.
elsif In_Instance_Body
and then Type_Access_Level (Operand_Type) >
@@ -7540,12 +7532,11 @@ package body Exp_Ch4 is
Reason => PE_Accessibility_Check_Failed));
Set_Etype (N, Target_Type);
- -- When the operand is a selected access discriminant
- -- the check needs to be made against the level of the
- -- object denoted by the prefix of the selected name.
- -- Force Program_Error for this case as well (this
- -- accessibility violation can only happen if within
- -- the body of an instantiation).
+ -- When the operand is a selected access discriminant the check needs
+ -- to be made against the level of the object denoted by the prefix
+ -- of the selected name. Force Program_Error for this case as well
+ -- (this accessibility violation can only happen if within the body
+ -- of an instantiation).
elsif In_Instance_Body
and then Ekind (Operand_Type) = E_Anonymous_Access_Type
@@ -7562,9 +7553,9 @@ package body Exp_Ch4 is
-- Case of conversions of tagged types and access to tagged types
- -- When needed, that is to say when the expression is class-wide,
- -- Add runtime a tag check for (strict) downward conversion by using
- -- the membership test, generating:
+ -- When needed, that is to say when the expression is class-wide, Add
+ -- runtime a tag check for (strict) downward conversion by using the
+ -- membership test, generating:
-- [constraint_error when Operand not in Target_Type'Class]
@@ -7579,10 +7570,9 @@ package body Exp_Ch4 is
and then Is_Tagged_Type (Designated_Type (Target_Type)))
or else Is_Tagged_Type (Target_Type)
then
- -- Do not do any expansion in the access type case if the
- -- parent is a renaming, since this is an error situation
- -- which will be caught by Sem_Ch8, and the expansion can
- -- interfere with this error check.
+ -- Do not do any expansion in the access type case if the parent is a
+ -- renaming, since this is an error situation which will be caught by
+ -- Sem_Ch8, and the expansion can interfere with this error check.
if Is_Access_Type (Target_Type)
and then Is_Renamed_Object (N)
@@ -7622,8 +7612,7 @@ package body Exp_Ch4 is
Actual_Target_Type)
and then not Tag_Checks_Suppressed (Actual_Target_Type)
then
- -- The conversion is valid for any descendant of the
- -- target type
+ -- Conversion is valid for any descendant of the target type
Actual_Target_Type := Class_Wide_Type (Actual_Target_Type);
@@ -7677,9 +7666,9 @@ package body Exp_Ch4 is
-- Case of conversions from a fixed-point type
- -- These conversions require special expansion and processing, found
- -- in the Exp_Fixd package. We ignore cases where Conversion_OK is
- -- set, since from a semantic point of view, these are simple integer
+ -- These conversions require special expansion and processing, found in
+ -- the Exp_Fixd package. We ignore cases where Conversion_OK is set,
+ -- since from a semantic point of view, these are simple integer
-- conversions, which do not need further processing.
elsif Is_Fixed_Point_Type (Operand_Type)
@@ -7691,11 +7680,10 @@ package body Exp_Ch4 is
pragma Assert (Operand_Type /= Universal_Fixed);
- -- Check for special case of the conversion to universal real
- -- that occurs as a result of the use of a round attribute.
- -- In this case, the real type for the conversion is taken
- -- from the target type of the Round attribute and the
- -- result must be marked as rounded.
+ -- Check for special case of the conversion to universal real that
+ -- occurs as a result of the use of a round attribute. In this case,
+ -- the real type for the conversion is taken from the target type of
+ -- the Round attribute and the result must be marked as rounded.
if Target_Type = Universal_Real
and then Nkind (Parent (N)) = N_Attribute_Reference
@@ -7727,10 +7715,10 @@ package body Exp_Ch4 is
-- Case of conversions to a fixed-point type
- -- These conversions require special expansion and processing, found
- -- in the Exp_Fixd package. Again, ignore cases where Conversion_OK
- -- is set, since from a semantic point of view, these are simple
- -- integer conversions, which do not need further processing.
+ -- These conversions require special expansion and processing, found in
+ -- the Exp_Fixd package. Again, ignore cases where Conversion_OK is set,
+ -- since from a semantic point of view, these are simple integer
+ -- conversions, which do not need further processing.
elsif Is_Fixed_Point_Type (Target_Type)
and then not Conversion_OK (N)
@@ -7782,9 +7770,9 @@ package body Exp_Ch4 is
-- Case of array conversions
- -- Expansion of array conversions, add required length/range checks
- -- but only do this if there is no change of representation. For
- -- handling of this case, see Handle_Changed_Representation.
+ -- Expansion of array conversions, add required length/range checks but
+ -- only do this if there is no change of representation. For handling of
+ -- this case, see Handle_Changed_Representation.
elsif Is_Array_Type (Target_Type) then
@@ -7798,8 +7786,8 @@ package body Exp_Ch4 is
-- Case of conversions of discriminated types
- -- Add required discriminant checks if target is constrained. Again
- -- this change is skipped if we have a change of representation.
+ -- Add required discriminant checks if target is constrained. Again this
+ -- change is skipped if we have a change of representation.
elsif Has_Discriminants (Target_Type)
and then Is_Constrained (Target_Type)
@@ -7814,8 +7802,8 @@ package body Exp_Ch4 is
elsif Is_Record_Type (Target_Type) then
-- Ada 2005 (AI-216): Program_Error is raised when converting from
- -- a derived Unchecked_Union type to an unconstrained non-Unchecked_
- -- Union type if the operand lacks inferable discriminants.
+ -- a derived Unchecked_Union type to an unconstrained type that is
+ -- not Unchecked_Union if the operand lacks inferable discriminants.
if Is_Derived_Type (Operand_Type)
and then Is_Unchecked_Union (Base_Type (Operand_Type))
@@ -7823,7 +7811,7 @@ package body Exp_Ch4 is
and then not Is_Unchecked_Union (Base_Type (Target_Type))
and then not Has_Inferable_Discriminants (Operand)
then
- -- To prevent Gigi from generating illegal code, we make a
+ -- To prevent Gigi from generating illegal code, we generate a
-- Program_Error node, but we give it the target type of the
-- conversion.
@@ -7870,25 +7858,24 @@ package body Exp_Ch4 is
Real_Range_Check;
end if;
- -- At this stage, either the conversion node has been transformed
- -- into some other equivalent expression, or left as a conversion
- -- that can be handled by Gigi. The conversions that Gigi can handle
- -- are the following:
+ -- At this stage, either the conversion node has been transformed into
+ -- some other equivalent expression, or left as a conversion that can
+ -- be handled by Gigi. The conversions that Gigi can handle are the
+ -- following:
-- Conversions with no change of representation or type
- -- Numeric conversions involving integer values, floating-point
- -- values, and fixed-point values. Fixed-point values are allowed
- -- only if Conversion_OK is set, i.e. if the fixed-point values
- -- are to be treated as integers.
+ -- Numeric conversions involving integer, floating- and fixed-point
+ -- values. Fixed-point values are allowed only if Conversion_OK is
+ -- set, i.e. if the fixed-point values are to be treated as integers.
-- No other conversions should be passed to Gigi
-- Check: are these rules stated in sinfo??? if so, why restate here???
- -- The only remaining step is to generate a range check if we still
- -- have a type conversion at this stage and Do_Range_Check is set.
- -- For now we do this only for conversions of discrete types.
+ -- The only remaining step is to generate a range check if we still have
+ -- a type conversion at this stage and Do_Range_Check is set. For now we
+ -- do this only for conversions of discrete types.
if Nkind (N) = N_Type_Conversion
and then Is_Discrete_Type (Etype (N))
@@ -7904,9 +7891,9 @@ package body Exp_Ch4 is
then
Set_Do_Range_Check (Expr, False);
- -- Before we do a range check, we have to deal with treating
- -- a fixed-point operand as an integer. The way we do this
- -- is simply to do an unchecked conversion to an appropriate
+ -- Before we do a range check, we have to deal with treating a
+ -- fixed-point operand as an integer. The way we do this is
+ -- simply to do an unchecked conversion to an appropriate
-- integer type large enough to hold the result.
-- This code is not active yet, because we are only dealing
@@ -7927,8 +7914,8 @@ package body Exp_Ch4 is
end if;
-- Reset overflow flag, since the range check will include
- -- dealing with possible overflow, and generate the check
- -- If Address is either source or target type, suppress
+ -- dealing with possible overflow, and generate the check If
+ -- Address is either a source type or target type, suppress
-- range check to avoid typing anomalies when it is a visible
-- integer type.
@@ -7975,8 +7962,8 @@ package body Exp_Ch4 is
-- Expand_N_Unchecked_Type_Conversion --
----------------------------------------
- -- If this cannot be handled by Gigi and we haven't already made
- -- a temporary for it, do it now.
+ -- If this cannot be handled by Gigi and we haven't already made a
+ -- temporary for it, do it now.
procedure Expand_N_Unchecked_Type_Conversion (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
@@ -8019,9 +8006,9 @@ package body Exp_Ch4 is
then
Rewrite (N, Make_Integer_Literal (Sloc (N), Val));
- -- If Address is the target type, just set the type
- -- to avoid a spurious type error on the literal when
- -- Address is a visible integer type.
+ -- If Address is the target type, just set the type to avoid a
+ -- spurious type error on the literal when Address is a visible
+ -- integer type.
if Is_Descendent_Of_Address (Target_Type) then
Set_Etype (N, Target_Type);
@@ -8425,11 +8412,11 @@ package body Exp_Ch4 is
New_Reference_To (Pool, Loc),
- -- Storage_Address. We use the attribute Pool_Address,
- -- which uses the pointer itself to find the address of
- -- the object, and which handles unconstrained arrays
- -- properly by computing the address of the template.
- -- i.e. the correct address of the corresponding allocation.
+ -- Storage_Address. We use the attribute Pool_Address, which uses
+ -- the pointer itself to find the address of the object, and which
+ -- handles unconstrained arrays properly by computing the address
+ -- of the template. i.e. the correct address of the corresponding
+ -- allocation.
Make_Attribute_Reference (Loc,
Prefix => Duplicate_Subexpr_Move_Checks (N),
@@ -8722,8 +8709,8 @@ package body Exp_Ch4 is
-- Make_Boolean_Array_Op --
---------------------------
- -- For logical operations on boolean arrays, expand in line the
- -- following, replacing 'and' with 'or' or 'xor' where needed:
+ -- For logical operations on boolean arrays, expand in line the following,
+ -- replacing 'and' with 'or' or 'xor' where needed:
-- function Annn (A : typ; B: typ) return typ is
-- C : typ;
@@ -9002,9 +8989,8 @@ package body Exp_Ch4 is
-- Start of processing for Is_Safe_In_Place_Array_Op
begin
- -- We skip this processing if the component size is not the
- -- same as a system storage unit (since at least for NOT
- -- this would cause problems).
+ -- Skip this processing if the component size is different from system
+ -- storage unit (since at least for NOT this would cause problems).
if Component_Size (Etype (Lhs)) /= System_Storage_Unit then
return False;
@@ -9034,15 +9020,15 @@ package body Exp_Ch4 is
-- Tagged_Membership --
-----------------------
- -- There are two different cases to consider depending on whether
- -- the right operand is a class-wide type or not. If not we just
- -- compare the actual tag of the left expr to the target type tag:
+ -- There are two different cases to consider depending on whether the right
+ -- operand is a class-wide type or not. If not we just compare the actual
+ -- tag of the left expr to the target type tag:
--
-- Left_Expr.Tag = Right_Type'Tag;
--
- -- If it is a class-wide type we use the RT function CW_Membership which
- -- is usually implemented by looking in the ancestor tables contained in
- -- the dispatch table pointed by Left_Expr.Tag for Typ'Tag
+ -- If it is a class-wide type we use the RT function CW_Membership which is
+ -- usually implemented by looking in the ancestor tables contained in the
+ -- dispatch table pointed by Left_Expr.Tag for Typ'Tag
-- Ada 2005 (AI-251): If it is a class-wide interface type we use the RT
-- function IW_Membership which is usually implemented by looking in the
Index: sem_intr.adb
===================================================================
--- sem_intr.adb (revision 134945)
+++ sem_intr.adb (working copy)
@@ -418,9 +418,7 @@ package body Sem_Intr is
Ptyp1, N);
return;
- elsif Is_Modular_Integer_Type (Typ1)
- and then Non_Binary_Modulus (Typ1)
- then
+ elsif Non_Binary_Modulus (Typ1) then
Errint
("shifts not allowed for non-binary modular types",
Ptyp1, N);
More information about the Gcc-patches
mailing list