diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-05-20 12:44:55 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2008-05-20 12:44:55 +0000 |
| commit | f1e2dcc530d9406d04177021480b615ebe12eab0 (patch) | |
| tree | 07adf48529a7f93ac90b78c757b1211f4363f826 /gcc/ada | |
| parent | 497260ff15267fd4331606ecc1c25649031748f3 (diff) | |
| download | ppe42-gcc-f1e2dcc530d9406d04177021480b615ebe12eab0.tar.gz ppe42-gcc-f1e2dcc530d9406d04177021480b615ebe12eab0.zip | |
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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@135619 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/einfo.adb | 47 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 45 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 964 | ||||
| -rw-r--r-- | gcc/ada/sem_intr.adb | 4 |
4 files changed, 520 insertions, 540 deletions
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 7374a7e41ae..7d3fbdf57d7 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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??"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 852d9966ddf..e1623042b52 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index ee440f14424..0246516fcbf 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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. + -- 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. + -- 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. + -- 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. + -- 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. + -- 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. + -- 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. + -- 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). + -- 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 diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb index 9d7319759b3..0b7adc45224 100644 --- a/gcc/ada/sem_intr.adb +++ b/gcc/ada/sem_intr.adb @@ -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); |
