Commit 685094bf by Robert Dewar Committed by Arnaud Charlet

re PR ada/30740 (Improper semantics in gnat's compilation of certain expressions…

re PR ada/30740 (Improper semantics in gnat's compilation of certain expressions involving modular arithmetic)

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.

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