Skip to content

R
riscv-gcc-1
Commit 685094bf by Robert Dewar Committed by Arnaud Charlet
Options

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