Google Git
Sign in
gnu / gcc / 19220ca6aa79921cc431e41f25986e16410c7a6a / . / gcc / ada / exp_ch4.adb
blob: 1f2640d2206a7d30b4de0acd4d084762d38d7b90 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ C H 4 --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Fixd; use Exp_Fixd;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Exp_VFpt; use Exp_VFpt;
with Hostparm; use Hostparm;
with Inline; use Inline;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.CN; use Sinfo.CN;
with Snames; use Snames;
with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Validsw; use Validsw;
package body Exp_Ch4 is
------------------------
-- Local Subprograms --
------------------------
procedure Binary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Binary_Op_Validity_Checks);
-- Performs validity checks for a binary operator
procedure Build_Boolean_Array_Proc_Call
(N : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id);
-- If an boolean array assignment can be done in place, build call to
-- corresponding library procedure.
procedure Expand_Allocator_Expression (N : Node_Id);
-- Subsidiary to Expand_N_Allocator, for the case when the expression
-- is a qualified expression or an aggregate.
procedure Expand_Array_Comparison (N : Node_Id);
-- This routine handles expansion of the comparison operators (N_Op_Lt,
-- N_Op_Le, N_Op_Gt, N_Op_Ge) when operating on an array type. The basic
-- code for these operators is similar, differing only in the details of
-- the actual comparison call that is made. Special processing (call a
-- run-time routine)
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_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. Typ is the type of the array, and Lhs, Rhs are the array
-- expressions to be compared. A_Typ is the type of the arguments,
-- which may be a private type, in which case Typ is its full view.
-- 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 the generated code.
procedure Expand_Boolean_Operator (N : Node_Id);
-- Common expansion processing for Boolean operators (And, Or, Xor)
-- for the case of array type arguments.
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
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 responsability of the caller
-- to insert those bodies at the right place. Nod provides the Sloc
-- value for generated code.
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.
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id);
-- Routine to expand concatenation of 2-5 operands (in the list Operands)
-- and replace node Cnode with the result of the contatenation. If there
-- are two operands, they can be string or character. If there are more
-- than two operands, then are always of type string (i.e. the caller has
-- 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.
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.
procedure Insert_Dereference_Action (N : Node_Id);
-- N is an expression whose type is an access. When the type is derived
-- from Checked_Pool, expands a call to the primitive 'dereference'.
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.
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).
procedure Rewrite_Comparison (N : Node_Id);
-- N is the node for a compile time comparison. If this outcome of this
-- comparison can be determined at compile time, then the node N can be
-- rewritten with True or False. If the outcome cannot be determined at
-- compile time, the call has no effect.
function Tagged_Membership (N : Node_Id) return Node_Id;
-- Construct the expression corresponding to the tagged membership test.
-- Deals with a second operand being (or not) a class-wide type.
function Safe_In_Place_Array_Op
(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.
procedure Unary_Op_Validity_Checks (N : Node_Id);
pragma Inline (Unary_Op_Validity_Checks);
-- Performs validity checks for a unary operator
-------------------------------
-- Binary_Op_Validity_Checks --
-------------------------------
procedure Binary_Op_Validity_Checks (N : Node_Id) is
begin
if Validity_Checks_On and Validity_Check_Operands then
Ensure_Valid (Left_Opnd (N));
Ensure_Valid (Right_Opnd (N));
end if;
end Binary_Op_Validity_Checks;
------------------------------------
-- Build_Boolean_Array_Proc_Call --
------------------------------------
procedure Build_Boolean_Array_Proc_Call
(N : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Kind : constant Node_Kind := Nkind (Expression (N));
Target : constant Node_Id :=
Make_Attribute_Reference (Loc,
Prefix => Name (N),
Attribute_Name => Name_Address);
Arg1 : constant Node_Id := Op1;
Arg2 : Node_Id := Op2;
Call_Node : Node_Id;
Proc_Name : Entity_Id;
begin
if Kind = N_Op_Not then
if Nkind (Op1) in N_Binary_Op then
-- Use negated version of the binary operators.
if Nkind (Op1) = N_Op_And then
Proc_Name := RTE (RE_Vector_Nand);
elsif Nkind (Op1) = N_Op_Or then
Proc_Name := RTE (RE_Vector_Nor);
else pragma Assert (Nkind (Op1) = N_Op_Xor);
Proc_Name := RTE (RE_Vector_Xor);
end if;
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Name, Loc),
Parameter_Associations => New_List (
Target,
Make_Attribute_Reference (Loc,
Prefix => Left_Opnd (Op1),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Right_Opnd (Op1),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Left_Opnd (Op1),
Attribute_Name => Name_Length)));
else
Proc_Name := RTE (RE_Vector_Not);
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Name, Loc),
Parameter_Associations => New_List (
Target,
Make_Attribute_Reference (Loc,
Prefix => Op1,
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Op1,
Attribute_Name => Name_Length)));
end if;
else
-- We use the following equivalences:
-- (not X) or (not Y) = not (X and Y) = Nand (X, Y)
-- (not X) and (not Y) = not (X or Y) = Nor (X, Y)
-- (not X) xor (not Y) = X xor Y
-- X xor (not Y) = not (X xor Y) = Nxor (X, Y)
if Nkind (Op1) = N_Op_Not then
if Kind = N_Op_And then
Proc_Name := RTE (RE_Vector_Nor);
elsif Kind = N_Op_Or then
Proc_Name := RTE (RE_Vector_Nand);
else
Proc_Name := RTE (RE_Vector_Xor);
end if;
else
if Kind = N_Op_And then
Proc_Name := RTE (RE_Vector_And);
elsif Kind = N_Op_Or then
Proc_Name := RTE (RE_Vector_Or);
elsif Nkind (Op2) = N_Op_Not then
Proc_Name := RTE (RE_Vector_Nxor);
Arg2 := Right_Opnd (Op2);
else
Proc_Name := RTE (RE_Vector_Xor);
end if;
end if;
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Proc_Name, Loc),
Parameter_Associations => New_List (
Target,
Make_Attribute_Reference (Loc,
Prefix => Arg1,
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Arg2,
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Op1,
Attribute_Name => Name_Length)));
end if;
Rewrite (N, Call_Node);
Analyze (N);
exception
when RE_Not_Available =>
return;
end Build_Boolean_Array_Proc_Call;
---------------------------------
-- Expand_Allocator_Expression --
---------------------------------
procedure Expand_Allocator_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Exp : constant Node_Id := Expression (Expression (N));
Indic : constant Node_Id := Subtype_Mark (Expression (N));
PtrT : constant Entity_Id := Etype (N);
T : constant Entity_Id := Entity (Indic);
Flist : Node_Id;
Node : Node_Id;
Temp : Entity_Id;
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Tag_Assign : Node_Id;
Tmp_Node : Node_Id;
begin
if Is_Tagged_Type (T) or else Controlled_Type (T) then
-- Actions inserted before:
-- Temp : constant ptr_T := new T'(Expression);
-- <no CW> Temp._tag := T'tag;
-- <CTRL> Adjust (Finalizable (Temp.all));
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- We analyze by hand the new internal allocator to avoid
-- any recursion and inappropriate call to Initialize
if not Aggr_In_Place then
Remove_Side_Effects (Exp);
end if;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- For a class wide allocation generate the following code:
-- type Equiv_Record is record ... end record;
-- implicit subtype CW is <Class_Wide_Subytpe>;
-- temp : PtrT := new CW'(CW!(expr));
if Is_Class_Wide_Type (T) then
Expand_Subtype_From_Expr (Empty, T, Indic, Exp);
Set_Expression (Expression (N),
Unchecked_Convert_To (Entity (Indic), Exp));
Analyze_And_Resolve (Expression (N), Entity (Indic));
end if;
if Aggr_In_Place then
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression =>
Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_Comes_From_Source
(Expression (Tmp_Node), Comes_From_Source (N));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
if Controlled_Type (T)
and then Ekind (PtrT) = E_Anonymous_Access_Type
then
-- Create local finalization list for access parameter.
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
end if;
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
else
Node := Relocate_Node (N);
Set_Analyzed (Node);
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Node));
end if;
-- Suppress the tag assignment when Java_VM because JVM tags
-- are represented implicitly in objects.
if Is_Tagged_Type (T)
and then not Is_Class_Wide_Type (T)
and then not Java_VM
then
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
New_Reference_To (Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (Access_Disp_Table (T), Loc)));
-- The previous assignment has to be done in any case
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
elsif Is_Private_Type (T)
and then Is_Tagged_Type (Underlying_Type (T))
and then not Java_VM
then
declare
Utyp : constant Entity_Id := Underlying_Type (T);
Ref : constant Node_Id :=
Unchecked_Convert_To (Utyp,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc)));
begin
Tag_Assign :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
New_Reference_To (Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
Access_Disp_Table (Utyp), Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
end;
end if;
if Controlled_Type (Designated_Type (PtrT))
and then Controlled_Type (T)
then
declare
Attach : Node_Id;
Apool : constant Entity_Id :=
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 Is_RTE (Apool, RE_SS_Pool) then
declare
F : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('F'));
begin
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => F,
Object_Definition => New_Reference_To (RTE
(RE_Finalizable_Ptr), Loc)));
Flist := New_Reference_To (F, Loc);
Attach := Make_Integer_Literal (Loc, 1);
end;
-- Normal case, not a secondary stack allocation
else
Flist := Find_Final_List (PtrT);
Attach := Make_Integer_Literal (Loc, 2);
end if;
if not Aggr_In_Place then
Insert_Actions (N,
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.
Unchecked_Convert_To (T,
Make_Explicit_Dereference (Loc,
New_Reference_To (Temp, Loc))),
Typ => T,
Flist_Ref => Flist,
With_Attach => Attach));
end if;
end;
end if;
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Aggr_In_Place then
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Tmp_Node :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Reference_To (PtrT, Loc),
Expression => Make_Allocator (Loc,
New_Reference_To (Etype (Exp), Loc)));
Set_Comes_From_Source
(Expression (Tmp_Node), Comes_From_Source (N));
Set_No_Initialization (Expression (Tmp_Node));
Insert_Action (N, Tmp_Node);
Convert_Aggr_In_Allocator (Tmp_Node, Exp);
Rewrite (N, New_Reference_To (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
elsif Is_Access_Type (Designated_Type (PtrT))
and then Nkind (Exp) = N_Allocator
and then Nkind (Expression (Exp)) /= N_Qualified_Expression
then
-- Apply constraint to designated subtype indication.
Apply_Constraint_Check (Expression (Exp),
Designated_Type (Designated_Type (PtrT)),
No_Sliding => True);
if Nkind (Expression (Exp)) = N_Raise_Constraint_Error then
-- Propagate constraint_error to enclosing allocator
Rewrite (Exp, New_Copy (Expression (Exp)));
end if;
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.
-- ???
--
-- 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).
if Is_Constrained (Designated_Type (PtrT))
and then not Subtypes_Statically_Match
(T, Designated_Type (PtrT))
then
Apply_Constraint_Check
(Exp, Designated_Type (PtrT), 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.
else
Apply_Constraint_Check
(Exp, Designated_Type (PtrT), No_Sliding => True);
end if;
end if;
exception
when RE_Not_Available =>
return;
end Expand_Allocator_Expression;
-----------------------------
-- 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:
-- [body for greater_nn; boolean_expression]
-- The body is built by Make_Array_Comparison_Op, and the form of the
-- Boolean expression depends on the operator involved.
procedure Expand_Array_Comparison (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Op1 : Node_Id := Left_Opnd (N);
Op2 : Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
Ctyp : constant Entity_Id := Component_Type (Typ1);
Expr : Node_Id;
Func_Body : Node_Id;
Func_Name : Entity_Id;
Comp : RE_Id;
Byte_Addressable : constant Boolean := System_Storage_Unit = Byte'Size;
-- 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.
------------------------
-- Length_Less_Than_4 --
------------------------
function Length_Less_Than_4 (Opnd : Node_Id) return Boolean is
Otyp : constant Entity_Id := Etype (Opnd);
begin
if Ekind (Otyp) = E_String_Literal_Subtype then
return String_Literal_Length (Otyp) < 4;
else
declare
Ityp : constant Entity_Id := Etype (First_Index (Otyp));
Lo : constant Node_Id := Type_Low_Bound (Ityp);
Hi : constant Node_Id := Type_High_Bound (Ityp);
Lov : Uint;
Hiv : Uint;
begin
if Compile_Time_Known_Value (Lo) then
Lov := Expr_Value (Lo);
else
return False;
end if;
if Compile_Time_Known_Value (Hi) then
Hiv := Expr_Value (Hi);
else
return False;
end if;
return Hiv < Lov + 3;
end;
end if;
end Length_Less_Than_4;
-- Start of processing for Expand_Array_Comparison
begin
-- Deal first with unpacked case, where we can call a runtime routine
-- except that we avoid this for targets for which are not addressable
-- by bytes, and for the JVM, since the JVM does not support direct
-- addressing of array components.
if not Is_Bit_Packed_Array (Typ1)
and then Byte_Addressable
and then not Java_VM
then
-- The call we generate is:
-- Compare_Array_xn[_Unaligned]
-- (left'address, right'address, left'length, right'length) <op> 0
-- x = U for unsigned, S for signed
-- n = 8,16,32,64 for component size
-- Add _Unaligned if length < 4 and component size is 8.
-- <op> is the standard comparison operator
if Component_Size (Typ1) = 8 then
if Length_Less_Than_4 (Op1)
or else
Length_Less_Than_4 (Op2)
then
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U8_Unaligned;
else
Comp := RE_Compare_Array_S8_Unaligned;
end if;
else
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U8;
else
Comp := RE_Compare_Array_S8;
end if;
end if;
elsif Component_Size (Typ1) = 16 then
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U16;
else
Comp := RE_Compare_Array_S16;
end if;
elsif Component_Size (Typ1) = 32 then
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U32;
else
Comp := RE_Compare_Array_S32;
end if;
else pragma Assert (Component_Size (Typ1) = 64);
if Is_Unsigned_Type (Ctyp) then
Comp := RE_Compare_Array_U64;
else
Comp := RE_Compare_Array_S64;
end if;
end if;
Remove_Side_Effects (Op1, Name_Req => True);
Remove_Side_Effects (Op2, Name_Req => True);
Rewrite (Op1,
Make_Function_Call (Sloc (Op1),
Name => New_Occurrence_Of (RTE (Comp), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Op1),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Op2),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Op1),
Attribute_Name => Name_Length),
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Op2),
Attribute_Name => Name_Length))));
Rewrite (Op2,
Make_Integer_Literal (Sloc (Op2),
Intval => Uint_0));
Analyze_And_Resolve (Op1, Standard_Integer);
Analyze_And_Resolve (Op2, Standard_Integer);
return;
end if;
-- Cases where we cannot make runtime call
-- For (a <= b) we convert to not (a > b)
if Chars (N) = Name_Op_Le then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Gt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
-- For < the Boolean expression is
-- greater__nn (op2, op1)
elsif Chars (N) = Name_Op_Lt then
Func_Body := Make_Array_Comparison_Op (Typ1, N);
-- Switch operands
Op1 := Right_Opnd (N);
Op2 := Left_Opnd (N);
-- For (a >= b) we convert to not (a < b)
elsif Chars (N) = Name_Op_Ge then
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_Op_Lt (Loc,
Left_Opnd => Op1,
Right_Opnd => Op2)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
-- For > the Boolean expression is
-- greater__nn (op1, op2)
else
pragma Assert (Chars (N) = Name_Op_Gt);
Func_Body := Make_Array_Comparison_Op (Typ1, N);
end if;
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Expr :=
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => New_List (Op1, Op2));
Insert_Action (N, Func_Body);
Rewrite (N, Expr);
Analyze_And_Resolve (N, Standard_Boolean);
exception
when RE_Not_Available =>
return;
end Expand_Array_Comparison;
---------------------------
-- Expand_Array_Equality --
---------------------------
-- Expand an equality function for multi-dimensional arrays. Here is
-- an example of such a function for Nb_Dimension = 2
-- function Enn (A : arr; B : arr) return boolean is
-- begin
-- if (A'length (1) = 0 or else A'length (2) = 0)
-- and then
-- (B'length (1) = 0 or else B'length (2) = 0)
-- then
-- return True; -- RM 4.5.2(22)
-- end if;
--
-- if A'length (1) /= B'length (1)
-- or else
-- A'length (2) /= B'length (2)
-- then
-- return False; -- RM 4.5.2(23)
-- end if;
--
-- declare
-- A1 : Index_type_1 := A'first (1)
-- B1 : Index_Type_1 := B'first (1)
-- begin
-- loop
-- declare
-- A2 : Index_type_2 := A'first (2);
-- B2 : Index_type_2 := B'first (2)
-- begin
-- loop
-- if A (A1, A2) /= B (B1, B2) then
-- return False;
-- end if;
--
-- exit when A2 = A'last (2);
-- A2 := Index_type2'succ (A2);
-- B2 := Index_type2'succ (B2);
-- end loop;
-- end;
--
-- exit when A1 = A'last (1);
-- A1 := Index_type1'succ (A1);
-- B1 := Index_type1'succ (B1);
-- end loop;
-- end;
--
-- return true;
-- end Enn;
function Expand_Array_Equality
(Nod : Node_Id;
Typ : Entity_Id;
A_Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Decls : constant List_Id := New_List;
Index_List1 : constant List_Id := New_List;
Index_List2 : constant List_Id := New_List;
Actuals : List_Id;
Formals : List_Id;
Func_Name : Entity_Id;
Func_Body : Node_Id;
A : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uA);
B : constant Entity_Id := Make_Defining_Identifier (Loc, Name_uB);
function Arr_Attr
(Arr : Entity_Id;
Nam : Name_Id;
Num : Int)
return Node_Id;
-- 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.
function Handle_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id;
-- This procedure returns a declare block:
--
-- declare
-- An : Index_Type_n := A'First (n);
-- Bn : Index_Type_n := B'First (n);
-- begin
-- loop
-- xxx
-- exit when An = A'Last (n);
-- An := Index_Type_n'Succ (An)
-- Bn := Index_Type_n'Succ (Bn)
-- end loop;
-- end;
--
-- where N is the value of "n" in the above code. Index is the
-- N'th index node, whose Etype is Index_Type_n in the above code.
-- The xxx statement is either the declare block 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!
function Test_Empty_Arrays return Node_Id;
-- This function constructs the test for both arrays being empty
-- (A'length (1) = 0 or else A'length (2) = 0 or else ...)
-- and then
-- (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
-- A'length (1) /= B'length (1)
-- or else
-- A'length (2) /= B'length (2)
-- or else
-- ...
--------------
-- Arr_Attr --
--------------
function Arr_Attr
(Arr : Entity_Id;
Nam : Name_Id;
Num : Int)
return Node_Id
is
begin
return
Make_Attribute_Reference (Loc,
Attribute_Name => Nam,
Prefix => New_Reference_To (Arr, Loc),
Expressions => New_List (Make_Integer_Literal (Loc, Num)));
end Arr_Attr;
------------------------
-- Component_Equality --
------------------------
function Component_Equality (Typ : Entity_Id) return Node_Id is
Test : Node_Id;
L, R : Node_Id;
begin
-- if a(i1...) /= b(j1...) then return false; end if;
L :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (A)),
Expressions => Index_List1);
R :=
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Chars (B)),
Expressions => Index_List2);
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
return
Make_Implicit_If_Statement (Nod,
Condition => Make_Op_Not (Loc, Right_Opnd => Test),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_False, Loc))));
end Component_Equality;
--------------------------
-- Handle_One_Dimension --
---------------------------
function Handle_One_Dimension
(N : Int;
Index : Node_Id)
return Node_Id
is
An : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
Bn : constant Entity_Id := Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('B'));
Index_Type_n : Entity_Id;
begin
if N > Number_Dimensions (Typ) then
return Component_Equality (Typ);
end if;
-- Case where we generate a declare block
Index_Type_n := Base_Type (Etype (Index));
Append (New_Reference_To (An, Loc), Index_List1);
Append (New_Reference_To (Bn, Loc), Index_List2);
return
Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => An,
Object_Definition =>
New_Reference_To (Index_Type_n, Loc),
Expression => Arr_Attr (A, Name_First, N)),
Make_Object_Declaration (Loc,
Defining_Identifier => Bn,
Object_Definition =>
New_Reference_To (Index_Type_n, Loc),
Expression => Arr_Attr (B, Name_First, N))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_Loop_Statement (Nod,
Statements => New_List (
Handle_One_Dimension (N + 1, Next_Index (Index)),
Make_Exit_Statement (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Reference_To (An, Loc),
Right_Opnd => Arr_Attr (A, Name_Last, N))),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (An, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Index_Type_n, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (An, Loc)))),
Make_Assignment_Statement (Loc,
Name => New_Reference_To (Bn, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Reference_To (Index_Type_n, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (
New_Reference_To (Bn, Loc)))))))));
end Handle_One_Dimension;
-----------------------
-- Test_Empty_Arrays --
-----------------------
function Test_Empty_Arrays return Node_Id is
Alist : Node_Id;
Blist : Node_Id;
Atest : Node_Id;
Btest : Node_Id;
begin
Alist := Empty;
Blist := Empty;
for J in 1 .. Number_Dimensions (Typ) loop
Atest :=
Make_Op_Eq (Loc,
Left_Opnd => Arr_Attr (A, Name_Length, J),
Right_Opnd => Make_Integer_Literal (Loc, 0));
Btest :=
Make_Op_Eq (Loc,
Left_Opnd => Arr_Attr (B, Name_Length, J),
Right_Opnd => Make_Integer_Literal (Loc, 0));
if No (Alist) then
Alist := Atest;
Blist := Btest;
else
Alist :=
Make_Or_Else (Loc,
Left_Opnd => Relocate_Node (Alist),
Right_Opnd => Atest);
Blist :=
Make_Or_Else (Loc,
Left_Opnd => Relocate_Node (Blist),
Right_Opnd => Btest);
end if;
end loop;
return
Make_And_Then (Loc,
Left_Opnd => Alist,
Right_Opnd => Blist);
end Test_Empty_Arrays;
-----------------------------
-- Test_Lengths_Correspond --
-----------------------------
function Test_Lengths_Correspond return Node_Id is
Result : Node_Id;
Rtest : Node_Id;
begin
Result := Empty;
for J in 1 .. Number_Dimensions (Typ) loop
Rtest :=
Make_Op_Ne (Loc,
Left_Opnd => Arr_Attr (A, Name_Length, J),
Right_Opnd => Arr_Attr (B, Name_Length, J));
if No (Result) then
Result := Rtest;
else
Result :=
Make_Or_Else (Loc,
Left_Opnd => Relocate_Node (Result),
Right_Opnd => Rtest);
end if;
end loop;
return Result;
end Test_Lengths_Correspond;
-- Start of processing for Expand_Array_Equality
begin
Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type => New_Reference_To (Typ, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type => New_Reference_To (Typ, Loc)));
Func_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
-- Build statement sequence for function
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Name,
Parameter_Specifications => Formals,
Subtype_Mark => New_Reference_To (Standard_Boolean, Loc)),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Implicit_If_Statement (Nod,
Condition => Test_Empty_Arrays,
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_True, Loc)))),
Make_Implicit_If_Statement (Nod,
Condition => Test_Lengths_Correspond,
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Standard_False, Loc)))),
Handle_One_Dimension (1, First_Index (Typ)),
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)))));
Set_Has_Completion (Func_Name, True);
-- 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 Base_Type (A_Typ) /= Base_Type (Typ) then
Actuals := New_List (
OK_Convert_To (Typ, Lhs),
OK_Convert_To (Typ, Rhs));
else
Actuals := New_List (Lhs, Rhs);
end if;
Append_To (Bodies, Func_Body);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations => Actuals);
end Expand_Array_Equality;
-----------------------------
-- 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.
procedure Expand_Boolean_Operator (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
if Is_Bit_Packed_Array (Typ) then
Expand_Packed_Boolean_Operator (N);
else
-- For the normal non-packed case, the general expansion is
-- to build a function for carrying out the comparison (using
-- Make_Boolean_Array_Op) and then inserting it into the tree.
-- The original operator node is then rewritten as a call to
-- this function.
declare
Loc : constant Source_Ptr := Sloc (N);
L : constant Node_Id := Relocate_Node (Left_Opnd (N));
R : constant Node_Id := Relocate_Node (Right_Opnd (N));
Func_Body : Node_Id;
Func_Name : Entity_Id;
begin
Convert_To_Actual_Subtype (L);
Convert_To_Actual_Subtype (R);
Ensure_Defined (Etype (L), N);
Ensure_Defined (Etype (R), N);
Apply_Length_Check (R, Etype (L));
if Nkind (Parent (N)) = N_Assignment_Statement
and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
then
Build_Boolean_Array_Proc_Call (Parent (N), L, R);
elsif Nkind (Parent (N)) = N_Op_Not
and then Nkind (N) = N_Op_And
and then
Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
then
return;
else
Func_Body := Make_Boolean_Array_Op (Etype (L), N);
Func_Name := Defining_Unit_Name (Specification (Func_Body));
Insert_Action (N, Func_Body);
-- Now rewrite the expression with a call
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Func_Name, Loc),
Parameter_Associations =>
New_List
(L, Make_Type_Conversion
(Loc, New_Reference_To (Etype (L), Loc), R))));
Analyze_And_Resolve (N, Typ);
end if;
end;
end if;
end Expand_Boolean_Operator;
-------------------------------
-- Expand_Composite_Equality --
-------------------------------
-- This function is only called for comparing internal fields of composite
-- types when these fields are themselves composites. This is a special
-- case because it is not possible to respect normal Ada visibility rules.
function Expand_Composite_Equality
(Nod : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Rhs : Node_Id;
Bodies : List_Id)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Nod);
Full_Type : Entity_Id;
Prim : Elmt_Id;
Eq_Op : Entity_Id;
begin
if Is_Private_Type (Typ) then
Full_Type := Underlying_Type (Typ);
else
Full_Type := Typ;
end if;
-- 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);
end if;
Full_Type := Base_Type (Full_Type);
if Is_Array_Type (Full_Type) then
-- If the operand is an elementary type other than a floating-point
-- type, then we can simply use the built-in block bitwise equality,
-- since the predefined equality operators always apply and bitwise
-- equality is fine for all these cases.
if Is_Elementary_Type (Component_Type (Full_Type))
and then not Is_Floating_Point_Type (Component_Type (Full_Type))
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.
else
return Expand_Array_Equality
(Nod, Full_Type, Typ, Lhs, Rhs, Bodies);
end if;
elsif Is_Tagged_Type (Full_Type) then
-- Call the primitive operation "=" of this type
if Is_Class_Wide_Type (Full_Type) then
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 Is_Private_Type (Typ)
and then not Is_Tagged_Type (Typ)
and then not Is_Controlled (Typ)
and then Is_Derived_Type (Typ)
and then No (Full_View (Typ))
then
Prim := First_Elmt (Collect_Primitive_Operations (Typ));
else
Prim := First_Elmt (Primitive_Operations (Full_Type));
end if;
loop
Eq_Op := Node (Prim);
exit when Chars (Eq_Op) = Name_Op_Eq
and then Etype (First_Formal (Eq_Op)) =
Etype (Next_Formal (First_Formal (Eq_Op)));
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Eq_Op := Node (Prim);
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List
(Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Lhs),
Unchecked_Convert_To (Etype (First_Formal (Eq_Op)), Rhs)));
elsif Is_Record_Type (Full_Type) then
Eq_Op := TSS (Full_Type, TSS_Composite_Equality);
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.
declare
T : constant Entity_Id := Etype (First_Formal (Eq_Op));
begin
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations =>
New_List (OK_Convert_To (T, Lhs),
OK_Convert_To (T, Rhs)));
end;
else
return
Make_Function_Call (Loc,
Name => New_Reference_To (Eq_Op, Loc),
Parameter_Associations => New_List (Lhs, Rhs));
end if;
else
return Expand_Record_Equality (Nod, Full_Type, Lhs, Rhs, Bodies);
end if;
else
-- It can be a simple record or the full view of a scalar private
return Make_Op_Eq (Loc, Left_Opnd => Lhs, Right_Opnd => Rhs);
end if;
end Expand_Composite_Equality;
------------------------------
-- 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 concatenantion operator applies, then the
-- following subprogram is constructed:
-- [function Cnn (S1 : Base_Typ; ...; Sn : Base_Typ) return Base_Typ is
-- L : Ind_Typ;
-- begin
-- if S1'Length /= 0 then
-- L := XXX; --> XXX = S1'First if Arr_Typ is unconstrained
-- XXX = Arr_Typ'First otherwise
-- elsif S2'Length /= 0 then
-- L := YYY; --> YYY = S2'First if Arr_Typ is unconstrained
-- YYY = Arr_Typ'First otherwise
-- ...
-- elsif Sn-1'Length /= 0 then
-- L := ZZZ; --> ZZZ = Sn-1'First if Arr_Typ is unconstrained
-- ZZZ = Arr_Typ'First otherwise
-- else
-- return Sn;
-- end if;
-- declare
-- P : Ind_Typ;
-- H : Ind_Typ :=
-- Ind_Typ'Val ((((S1'Length - 1) + S2'Length) + ... + Sn'Length)
-- + Ind_Typ'Pos (L));
-- R : Base_Typ (L .. H);
-- begin
-- if S1'Length /= 0 then
-- P := S1'First;
-- loop
-- R (L) := S1 (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = S1'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
--
-- if S2'Length /= 0 then
-- L := Ind_Typ'Succ (L);
-- loop
-- R (L) := S2 (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = S2'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
-- ...
-- if Sn'Length /= 0 then
-- P := Sn'First;
-- loop
-- R (L) := Sn (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = Sn'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
-- end if;
-- return R;
-- end;
-- end Cnn;]
procedure Expand_Concatenate_Other (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Nb_Opnds : constant Nat := List_Length (Opnds);
Arr_Typ : constant Entity_Id := Etype (Entity (Cnode));
Base_Typ : constant Entity_Id := Base_Type (Etype (Cnode));
Ind_Typ : constant Entity_Id := Etype (First_Index (Base_Typ));
Func_Id : Node_Id;
Func_Spec : Node_Id;
Param_Specs : List_Id;
Func_Body : Node_Id;
Func_Decls : List_Id;
Func_Stmts : List_Id;
L_Decl : Node_Id;
If_Stmt : Node_Id;
Elsif_List : List_Id;
Declare_Block : Node_Id;
Declare_Decls : List_Id;
Declare_Stmts : List_Id;
H_Decl : Node_Id;
H_Init : Node_Id;
P_Decl : Node_Id;
R_Decl : Node_Id;
R_Constr : Node_Id;
R_Range : Node_Id;
Params : List_Id;
Operand : Node_Id;
function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id;
-- Builds the sequence of statement:
-- P := Si'First;
-- loop
-- R (L) := Si (P);
-- L := Ind_Typ'Succ (L);
-- exit when P = Si'Last;
-- P := Ind_Typ'Succ (P);
-- end loop;
--
-- where i is the input parameter I given.
-- If the flag Last is true, the exit statement is emitted before
-- incrementing the lower bound, to prevent the creation out of
-- bound values.
function Init_L (I : Nat) return Node_Id;
-- Builds the statement:
-- L := Arr_Typ'First; If Arr_Typ is constrained
-- L := Si'First; otherwise (where I is the input param given)
function H return Node_Id;
-- Builds reference to identifier H.
function Ind_Val (E : Node_Id) return Node_Id;
-- Builds expression Ind_Typ'Val (E);
function L return Node_Id;
-- Builds reference to identifier L.
function L_Pos return Node_Id;
-- Builds expression Integer_Type'(Ind_Typ'Pos (L)).
-- We qualify the expression to avoid universal_integer computations
-- whenever possible, in the expression for the upper bound H.
function L_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (L).
function One return Node_Id;
-- Builds integer literal one.
function P return Node_Id;
-- Builds reference to identifier P.
function P_Succ return Node_Id;
-- Builds expression Ind_Typ'Succ (P).
function R return Node_Id;
-- Builds reference to identifier R.
function S (I : Nat) return Node_Id;
-- Builds reference to identifier Si, where I is the value given.
function S_First (I : Nat) return Node_Id;
-- Builds expression Si'First, where I is the value given.
function S_Last (I : Nat) return Node_Id;
-- Builds expression Si'Last, where I is the value given.
function S_Length (I : Nat) return Node_Id;
-- Builds expression Si'Length, where I is the value given.
function S_Length_Test (I : Nat) return Node_Id;
-- Builds expression Si'Length /= 0, where I is the value given.
-------------------
-- Copy_Into_R_S --
-------------------
function Copy_Into_R_S (I : Nat; Last : Boolean) return List_Id is
Stmts : constant List_Id := New_List;
P_Start : Node_Id;
Loop_Stmt : Node_Id;
R_Copy : Node_Id;
Exit_Stmt : Node_Id;
L_Inc : Node_Id;
P_Inc : Node_Id;
begin
-- First construct the initializations
P_Start := Make_Assignment_Statement (Loc,
Name => P,
Expression => S_First (I));
Append_To (Stmts, P_Start);
-- Then build the loop
R_Copy := Make_Assignment_Statement (Loc,
Name => Make_Indexed_Component (Loc,
Prefix => R,
Expressions => New_List (L)),
Expression => Make_Indexed_Component (Loc,
Prefix => S (I),
Expressions => New_List (P)));
L_Inc := Make_Assignment_Statement (Loc,
Name => L,
Expression => L_Succ);
Exit_Stmt := Make_Exit_Statement (Loc,
Condition => Make_Op_Eq (Loc, P, S_Last (I)));
P_Inc := Make_Assignment_Statement (Loc,
Name => P,
Expression => P_Succ);
if Last then
Loop_Stmt :=
Make_Implicit_Loop_Statement (Cnode,
Statements => New_List (R_Copy, Exit_Stmt, L_Inc, P_Inc));
else
Loop_Stmt :=
Make_Implicit_Loop_Statement (Cnode,
Statements => New_List (R_Copy, L_Inc, Exit_Stmt, P_Inc));
end if;
Append_To (Stmts, Loop_Stmt);
return Stmts;
end Copy_Into_R_S;
-------
-- H --
-------
function H return Node_Id is
begin
return Make_Identifier (Loc, Name_uH);
end H;
-------------
-- Ind_Val --
-------------
function Ind_Val (E : Node_Id) return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (E));
end Ind_Val;
------------
-- Init_L --
------------
function Init_L (I : Nat) return Node_Id is
E : Node_Id;
begin
if Is_Constrained (Arr_Typ) then
E := Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Arr_Typ, Loc),
Attribute_Name => Name_First);
else
E := S_First (I);
end if;
return Make_Assignment_Statement (Loc, Name => L, Expression => E);
end Init_L;
-------
-- L --
-------
function L return Node_Id is
begin
return Make_Identifier (Loc, Name_uL);
end L;
-----------
-- L_Pos --
-----------
function L_Pos return Node_Id 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 Is_Enumeration_Type (Ind_Typ)
or else Root_Type (Ind_Typ) = Standard_Integer
or else Root_Type (Ind_Typ) = Standard_Short_Integer
or else Root_Type (Ind_Typ) = Standard_Short_Short_Integer
then
Target_Type := Standard_Integer;
else
Target_Type := Root_Type (Ind_Typ);
end if;
return
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Reference_To (Target_Type, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Pos,
Expressions => New_List (L)));
end L_Pos;
------------
-- L_Succ --
------------
function L_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (L));
end L_Succ;
---------
-- One --
---------
function One return Node_Id is
begin
return Make_Integer_Literal (Loc, 1);
end One;
-------
-- P --
-------
function P return Node_Id is
begin
return Make_Identifier (Loc, Name_uP);
end P;
------------
-- P_Succ --
------------
function P_Succ return Node_Id is
begin
return
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Ind_Typ, Loc),
Attribute_Name => Name_Succ,
Expressions => New_List (P));
end P_Succ;
-------
-- R --
-------
function R return Node_Id is
begin
return Make_Identifier (Loc, Name_uR);
end R;
-------
-- S --
-------
function S (I : Nat) return Node_Id is
begin
return Make_Identifier (Loc, New_External_Name ('S', I));
end S;
-------------
-- S_First --
-------------
function S_First (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_First);
end S_First;
------------
-- S_Last --
------------
function S_Last (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Last);
end S_Last;
--------------
-- S_Length --
--------------
function S_Length (I : Nat) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix => S (I),
Attribute_Name => Name_Length);
end S_Length;
-------------------
-- S_Length_Test --
-------------------
function S_Length_Test (I : Nat) return Node_Id is
begin
return
Make_Op_Ne (Loc,
Left_Opnd => S_Length (I),
Right_Opnd => Make_Integer_Literal (Loc, 0));
end S_Length_Test;
-- Start of processing for Expand_Concatenate_Other
begin
-- Construct the parameter specs and the overall function spec
Param_Specs := New_List;
for I in 1 .. Nb_Opnds loop
Append_To
(Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_External_Name ('S', I)),
Parameter_Type => New_Reference_To (Base_Typ, Loc)));
end loop;
Func_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Func_Id,
Parameter_Specifications => Param_Specs,
Subtype_Mark => New_Reference_To (Base_Typ, Loc));
-- Construct L's object declaration
L_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uL),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
Func_Decls := New_List (L_Decl);
-- Construct the if-then-elsif statements
Elsif_List := New_List;
for I in 2 .. Nb_Opnds - 1 loop
Append_To (Elsif_List, Make_Elsif_Part (Loc,
Condition => S_Length_Test (I),
Then_Statements => New_List (Init_L (I))));
end loop;
If_Stmt :=
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (1),
Then_Statements => New_List (Init_L (1)),
Elsif_Parts => Elsif_List,
Else_Statements => New_List (Make_Return_Statement (Loc,
Expression => S (Nb_Opnds))));
-- Construct the declaration for H
P_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uP),
Object_Definition => New_Reference_To (Ind_Typ, Loc));
H_Init := Make_Op_Subtract (Loc, S_Length (1), One);
for I in 2 .. Nb_Opnds loop
H_Init := Make_Op_Add (Loc, H_Init, S_Length (I));
end loop;
H_Init := Ind_Val (Make_Op_Add (Loc, H_Init, L_Pos));
H_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uH),
Object_Definition => New_Reference_To (Ind_Typ, Loc),
Expression => H_Init);
-- Construct the declaration for R
R_Range := Make_Range (Loc, Low_Bound => L, High_Bound => H);
R_Constr :=
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (R_Range));
R_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_uR),
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Reference_To (Base_Typ, Loc),
Constraint => R_Constr));
-- Construct the declarations for the declare block
Declare_Decls := New_List (P_Decl, H_Decl, R_Decl);
-- Construct list of statements for the declare block
Declare_Stmts := New_List;
for I in 1 .. Nb_Opnds loop
Append_To (Declare_Stmts,
Make_Implicit_If_Statement (Cnode,
Condition => S_Length_Test (I),
Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds)));
end loop;
Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R));
-- Construct the declare block
Declare_Block := Make_Block_Statement (Loc,
Declarations => Declare_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Declare_Stmts));
-- Construct the list of function statements
Func_Stmts := New_List (If_Stmt, Declare_Block);
-- Construct the function body
Func_Body :=
Make_Subprogram_Body (Loc,
Specification => Func_Spec,
Declarations => Func_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Func_Stmts));
-- Insert the newly generated function in the code. This is analyzed
-- with all checks off, since we have completed all the checks.
-- Note that this does *not* fix the array concatenation bug when the
-- low bound is Integer'first sibce that bug comes from the pointer
-- dereferencing an unconstrained array. An there we need a constraint
-- check to make sure the length of the concatenated array is ok. ???
Insert_Action (Cnode, Func_Body, Suppress => All_Checks);
-- Construct list of arguments for the function call
Params := New_List;
Operand := First (Opnds);
for I in 1 .. Nb_Opnds loop
Append_To (Params, Relocate_Node (Operand));
Next (Operand);
end loop;
-- Insert the function call
Rewrite
(Cnode,
Make_Function_Call (Loc, New_Reference_To (Func_Id, Loc), Params));
Analyze_And_Resolve (Cnode, Base_Typ);
Set_Is_Inlined (Func_Id);
end Expand_Concatenate_Other;
-------------------------------
-- Expand_Concatenate_String --
-------------------------------
procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is
Loc : constant Source_Ptr := Sloc (Cnode);
Opnd1 : constant Node_Id := First (Opnds);
Opnd2 : constant Node_Id := Next (Opnd1);
Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1));
Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2));
R : RE_Id;
-- RE_Id value for function to be called
begin
-- In all cases, we build a call to a routine giving the list of
-- arguments as the parameter list to the routine.
case List_Length (Opnds) is
when 2 =>
if Typ1 = Standard_Character then
if Typ2 = Standard_Character then
R := RE_Str_Concat_CC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat_CS;
end if;
elsif Typ1 = Standard_String then
if Typ2 = Standard_Character then
R := RE_Str_Concat_SC;
else
pragma Assert (Typ2 = Standard_String);
R := RE_Str_Concat;
end if;
-- If we have anything other than Standard_Character or
-- Standard_String, then we must have had a serious error
-- earlier, so we just abandon the attempt at expansion.
else
pragma Assert (Serious_Errors_Detected > 0);
return;
end if;
when 3 =>
R := RE_Str_Concat_3;
when 4 =>
R := RE_Str_Concat_4;
when 5 =>
R := RE_Str_Concat_5;
when others =>
R := RE_Null;
raise Program_Error;
end case;
-- Now generate the appropriate call
Rewrite (Cnode,
Make_Function_Call (Sloc (Cnode),
Name => New_Occurrence_Of (RTE (R), Loc),
Parameter_Associations => Opnds));
Analyze_And_Resolve (Cnode, Standard_String);
exception
when RE_Not_Available =>
return;
end Expand_Concatenate_String;
------------------------
-- Expand_N_Allocator --
------------------------
procedure Expand_N_Allocator (N : Node_Id) is
PtrT : constant Entity_Id := Etype (N);
Desig : Entity_Id;
Loc : constant Source_Ptr := Sloc (N);
Temp : Entity_Id;
Node : Node_Id;
begin
-- RM E.2.3(22). We enforce that the expected type of an allocator
-- shall not be a remote access-to-class-wide-limited-private type
-- Why is this being done at expansion time, seems clearly wrong ???
Validate_Remote_Access_To_Class_Wide_Type (N);
-- Set the Storage Pool
Set_Storage_Pool (N, Associated_Storage_Pool (Root_Type (PtrT)));
if Present (Storage_Pool (N)) then
if Is_RTE (Storage_Pool (N), RE_SS_Pool) then
if not Java_VM then
Set_Procedure_To_Call (N, RTE (RE_SS_Allocate));
end if;
elsif Is_Class_Wide_Type (Etype (Storage_Pool (N))) then
Set_Procedure_To_Call (N, RTE (RE_Allocate_Any));
else
Set_Procedure_To_Call (N,
Find_Prim_Op (Etype (Storage_Pool (N)), Name_Allocate));
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:
-- Size and initial value is known at compile time
-- Access type is access-to-constant
-- The allocator is not part of a constraint on a record component,
-- because in that case the inserted actions are delayed until the
-- record declaration is fully analyzed, which is too late for the
-- analysis of the rewritten allocator.
if Is_Access_Constant (PtrT)
and then Nkind (Expression (N)) = N_Qualified_Expression
and then Compile_Time_Known_Value (Expression (Expression (N)))
and then Size_Known_At_Compile_Time (Etype (Expression
(Expression (N))))
and then not Is_Record_Type (Current_Scope)
then
-- Here we can do the optimization. For the allocator
-- new x'(y)
-- We insert an object declaration
-- Tnn : aliased x := y;
-- and replace the allocator by Tnn'Unrestricted_Access.
-- Tnn is marked as requiring static allocation.
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Desig := Subtype_Mark (Expression (N));
-- If context is constrained, use constrained subtype directly,
-- so that the constant is not labelled as having a nomimally
-- unconstrained subtype.
if Entity (Desig) = Base_Type (Designated_Type (PtrT)) then
Desig := New_Occurrence_Of (Designated_Type (PtrT), Loc);
end if;
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Aliased_Present => True,
Constant_Present => Is_Access_Constant (PtrT),
Object_Definition => Desig,
Expression => Expression (Expression (N))));
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Temp, Loc),
Attribute_Name => Name_Unrestricted_Access));
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!
Set_Is_Statically_Allocated (Temp);
return;
end if;
if Nkind (Expression (N)) = N_Qualified_Expression then
Expand_Allocator_Expression (N);
-- 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 qualifed expression), then we must generate a call
-- to the initialization routine. This is done using an expression
-- actions node:
--
-- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
--
-- Here ptr_T is the pointer type for the allocator, and T is the
-- subtype of the allocator. A special case arises if the designated
-- type of the access type is a task or contains tasks. In this case
-- the call to Init (Temp.all ...) is replaced by code that ensures
-- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
-- for details). In addition, if the type T is a task T, then the
-- first argument to Init must be converted to the task record type.
else
declare
T : constant Entity_Id := Entity (Expression (N));
Init : Entity_Id;
Arg1 : Node_Id;
Args : List_Id;
Decls : List_Id;
Decl : Node_Id;
Discr : Elmt_Id;
Flist : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
begin
if No_Initialization (N) then
null;
-- Case of no initialization procedure present
elsif not Has_Non_Null_Base_Init_Proc (T) then
-- Case of simple initialization required
if Needs_Simple_Initialization (T) then
Rewrite (Expression (N),
Make_Qualified_Expression (Loc,
Subtype_Mark => New_Occurrence_Of (T, Loc),
Expression => Get_Simple_Init_Val (T, Loc)));
Analyze_And_Resolve (Expression (Expression (N)), T);
Analyze_And_Resolve (Expression (N), T);
Set_Paren_Count (Expression (Expression (N)), 1);
Expand_N_Allocator (N);
-- No initialization required
else
null;
end if;
-- Case of initialization procedure present, must be called
else
Init := Base_Init_Proc (T);
Node := N;
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-- Construct argument list for the initialization routine call
-- The CPP constructor needs the address directly
if Is_CPP_Class (T) then
Arg1 := New_Reference_To (Temp, Loc);
Temp_Type := T;
else
Arg1 :=
Make_Explicit_Dereference (Loc,
Prefix => New_Reference_To (Temp, Loc));
Set_Assignment_OK (Arg1);
Temp_Type := PtrT;
-- The initialization procedure expects a specific type.
-- if the context is access to class wide, indicate that
-- the object being allocated has the right specific type.
if Is_Class_Wide_Type (Designated_Type (PtrT)) then
Arg1 := Unchecked_Convert_To (T, Arg1);
end if;
end if;
-- If designated type is a concurrent type or if it is a
-- private type whose definition is a concurrent type,
-- the first argument in the Init routine has to be
-- unchecked conversion to the corresponding record type.
-- If the designated type is a derived type, we also
-- convert the argument to its root type.
if Is_Concurrent_Type (T) then
Arg1 :=
Unchecked_Convert_To (Corresponding_Record_Type (T), Arg1);
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Is_Concurrent_Type (Full_View (T))
then
Arg1 :=
Unchecked_Convert_To
(Corresponding_Record_Type (Full_View (T)), Arg1);
elsif Etype (First_Formal (Init)) /= Base_Type (T) then
declare
Ftyp : constant Entity_Id := Etype (First_Formal (Init));
begin
Arg1 := OK_Convert_To (Etype (Ftyp), Arg1);
Set_Etype (Arg1, Ftyp);
end;
end if;
Args := New_List (Arg1);
-- For the task case, pass the Master_Id of the access type
-- as the value of the _Master parameter, and _Chain as the
-- value of the _Chain parameter (_Chain will be defined as
-- part of the generated code for the allocator).
if Has_Task (T) then
if No (Master_Id (Base_Type (PtrT))) then
-- The designated type was an incomplete type, and
-- the access type did not get expanded. Salvage
-- it now.
Expand_N_Full_Type_Declaration
(Parent (Base_Type (PtrT)));
end if;
-- If the context of the allocator is a declaration or
-- an assignment, we can generate a meaningful image for
-- it, even though subsequent assignments might remove
-- the connection between task and entity. We build this
-- image when the left-hand side is a simple variable,
-- a simple indexed assignment or a simple selected
-- component.
if Nkind (Parent (N)) = N_Assignment_Statement then
declare
Nam : constant Node_Id := Name (Parent (N));
begin
if Is_Entity_Name (Nam) then
Decls :=
Build_Task_Image_Decls (
Loc,
New_Occurrence_Of
(Entity (Nam), Sloc (Nam)), T);
elsif (Nkind (Nam) = N_Indexed_Component
or else Nkind (Nam) = N_Selected_Component)
and then Is_Entity_Name (Prefix (Nam))
then
Decls :=
Build_Task_Image_Decls
(Loc, Nam, Etype (Prefix (Nam)));
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
end;
elsif Nkind (Parent (N)) = N_Object_Declaration then
Decls :=
Build_Task_Image_Decls (
Loc, Defining_Identifier (Parent (N)), T);
else
Decls := Build_Task_Image_Decls (Loc, T, T);
end if;
Append_To (Args,
New_Reference_To
(Master_Id (Base_Type (Root_Type (PtrT))), Loc));
Append_To (Args, Make_Identifier (Loc, Name_uChain));
Decl := Last (Decls);
Append_To (Args,
New_Occurrence_Of (Defining_Identifier (Decl), Loc));
-- Has_Task is false, Decls not used
else
Decls := No_List;
end if;
-- Add discriminants if discriminated type
if Has_Discriminants (T) then
Discr := First_Elmt (Discriminant_Constraint (T));
while Present (Discr) loop
Append (New_Copy_Tree (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
elsif Is_Private_Type (T)
and then Present (Full_View (T))
and then Has_Discriminants (Full_View (T))
then
Discr :=
First_Elmt (Discriminant_Constraint (Full_View (T)));
while Present (Discr) loop
Append (New_Copy_Tree (Elists.Node (Discr)), Args);
Next_Elmt (Discr);
end loop;
end if;
-- We set the allocator as analyzed so that when we analyze the
-- expression actions node, we do not get an unwanted recursive
-- expansion of the allocator expression.
Set_Analyzed (N, True);
Node := Relocate_Node (N);
-- Here is the transformation:
-- input: new T
-- output: Temp : constant ptr_T := new T;
-- Init (Temp.all, ...);
-- <CTRL> Attach_To_Final_List (Finalizable (Temp.all));
-- <CTRL> Initialize (Finalizable (Temp.all));
-- Here ptr_T is the pointer type for the allocator, and T
-- is the subtype of the allocator.
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Temp_Type, Loc),
Expression => Node);
Set_Assignment_OK (Temp_Decl);
if Is_CPP_Class (T) then
Set_Aliased_Present (Temp_Decl);
end if;
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
-- If the designated type is task type or contains tasks,
-- Create block to activate created tasks, and insert
-- declaration for Task_Image variable ahead of call.
if Has_Task (T) then
declare
L : constant List_Id := New_List;
Blk : Node_Id;
begin
Build_Task_Allocate_Block (L, Node, Args);
Blk := Last (L);
Insert_List_Before (First (Declarations (Blk)), Decls);
Insert_Actions (N, L);
end;
else
Insert_Action (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (Init, Loc),
Parameter_Associations => Args));
end if;
if Controlled_Type (T) then
Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT);
Insert_Actions (N,
Make_Init_Call (
Ref => New_Copy_Tree (Arg1),
Typ => T,
Flist_Ref => Flist,
With_Attach => Make_Integer_Literal (Loc, 2)));
end if;
if Is_CPP_Class (T) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Reference_To (Temp, Loc),
Attribute_Name => Name_Unchecked_Access));
else
Rewrite (N, New_Reference_To (Temp, Loc));
end if;
Analyze_And_Resolve (N, PtrT);
end if;
end;
end if;
exception
when RE_Not_Available =>
return;
end Expand_N_Allocator;
-----------------------
-- Expand_N_And_Then --
-----------------------
-- Expand into conditional expression if Actions present, and also
-- deal with optimizing case of arguments being True or False.
procedure Expand_N_And_Then (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Actlist : List_Id;
begin
-- Deal with non-standard booleans
if Is_Boolean_Type (Typ) then
Adjust_Condition (Left);
Adjust_Condition (Right);
Set_Etype (N, Standard_Boolean);
end if;
-- Check for cases of left argument is True or False
if Nkind (Left) = N_Identifier then
-- If left argument is True, change (True and then Right) to Right.
-- Any actions associated with Right will be executed unconditionally
-- and can thus be inserted into the tree unconditionally.
if Entity (Left) = Standard_True then
if Present (Actions (N)) then
Insert_Actions (N, Actions (N));
end if;
Rewrite (N, Right);
Adjust_Result_Type (N, Typ);
return;
-- If left argument is False, change (False and then Right) to
-- False. In this case we can forget the actions associated with
-- Right, since they will never be executed.
elsif Entity (Left) = Standard_False then
Kill_Dead_Code (Right);
Kill_Dead_Code (Actions (N));
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Adjust_Result_Type (N, Typ);
return;
end if;
end if;
-- If Actions are present, we expand
-- left and then right
-- into
-- if left then right else false end
-- with the actions becoming the Then_Actions of the conditional
-- expression. This conditional expression is then further expanded
-- (and will eventually disappear)
if Present (Actions (N)) then
Actlist := Actions (N);
Rewrite (N,
Make_Conditional_Expression (Loc,
Expressions => New_List (
Left,
Right,
New_Occurrence_Of (Standard_False, Loc))));
Set_Then_Actions (N, Actlist);
Analyze_And_Resolve (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
return;
end if;
-- No actions present, check for cases of right argument True/False
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.
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.
elsif Entity (Right) = Standard_False then
Remove_Side_Effects (Left);
Rewrite
(N, New_Occurrence_Of (Standard_False, Loc));
end if;
end if;
Adjust_Result_Type (N, Typ);
end Expand_N_And_Then;
-------------------------------------
-- Expand_N_Conditional_Expression --
-------------------------------------
-- Expand into expression actions if then/else actions present
procedure Expand_N_Conditional_Expression (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Cond : constant Node_Id := First (Expressions (N));
Thenx : constant Node_Id := Next (Cond);
Elsex : constant Node_Id := Next (Thenx);
Typ : constant Entity_Id := Etype (N);
Cnn : Entity_Id;
New_If : Node_Id;
begin
-- If either then or else actions are present, then given:
-- if cond then then-expr else else-expr end
-- we insert the following sequence of actions (using Insert_Actions):
-- Cnn : typ;
-- if cond then
-- <<then actions>>
-- Cnn := then-expr;
-- else
-- <<else actions>>
-- Cnn := else-expr
-- end if;
-- and replace the conditional expression by a reference to Cnn.
if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then
Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C'));
New_If :=
Make_Implicit_If_Statement (N,
Condition => Relocate_Node (Cond),
Then_Statements => New_List (
Make_Assignment_Statement (Sloc (Thenx),
Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
Expression => Relocate_Node (Thenx))),
Else_Statements => New_List (
Make_Assignment_Statement (Sloc (Elsex),
Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
Expression => Relocate_Node (Elsex))));
Set_Assignment_OK (Name (First (Then_Statements (New_If))));
Set_Assignment_OK (Name (First (Else_Statements (New_If))));
if Present (Then_Actions (N)) then
Insert_List_Before
(First (Then_Statements (New_If)), Then_Actions (N));
end if;
if Present (Else_Actions (N)) then
Insert_List_Before
(First (Else_Statements (New_If)), Else_Actions (N));
end if;
Rewrite (N, New_Occurrence_Of (Cnn, Loc));
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Cnn,
Object_Definition => New_Occurrence_Of (Typ, Loc)));
Insert_Action (N, New_If);
Analyze_And_Resolve (N, Typ);
end if;
end Expand_N_Conditional_Expression;
-----------------------------------
-- Expand_N_Explicit_Dereference --
-----------------------------------
procedure Expand_N_Explicit_Dereference (N : Node_Id) is
begin
-- The only processing required is an insertion of an explicit
-- dereference call for the checked storage pool case.
Insert_Dereference_Action (Prefix (N));
end Expand_N_Explicit_Dereference;
-----------------
-- Expand_N_In --
-----------------
procedure Expand_N_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Rtyp : constant Entity_Id := Etype (N);
Lop : constant Node_Id := Left_Opnd (N);
Rop : constant Node_Id := Right_Opnd (N);
begin
-- If we have an explicit range, do a bit of optimization based
-- on range analysis (we may be able to kill one or both checks).
if Nkind (Rop) = N_Range then
declare
Lcheck : constant Compare_Result :=
Compile_Time_Compare (Lop, Low_Bound (Rop));
Ucheck : constant Compare_Result :=
Compile_Time_Compare (Lop, High_Bound (Rop));
begin
-- If either check is known to fail, replace result
-- by False, since the other check does not matter.
if Lcheck = LT or else Ucheck = GT then
Rewrite (N,
New_Reference_To (Standard_False, Loc));
Analyze_And_Resolve (N, Rtyp);
return;
-- 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
Rewrite (N,
New_Reference_To (Standard_True, Loc));
Analyze_And_Resolve (N, Rtyp);
return;
-- If lower bound check succeeds and upper bound check is
-- not known to succeed or fail, then replace the range check
-- with a comparison against the upper bound.
elsif Lcheck in Compare_GE then
Rewrite (N,
Make_Op_Le (Loc,
Left_Opnd => Lop,
Right_Opnd => High_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
return;
-- If upper bound check succeeds and lower bound check is
-- not known to succeed or fail, then replace the range check
-- with a comparison against the lower bound.
elsif Ucheck in Compare_LE then
Rewrite (N,
Make_Op_Ge (Loc,
Left_Opnd => Lop,
Right_Opnd => Low_Bound (Rop)));
Analyze_And_Resolve (N, Rtyp);
return;
end if;
end;
-- For all other cases of an explicit range, nothing to be done
return;
-- Here right operand is a subtype mark
else
declare
Typ : Entity_Id := Etype (Rop);
Is_Acc : constant Boolean := Is_Access_Type (Typ);
Obj : Node_Id := Lop;
Cond : Node_Id := Empty;
begin
Remove_Side_Effects (Obj);
-- For tagged type, do tagged membership operation
if Is_Tagged_Type (Typ) then
-- No expansion will be performed when Java_VM, as the
-- JVM back end will handle the membership tests directly
-- (tags are not explicitly represented in Java objects,
-- so the normal tagged membership expansion is not what
-- we want).
if not Java_VM then
Rewrite (N, Tagged_Membership (N));
Analyze_And_Resolve (N, Rtyp);
end if;
return;
-- If type is scalar type, rewrite as x in t'first .. t'last
-- This reason we do this is that the bounds may have the wrong
-- type if they come from the original type definition.
elsif Is_Scalar_Type (Typ) then
Rewrite (Rop,
Make_Range (Loc,
Low_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
Prefix => New_Reference_To (Typ, Loc)),
High_Bound =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
Prefix => New_Reference_To (Typ, Loc))));
Analyze_And_Resolve (N, Rtyp);
return;
end if;
-- Here we have a non-scalar type
if Is_Acc then
Typ := Designated_Type (Typ);
end if;
if not Is_Constrained (Typ) then
Rewrite (N,
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).
elsif Is_Array_Type (Typ) then
Check_Subscripts : declare
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id;
-- Build attribute reference E'Nam(Dim)
-----------------------------------
-- Construct_Attribute_Reference --
-----------------------------------
function Construct_Attribute_Reference
(E : Node_Id;
Nam : Name_Id;
Dim : Nat)
return Node_Id
is
begin
return
Make_Attribute_Reference (Loc,
Prefix => E,
Attribute_Name => Nam,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim)));
end Construct_Attribute_Reference;
-- Start processing for Check_Subscripts
begin
for J in 1 .. Number_Dimensions (Typ) loop
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj),
Name_First, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_First, J)));
Evolve_And_Then (Cond,
Make_Op_Eq (Loc,
Left_Opnd =>
Construct_Attribute_Reference
(Duplicate_Subexpr_No_Checks (Obj),
Name_Last, J),
Right_Opnd =>
Construct_Attribute_Reference
(New_Occurrence_Of (Typ, Loc), Name_Last, J)));
end loop;
if Is_Acc then
Cond :=
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end Check_Subscripts;
-- 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.
Obj := Relocate_Node (Left_Opnd (N));
if Has_Discriminants (Typ) then
Cond := Make_Op_Not (Loc,
Right_Opnd => Build_Discriminant_Checks (Obj, Typ));
if Is_Acc then
Cond := Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Obj,
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
else
Cond := New_Occurrence_Of (Standard_True, Loc);
end if;
Rewrite (N, Cond);
Analyze_And_Resolve (N, Rtyp);
end if;
end;
end if;
end Expand_N_In;
--------------------------------
-- Expand_N_Indexed_Component --
--------------------------------
procedure Expand_N_Indexed_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
P : constant Node_Id := Prefix (N);
T : constant Entity_Id := Etype (P);
begin
-- A special optimization, if we have an indexed component that
-- is selecting from a slice, then we can eliminate the slice,
-- since, for example, x (i .. j)(k) is identical to x(k). The
-- only difference is the range check required by the slice. The
-- range check for the slice itself has already been generated.
-- The range check for the subscripting operation is ensured
-- by converting the subject to the subtype of the slice.
-- This optimization not only generates better code, avoiding
-- slice messing especially in the packed case, but more importantly
-- bypasses some problems in handling this peculiar case, for
-- example, the issue of dealing specially with object renamings.
if Nkind (P) = N_Slice then
Rewrite (N,
Make_Indexed_Component (Loc,
Prefix => Prefix (P),
Expressions => New_List (
Convert_To
(Etype (First_Index (Etype (P))),
First (Expressions (N))))));
Analyze_And_Resolve (N, Typ);
return;
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 Is_Access_Type (T) then
-- Check whether the prefix comes from a debug pool, and generate
-- the check before rewriting.
Insert_Dereference_Action (P);
Rewrite (P,
Make_Explicit_Dereference (Sloc (N),
Prefix => Relocate_Node (P)));
Analyze_And_Resolve (P, Designated_Type (T));
end if;
-- Generate index and validity checks
Generate_Index_Checks (N);
if Validity_Checks_On and then Validity_Check_Subscripts then
Apply_Subscript_Validity_Checks (N);
end if;
-- All done for the non-packed case
if not Is_Packed (Etype (Prefix (N))) then
return;
end if;
-- For packed arrays that are not bit-packed (i.e. the case of an array
-- with one or more index types with a non-coniguous enumeration type),
-- we can always use the normal packed element get circuit.
if not Is_Bit_Packed_Array (Etype (Prefix (N))) then
Expand_Packed_Element_Reference (N);
return;
end if;
-- For a reference to a component of a bit packed array, we have to
-- 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,
-- This case is handled in Exp_Ch5.Expand_N_Assignment_Statement
-- Renaming objects in renaming associations
-- This case is handled when a use of the renamed variable occurs
-- Actual parameters for a procedure call
-- This case is handled in Exp_Ch6.Expand_Actuals
-- The second expression in a 'Read attribute reference
-- The prefix of an address or size attribute reference
-- The following circuit detects these exceptions
declare
Child : Node_Id := N;
Parnt : Node_Id := Parent (N);
begin
loop
if Nkind (Parnt) = N_Unchecked_Expression then
null;
elsif Nkind (Parnt) = N_Object_Renaming_Declaration
or else Nkind (Parnt) = N_Procedure_Call_Statement
or else (Nkind (Parnt) = N_Parameter_Association
and then
Nkind (Parent (Parnt)) = N_Procedure_Call_Statement)
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then (Attribute_Name (Parnt) = Name_Address
or else
Attribute_Name (Parnt) = Name_Size)
and then Prefix (Parnt) = Child
then
return;
elsif Nkind (Parnt) = N_Assignment_Statement
and then Name (Parnt) = Child
then
return;
-- 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)
then
Expand_Packed_Element_Reference (N);
return;
elsif Nkind (Parent (Parnt)) = N_Assignment_Statement
and then Name (Parent (Parnt)) = Parnt
then
return;
elsif Nkind (Parnt) = N_Attribute_Reference
and then Attribute_Name (Parnt) = Name_Read
and then Next (First (Expressions (Parnt))) = Child
then
return;
elsif (Nkind (Parnt) = N_Indexed_Component
or else Nkind (Parnt) = N_Selected_Component)
and then Prefix (Parnt) = Child
then
null;
else
Expand_Packed_Element_Reference (N);
return;
end if;
-- Keep looking up tree for unchecked expression, or if we are
-- the prefix of a possible assignment left side.
Child := Parnt;
Parnt := Parent (Child);
end loop;
end;
end Expand_N_Indexed_Component;
---------------------
-- Expand_N_Not_In --
---------------------
-- Replace a not in b by not (a in b) so that the expansions for (a in b)
-- can be done. This avoids needing to duplicate this expansion code.
procedure Expand_N_Not_In (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Rewrite (N,
Make_Op_Not (Loc,
Right_Opnd =>
Make_In (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd => Right_Opnd (N))));
Analyze_And_Resolve (N, Typ);
end Expand_N_Not_In;
-------------------
-- 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.
procedure Expand_N_Null (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Agg : Node_Id;
begin
if Ekind (Typ) = E_Access_Protected_Subprogram_Type then
Agg :=
Make_Aggregate (Loc,
Expressions => New_List (
New_Occurrence_Of (RTE (RE_Null_Address), Loc),
Make_Null (Loc)));
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.
Set_Etype (N, Typ);
end if;
exception
when RE_Not_Available =>
return;
end Expand_N_Null;
---------------------
-- Expand_N_Op_Abs --
---------------------
procedure Expand_N_Op_Abs (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Expr : constant Node_Id := Right_Opnd (N);
begin
Unary_Op_Validity_Checks (N);
-- Deal with software overflow checking
if not Backend_Overflow_Checks_On_Target
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:
-- [constraint_error when Expr = typ'Base'First]
-- with the usual Duplicate_Subexpr use coding for expr
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Expr),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Base_Type (Etype (Expr)), Loc),
Attribute_Name => Name_First)),
Reason => CE_Overflow_Check_Failed));
end if;
-- Vax floating-point types case
if Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Abs;
---------------------
-- Expand_N_Op_Add --
---------------------
procedure Expand_N_Op_Add (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- N + 0 = 0 + N = N for integer types
if Is_Integer_Type (Typ) then
if Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_0
then
Rewrite (N, Left_Opnd (N));
return;
elsif Compile_Time_Known_Value (Left_Opnd (N))
and then Expr_Value (Left_Opnd (N)) = Uint_0
then
Rewrite (N, Right_Opnd (N));
return;
end if;
end if;
-- Arithmetic overflow checks for signed integer/fixed point types
if Is_Signed_Integer_Type (Typ)
or else Is_Fixed_Point_Type (Typ)
then
Apply_Arithmetic_Overflow_Check (N);
return;
-- Vax floating-point types case
elsif Vax_Float (Typ) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Add;
---------------------
-- Expand_N_Op_And --
---------------------
procedure Expand_N_Op_And (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
if Is_Array_Type (Etype (N)) then
Expand_Boolean_Operator (N);
elsif Is_Boolean_Type (Etype (N)) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
end Expand_N_Op_And;
------------------------
-- Expand_N_Op_Concat --
------------------------
Max_Available_String_Operands : Int := -1;
-- This is initialized the first time this routine is called. It records
-- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are
-- available in the run-time:
--
-- 0 None available
-- 2 RE_Str_Concat available, RE_Str_Concat_3 not available
-- 3 RE_Str_Concat/Concat_2 available, RE_Str_Concat_4 not available
-- 4 RE_Str_Concat/Concat_2/3 available, RE_Str_Concat_5 not available
-- 5 All routines including RE_Str_Concat_5 available
Char_Concat_Available : Boolean;
-- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if
-- all three are available, False if any one of these is unavailable.
procedure Expand_N_Op_Concat (N : Node_Id) is
Opnds : List_Id;
-- List of operands to be concatenated
Opnd : Node_Id;
-- Single operand for concatenation
Cnode : Node_Id;
-- 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
Ctyp : Entity_Id;
-- Component type of concatenation represented by Cnode
begin
-- Initialize global variables showing run-time status
if Max_Available_String_Operands < 1 then
if not RTE_Available (RE_Str_Concat) then
Max_Available_String_Operands := 0;
elsif not RTE_Available (RE_Str_Concat_3) then
Max_Available_String_Operands := 2;
elsif not RTE_Available (RE_Str_Concat_4) then
Max_Available_String_Operands := 3;
elsif not RTE_Available (RE_Str_Concat_5) then
Max_Available_String_Operands := 4;
else
Max_Available_String_Operands := 5;
end if;
Char_Concat_Available :=
RTE_Available (RE_Str_Concat_CC)
and then
RTE_Available (RE_Str_Concat_CS)
and then
RTE_Available (RE_Str_Concat_SC);
end if;
-- Ensure validity of both operands
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 Nkind (Parent (N)) = N_Op_Concat
and then N = Left_Opnd (Parent (N))
then
return;
end if;
-- We get here with a concatenation whose left operand may be a
-- concatenation itself with a consistent type. We need to process
-- these concatenation operands from left to right, which means
-- from the deepest node in the tree to the highest node.
Cnode := N;
while Nkind (Left_Opnd (Cnode)) = N_Op_Concat loop
Cnode := Left_Opnd (Cnode);
end loop;
-- Now Opnd is the deepest Opnd, and its parents are the concatenation
-- nodes above, so now we process bottom up, doing the operations. We
-- gather a string that is as long as possible up to five operands
-- The outer loop runs more than once if there are more than five
-- concatenations of type Standard.String, the most we handle for
-- this case, or if more than one concatenation type is involved.
Outer : loop
Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode));
Set_Parent (Opnds, N);
-- The inner loop gathers concatenation operands. We gather any
-- number of these in the non-string case, or if no concatenation
-- routines are available for string (since in that case we will
-- treat string like any other non-string case). Otherwise we only
-- gather as many operands as can be handled by the available
-- procedures in the run-time library (normally 5, but may be
-- less for the configurable run-time case).
Inner : while Cnode /= N
and then (Base_Type (Etype (Cnode)) /= Standard_String
or else
Max_Available_String_Operands = 0
or else
List_Length (Opnds) <
Max_Available_String_Operands)
and then Base_Type (Etype (Cnode)) =
Base_Type (Etype (Parent (Cnode)))
loop
Cnode := Parent (Cnode);
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.
Atyp := Base_Type (Etype (Cnode));
Ctyp := Base_Type (Component_Type (Etype (Cnode)));
if (List_Length (Opnds) > 2 or else Atyp /= Standard_String)
or else not Char_Concat_Available
then
Opnd := First (Opnds);
loop
if Base_Type (Etype (Opnd)) = Ctyp then
Rewrite (Opnd,
Make_Aggregate (Sloc (Cnode),
Expressions => New_List (Relocate_Node (Opnd))));
Analyze_And_Resolve (Opnd, Atyp);
end if;
Next (Opnd);
exit when No (Opnd);
end loop;
end if;
-- Now call appropriate continuation routine
if Atyp = Standard_String
and then Max_Available_String_Operands > 0
then
Expand_Concatenate_String (Cnode, Opnds);
else
Expand_Concatenate_Other (Cnode, Opnds);
end if;
exit Outer when Cnode = N;
Cnode := Parent (Cnode);
end loop Outer;
end Expand_N_Op_Concat;
------------------------
-- Expand_N_Op_Divide --
------------------------
procedure Expand_N_Op_Divide (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ltyp : constant Entity_Id := Etype (Left_Opnd (N));
Rtyp : constant Entity_Id := Etype (Right_Opnd (N));
Typ : Entity_Id := Etype (N);
begin
Binary_Op_Validity_Checks (N);
-- Vax_Float is a special case
if Vax_Float (Typ) then
Expand_Vax_Arith (N);
return;
end if;
-- N / 1 = N for integer types
if Is_Integer_Type (Typ)
and then Compile_Time_Known_Value (Right_Opnd (N))
and then Expr_Value (Right_Opnd (N)) = Uint_1
then
Rewrite (N, Left_Opnd (N));
return;
end if;
-- Convert x / 2 ** y to Shift_Right (x, y). Note that the fact that
-- Is_Power_Of_2_For_Shift is set means that we know that our left
-- operand is an unsigned integer, as required for this to work.
if Nkind (Right_Opnd (N)) = N_Op_Expon
and then Is_Power_Of_2_For_Shift (Right_Opnd (N))
-- We cannot do this transformation in configurable run time mode if we
-- have 64-bit -- integers and long shifts are not available.
and then
(Esize (Ltyp) <= 32
or else Support_Long_Shifts_On_Target)
then
Rewrite (N,
Make_Op_Shift_Right (Loc,
Left_Opnd => Left_Opnd (N),
Right_Opnd =>
Convert_To (Standard_Natural, Right_Opnd (Right_Opnd (N)))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Do required fixup of universal fixed operation
if Typ = Universal_Fixed then
Fixup_Universal_Fixed_Operation (N);
Typ := Etype (N);
end if;
-- Divisions with fixed-point results
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.
if not Treat_Fixed_As_Integer (N) then
if Is_Integer_Type (Rtyp) then
Expand_Divide_Fixed_By_Integer_Giving_Fixed (N);
else
Expand_Divide_Fixed_By_Fixed_Giving_Fixed (N);
end if;
end if;
-- 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))
and then not Treat_Fixed_As_Integer (N)
then
if Is_Integer_Type (Typ) then
Expand_Divide_Fixed_By_Fixed_Giving_Integer (N);
else
pragma Assert (Is_Floating_Point_Type (Typ));
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.
elsif Typ = Universal_Real
and then Is_Integer_Type (Rtyp)
then
Rewrite (Right_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Right_Opnd (N))));
Analyze_And_Resolve (Right_Opnd (N), Universal_Real);
elsif Typ = Universal_Real
and then Is_Integer_Type (Ltyp)
then
Rewrite (Left_Opnd (N),
Convert_To (Universal_Real, Relocate_Node (Left_Opnd (N))));
Analyze_And_Resolve (Left_Opnd (N), Universal_Real);
-- Non-fixed point cases, do zero divide and overflow checks
elsif Is_Integer_Type (Typ) then
Apply_Divide_Check (N);
-- Check for 64-bit division available
if Esize (Ltyp) > 32
and then not Support_64_Bit_Divides_On_Target
then
Error_Msg_CRT ("64-bit division", N);
end if;
end if;
end Expand_N_Op_Divide;
--------------------
-- Expand_N_Op_Eq --
--------------------
procedure Expand_N_Op_Eq (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Lhs : constant Node_Id := Left_Opnd (N);
Rhs : constant Node_Id := Right_Opnd (N);
Bodies : constant List_Id := New_List;
A_Typ : constant Entity_Id := Etype (Lhs);
Typl : Entity_Id := A_Typ;
Op_Name : Entity_Id;
Prim : Elmt_Id;
procedure Build_Equality_Call (Eq : Entity_Id);
-- If a constructed equality exists for the type or for its parent,
-- build and analyze call, adding conversions if the operation is
-- inherited.
-------------------------
-- Build_Equality_Call --
-------------------------
procedure Build_Equality_Call (Eq : Entity_Id) is
Op_Type : constant Entity_Id := Etype (First_Formal (Eq));
L_Exp : Node_Id := Relocate_Node (Lhs);
R_Exp : Node_Id := Relocate_Node (Rhs);
begin
if Base_Type (Op_Type) /= Base_Type (A_Typ)
and then not Is_Class_Wide_Type (A_Typ)
then
L_Exp := OK_Convert_To (Op_Type, L_Exp);
R_Exp := OK_Convert_To (Op_Type, R_Exp);
end if;
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (Eq, Loc),
Parameter_Associations => New_List (L_Exp, R_Exp)));
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end Build_Equality_Call;
-- Start of processing for Expand_N_Op_Eq
begin
Binary_Op_Validity_Checks (N);
if Ekind (Typl) = E_Private_Type then
Typl := Underlying_Type (Typl);
elsif Ekind (Typl) = E_Private_Subtype then
Typl := Underlying_Type (Base_Type (Typl));
end if;
-- It may happen in error situations that the underlying type is not
-- set. The error will be detected later, here we just defend the
-- expander code.
if No (Typl) then
return;
end if;
Typl := Base_Type (Typl);
-- Vax float types
if Vax_Float (Typl) then
Expand_Vax_Comparison (N);
return;
-- Boolean types (requiring handling of non-standard case)
elsif Is_Boolean_Type (Typl) then
Adjust_Condition (Left_Opnd (N));
Adjust_Condition (Right_Opnd (N));
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
-- Array types
elsif Is_Array_Type (Typl) then
-- If we are doing full validity checking, then expand out array
-- comparisons to make sure that we check the array elements.
if Validity_Check_Operands then
declare
Save_Force_Validity_Checks : constant Boolean :=
Force_Validity_Checks;
begin
Force_Validity_Checks := True;
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Insert_Actions (N, Bodies);
Analyze_And_Resolve (N, Standard_Boolean);
Force_Validity_Checks := Save_Force_Validity_Checks;
end;
-- Packed case
elsif Is_Bit_Packed_Array (Typl) then
Expand_Packed_Eq (N);
-- For non-floating-point elementary types, the primitive equality
-- always applies, and block-bit comparison is fine. Floating-point
-- is an exception because of negative zeroes.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then Support_Composite_Compare_On_Target
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.
else
Rewrite (N,
Expand_Array_Equality (N, Typl, A_Typ,
Relocate_Node (Lhs), Relocate_Node (Rhs), Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
-- Record Types
elsif Is_Record_Type (Typl) then
-- For tagged types, use the primitive "="
if Is_Tagged_Type (Typl) then
-- 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 (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
Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
while Chars (Node (Prim)) /= Name_Op_Eq loop
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Op_Name := Node (Prim);
-- Find the type's predefined equality or an overriding
-- 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).
else
if Is_Class_Wide_Type (Typl) then
Typl := Root_Type (Typl);
end if;
Prim := First_Elmt (Primitive_Operations (Typl));
while Present (Prim) loop
exit when Chars (Node (Prim)) = Name_Op_Eq
and then Etype (First_Formal (Node (Prim))) =
Etype (Next_Formal (First_Formal (Node (Prim))))
and then
Base_Type (Etype (Node (Prim))) = Standard_Boolean;
Next_Elmt (Prim);
pragma Assert (Present (Prim));
end loop;
Op_Name := Node (Prim);
end if;
Build_Equality_Call (Op_Name);
-- If a type support function is present (for complex cases), use it
elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then
Build_Equality_Call
(TSS (Root_Type (Typl), TSS_Composite_Equality));
-- Otherwise expand the component by component equality. Note that
-- we never use block-bit coparisons for records, because of the
-- problems with gaps. The backend will often be able to recombine
-- the separate comparisons that we generate here.
else
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
Rewrite (N,
Expand_Record_Equality (N, Typl, Lhs, Rhs, Bodies));
Insert_Actions (N, Bodies, Suppress => All_Checks);
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
end if;
end if;
-- If we still have an equality comparison (i.e. it was not rewritten
-- in some way), then we can test if result is needed at compile time).
if Nkind (N) = N_Op_Eq then
Rewrite_Comparison (N);
end if;
end Expand_N_Op_Eq;
-----------------------
-- Expand_N_Op_Expon --
-----------------------
procedure Expand_N_Op_Expon (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Rtyp : constant Entity_Id := Root_Type (Typ);
Base : constant Node_Id := Relocate_Node (Left_Opnd (N));
Bastyp : constant Node_Id := Etype (Base);
Exp : constant Node_Id := Relocate_Node (Right_Opnd (N));
Exptyp : constant Entity_Id := Etype (Exp);
Ovflo : constant Boolean := Do_Overflow_Check (N);
Expv : Uint;
Xnode : Node_Id;
Temp : Node_Id;
Rent : RE_Id;
Ent : Entity_Id;
Etyp : Entity_Id;
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 Is_Private_Type (Etype (Base))
or else
Is_Private_Type (Typ)
or else
Is_Private_Type (Exptyp)
or else
Rtyp /= Root_Type (Bastyp)
then
declare
Bt : constant Entity_Id := Root_Type (Underlying_Type (Bastyp));
Et : constant Entity_Id := Root_Type (Underlying_Type (Exptyp));
begin
Rewrite (N,
Unchecked_Convert_To (Typ,
Make_Op_Expon (Loc,
Left_Opnd => Unchecked_Convert_To (Bt, Base),
Right_Opnd => Unchecked_Convert_To (Et, Exp))));
Analyze_And_Resolve (N, Typ);
return;
end;
end if;
-- Test for case of known right argument
if Compile_Time_Known_Value (Exp) then
Expv := Expr_Value (Exp);
-- We only fold small non-negative exponents. You might think we
-- could fold small negative exponents for the real case, but we
-- can't because we are required to raise Constraint_Error for
-- the case of 0.0 ** (negative) even if Machine_Overflows = False.
-- See ACVC test C4A012B.
if Expv >= 0 and then Expv <= 4 then
-- X ** 0 = 1 (or 1.0)
if Expv = 0 then
if Ekind (Typ) in Integer_Kind then
Xnode := Make_Integer_Literal (Loc, Intval => 1);
else
Xnode := Make_Real_Literal (Loc, Ureal_1);
end if;
-- X ** 1 = X
elsif Expv = 1 then
Xnode := Base;
-- X ** 2 = X * X
elsif Expv = 2 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
-- X ** 3 = X * X * X
elsif Expv = 3 then
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr_No_Checks (Base)),
Right_Opnd => Duplicate_Subexpr_No_Checks (Base));
-- X ** 4 ->
-- En : constant base'type := base * base;
-- ...
-- En * En
else -- Expv = 4
Temp :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
Object_Definition => New_Reference_To (Typ, Loc),
Expression =>
Make_Op_Multiply (Loc,
Left_Opnd => Duplicate_Subexpr (Base),
Right_Opnd => Duplicate_Subexpr_No_Checks (Base)))));
Xnode :=
Make_Op_Multiply (Loc,
Left_Opnd => New_Reference_To (Temp, Loc),
Right_Opnd => New_Reference_To (Temp, Loc));
end if;
Rewrite (N, Xnode);
Analyze_And_Resolve (N, Typ);
return;
end if;
end if;
-- Case of (2 ** expression) appearing as an argument of an integer
-- multiplication, or as the right argument of a division of a non-
-- negative integer. In such cases we leave the node untouched, setting
-- the flag Is_Natural_Power_Of_2_for_Shift set, then the expansion
-- of the higher level node converts it into a shift.
if Nkind (Base) = N_Integer_Literal
and then Intval (Base) = 2
and then Is_Integer_Type (Root_Type (Exptyp))
and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
and then Is_Unsigned_Type (Exptyp)
and then not Ovflo
and then Nkind (Parent (N)) in N_Binary_Op
then
declare
P : constant Node_Id := Parent (N);
L : constant Node_Id := Left_Opnd (P);
R : constant Node_Id := Right_Opnd (P);
begin
if (Nkind (P) = N_Op_Multiply
and then
((Is_Integer_Type (Etype (L)) and then R = N)
or else
(Is_Integer_Type (Etype (R)) and then L = N))
and then not Do_Overflow_Check (P))
or else
(Nkind (P) = N_Op_Divide
and then Is_Integer_Type (Etype (L))
and then Is_Unsigned_Type (Etype (L))
and then R = N
and then not Do_Overflow_Check (P))
then
Set_Is_Power_Of_2_For_Shift (N);
return;
end if;
end;
end if;
-- Fall through if exponentiation must be done using a runtime routine
-- First deal with modular case
if Is_Modular_Integer_Type (Rtyp) then
-- Non-binary case, we call the special exponentiation routine for
-- the non-binary case, converting the argument to Long_Long_Integer
-- and passing the modulus value. Then the result is converted back
-- to the base type.
if Non_Binary_Modulus (Rtyp) then
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (RE_Exp_Modular), Loc),
Parameter_Associations => New_List (
Convert_To (Standard_Integer, Base),
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.
else
if UI_To_Int (Esize (Rtyp)) <= Standard_Integer_Size then
Ent := RTE (RE_Exp_Unsigned);
else
Ent := RTE (RE_Exp_Long_Long_Unsigned);
end if;
Rewrite (N,
Convert_To (Typ,
Make_Op_And (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name => New_Reference_To (Ent, Loc),
Parameter_Associations => New_List (
Convert_To (Etype (First_Formal (Ent)), Base),
Exp)),
Right_Opnd =>
Make_Integer_Literal (Loc, Modulus (Rtyp) - 1))));
end if;
-- Common exit point for modular type case
Analyze_And_Resolve (N, Typ);
return;
-- Signed integer cases, done using either Integer or Long_Long_Integer.
-- It is not worth having routines for Short_[Short_]Integer, since for
-- most machines it would not help, and it would generate more code that
-- might need certification in the HI-E case.
-- In the integer cases, we have two routines, one for when overflow
-- checks are required, and one when they are not required, since
-- there is a real gain in ommitting checks on many machines.
elsif Rtyp = Base_Type (Standard_Long_Long_Integer)
or else (Rtyp = Base_Type (Standard_Long_Integer)
and then
Esize (Standard_Long_Integer) > Esize (Standard_Integer))
or else (Rtyp = Universal_Integer)
then
Etyp := Standard_Long_Long_Integer;
if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
end if;
elsif Is_Signed_Integer_Type (Rtyp) then
Etyp := Standard_Integer;
if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
end if;
-- Floating-point cases, always done using Long_Long_Float. We do not
-- need separate routines for the overflow case here, since in the case
-- of floating-point, we generate infinities anyway as a rule (either
-- that or we automatically trap overflow), and if there is an infinity
-- generated and a range check is required, the check will fail anyway.
else
pragma Assert (Is_Floating_Point_Type (Rtyp));
Etyp := Standard_Long_Long_Float;
Rent := RE_Exn_Long_Long_Float;
end if;
-- Common processing for integer cases and floating-point cases.
-- If we are in the right type, we can call runtime routine directly
if Typ = Etyp
and then Rtyp /= Universal_Integer
and then Rtyp /= Universal_Real
then
Rewrite (N,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (Base, Exp)));
-- Otherwise we have to introduce conversions (conversions are also
-- required in the universal cases, since the runtime routine is
-- typed using one of the standard types.
else
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Reference_To (RTE (Rent), Loc),
Parameter_Associations => New_List (
Convert_To (Etyp, Base),
Exp))));
end if;
Analyze_And_Resolve (N, Typ);
return;
exception
when RE_Not_Available =>
return;
end Expand_N_Op_Expon;
--------------------
-- Expand_N_Op_Ge --
--------------------
procedure Expand_N_Op_Ge (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Ge;
--------------------
-- Expand_N_Op_Gt --
--------------------
procedure Expand_N_Op_Gt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Gt;
--------------------
-- Expand_N_Op_Le --
--------------------
procedure Expand_N_Op_Le (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Le;
--------------------
-- Expand_N_Op_Lt --
--------------------
procedure Expand_N_Op_Lt (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Op1 : constant Node_Id := Left_Opnd (N);
Op2 : constant Node_Id := Right_Opnd (N);
Typ1 : constant Entity_Id := Base_Type (Etype (Op1));
begin
Binary_Op_Validity_Checks (N);
if Vax_Float (Typ1) then
Expand_Vax_Comparison (N);
return;
elsif Is_Array_Type (Typ1) then
Expand_Array_Comparison (N);
return;
end if;
if Is_Boolean_Type (Typ1) then
Adjust_Condition (Op1);
Adjust_Condition (Op2);
Set_Etype (N, Standard_Boolean);
Adjust_Result_Type (N, Typ);
end if;
Rewrite_Comparison (N);
end Expand_N_Op_Lt;
-----------------------
-- Expand_N_Op_Minus --
-----------------------
procedure Expand_N_Op_Minus (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
Unary_Op_Validity_Checks (N);
if not Backend_Overflow_Checks_On_Target
and then Is_Signed_Integer_Type (Etype (N))
and then Do_Overflow_Check (N)
then
-- Software overflow checking expands -expr into (0 - expr)
Rewrite (N,
Make_Op_Subtract (Loc,
Left_Opnd => Make_Integer_Literal (Loc, 0),
Right_Opnd => Right_Opnd (N)));
Analyze_And_Resolve (N, Typ);
-- Vax floating-point types case
elsif Vax_Float (Etype (N)) then
Expand_Vax_Arith (N);
end if;
end Expand_N_Op_Minus;
---------------------
-- Expand_N_Op_Mod --
---------------------
procedure Expand_N_Op_Mod (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
DOC : constant Boolean := Do_Overflow_Check (N);
DDC : constant Boolean := Do_Division_Check (N);
LLB : Uint;
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
begin
Binary_Op_Validity_Checks (N);
Determine_Range (Right, ROK, Rlo, Rhi);
Determine_Range (Left, LOK, Llo, Lhi);
-- Convert mod to rem if operands are known non-negative. We do this
-- since it is quite likely that this will improve the quality of code,
-- (the operation now corresponds to the hardware remainder), and it
-- does not seem likely that it could be harmful.
if LOK and then Llo >= 0
and then
ROK and then Rlo >= 0
then
Rewrite (N,
Make_Op_Rem (Sloc (N),
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.
Set_Entity (N, Standard_Entity (S_Op_Rem));
Set_Etype (N, Typ);
Set_Do_Overflow_Check (N, DOC);
Set_Do_Division_Check (N, DDC);
Expand_N_Op_Rem (N);
Set_Analyzed (N);
-- Otherwise, normal mod processing
else
if Is_Integer_Type (Etype (N)) then
Apply_Divide_Check (N);
end if;
-- Apply optimization x mod 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)
and then Expr_Value (Right) = Uint_1
then
Rewrite (N, Make_Integer_Literal (Loc, 0));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- Deal with annoying case of largest negative number remainder
-- minus one. Gigi does not handle this case correctly, because
-- it generates a divide instruction which may trap in this case.
-- In fact the check is quite easy, if the right operand is -1,